' NAME: OpenFilesUserSessionAuditor.vbs
'
' AUTHOR: Alan dot Kaplan at VA dot Gov 
' DATE  : 2/28/2011
'
' COMMENT: This script creates a report of who is accessing what files on a server
' It uses the NT LANManServer Sessions and Resources objects
' It can be run locally or remotely with admin rights
' v3 improved error handling and messages.  Renamed from SessionFileAuditor.vbs
'==========================================================================
Option Explicit 
Const ForAppend = 8
Const adOpenStatic = 3
Const adOpenForward = 0
Const adLockOptimistic = 3

dim fso, appendout
Dim objCon 			'connection to Access
Dim dbName, sqlRS, objRS
Dim retval, message
Dim ocommand, strsql 	'As ADODB.Command
Dim wshShell: Set wshShell = WScript.CreateObject("WScript.Shell")
dim quote: quote=chr(34)
Dim bAppend:bAppend = False
Set objCon = CreateObject("ADODB.Connection")
Dim strServer, strComputer
Dim objConnection, ColResources, objResource, colSessions, objSession
Dim oFile,iSize, strIP, strUserName
Dim iMaxSize
Dim d: Set d = CreateObject("Scripting.Dictionary") 
Dim strReportFile
Dim dFutureTime
Dim bExcel
Set objRS = CreateObject("ADODB.Recordset")
Set fso = CreateObject("Scripting.FileSystemObject")

'Make sure running Cscript.
If (Not IsCScript()) Then 		'If not CScript, re-run with cscript...
	WshShell.Run "CScript.exe " & quote & WScript.ScriptFullName & quote, 1, true
    WScript.Quit            	'...and stop running as WScript
End If

strServer = wshShell.ExpandEnvironmentStrings("%COMPUTERNAME%")
message = "This script records user sessions with open files on a server. It can be run locally or remotely.  " & _
"You can set the duration of the monitoring and the size of the temporary database created." &  VbCrLf & VbCrLf & _
"This has much less overhead than enabling file auditing, " & _
"and may be used to monitor suspect access.  Typical network traffic for remote monitoring is 2-4 kb per query." & VbCrLf & VbCrLf & _
"You do not have to have Excel or Access installed, but you must run it with administrative rights.  " & VbCrLf & VbCrLf & _
"Monitor what server:"
strServer = InputBox(message,"Which server do you want to monitor",strServer) 
If strServer  = "" Then WScript.Quit
strServer = UCase(strServer)
'get path name, ending in \
Dim scriptpath: scriptpath =fso.Getfile(WScript.ScriptFullName).parentfolder.path & "\"
dbName = scriptpath  & "SessionFileAuditor.mdb"

'Delete old Access DB 
On Error Resume Next
If fso.FileExists(dbName) Then 
	message = "The temporary database exists.  You can" & vbcrlf & _ 
	"1) Delete it." & vbcrlf & _
	"2) Append to it, adding new entries" & VbCrLf &  _
	"3) Run report from it.  Do this if you ended a query early" & vbcrlf & _
	"0) Exit program"
	retval = InputBox(Message,"File Exists",1)
	Select Case RetVal
		Case 0 
			WScript.Quit
		Case 1 
			fso.DeleteFile(dbName)
			If Err <> 0 Then 
				MsgBox "Cannot delete open file.  Close " & dbName,vbcritical + vbokonly,"Open File Error"
				WScript.Quit
			Else
				CreateDB
			End If 
		Case 2
	 		bAppend = True
	 	Case 3
	 		DBConnect objCon, objRS 
	 		Reports()
	 End Select 
Else 
	CreateDB
End If

On Error goto 0

'Get length of time to run
Runtime
message = "Data collected is filtered to remove multiple entries to reduce spaces.  Maximum Size for temporary database in MB:"
iMaxSize = InputBox (message,"Max Database Size",2048 )

Do until (TimeValue(Now)> TimeValue(dFutureTime)) and (DateValue(Now)=DateValue(dFutureTime))
	WScript.Echo VbCrLf &  "It is now " & Time & ". Running data collection from " & strServer & " until " &   dFutureTime
	Set oFile = fso.getFile(dbName)
	iSize = oFile.Size /1024 /1045
	WScript.Echo "Database size is " & round(iSize,2) & " MB"
	
	If iSize > iMaxSize Then 
		WScript.Echo "Quit at " & Time & " when database reached maximum size, " & iMaxSize
		Exit Do
	Else
		Query()
	End If 
Loop 

Reports


'==================
'Functions and Subs
'==================
Sub CreateDB() 
	' With this you can make an Access DB even if you don't have Access installed
 	Dim OConnMDB
 	Set OConnMDB = CreateObject("ADOX.Catalog")
 	OConnMDB.Create _
 	    "Provider = Microsoft.Jet.OLEDB.4.0; " & _
 	        "Data Source = " &dbname 
 	Set oConnMDB = Nothing
	
	objCon.Open _
	    "Provider= Microsoft.Jet.OLEDB.4.0; " & _
	        "Data Source=" & dbName 	
	objCon.Execute "CREATE TABLE Resources(rUserName TEXT(50),FileName TEXT(255))"
	objCon.Execute "CREATE TABLE Sessions(sUserName TEXT(50),IP TEXT(25),Computer TEXT(50),[First Seen] DATE, [Last Seen] DATE)"
End Sub 


Sub DBConnect (byref objcon, byref objRS)
	'overly elaborate code lifted from another of my scripts
	Dim strdbpath,Constr, SQLError
	strDBPath = dbName
	Set objCon =  WScript.CreateObject("adodb.connection")

	On Error Resume next

	Constr = "Driver={Microsoft Access Driver (*.mdb)};DBQ=" & strDBPath & ";"
	objCon.open(Constr)

	If Err.Number <> 0 Then
		If  objRS.State = 1 Then objRS.Close
		If  objcon.State = 1 Then objcon.Close
		SQLError = SQLError + 1
			If sqlError = 10 Then
				Wscript.Echo strComputer & "failed to connect to db with " & WScript.ScriptName
				wscript.sleep 2000
				WScript.Quit 
			End If 
			
		WScript.echo Err.Description
		WScript.Echo "Error Connecting to temporary database " & vbcrlf & strsql & vbcrlf & "Retrying..." 
		wscript.sleep 100
		DBConnect objCon, objRS
		wscript.sleep 100
		Err.Clear
	 Else
		wscript.echo "Connected to temporary Access database"
		set objRS = WScript.CreateObject("adodb.recordset")
	End If 
End Sub


Sub Query()
	On Error Resume Next 
	'The LanManServer object gets this information best.
	If objCon.state = 0 Then  DBConnect objCon, objRS
	Set objConnection = GetObject("WinNT://" & strServer & "/LanmanServer")
	If Err <>  0 Then Exit Sub 'sometimes fails for no good reason
	Set ColResources = objConnection.Resources 
	Set colSessions  = objConnection.Sessions
	
	For Each objResource in colResources 
		If len(objResource.User) > 0  Then 
			AddResourceRow objResource.User, objResource.Path
		End If 
	Next 
	objRS.Close
	On Error GoTo 0
	
	For Each objSession in colSessions
		On Error Resume Next 
		If len(objSession.User) > 1 and right(objSession.Computer,1) <> "$" Then
			strUserName = objSession.User
			If IsIP(objSession.Computer) Then 
				strIP = objSession.Computer
				'It is an IP, Look up Name
				strComputer = DNSName(strIP)
			Else
				' it is a name, get IP
				strIP = getIP(objSession.Computer)
			End If 
			
			strComputer = DNSName(strIP)
			If Len (strComputer) = 0 Then strComputer = "Not Available"
			AddSessionRow strUserName, strIP, strComputer
		End If 
	Next 
	bAppend = True
End Sub 

Sub Reports()
	'Name of Report.  Can open in Excel. delimiter is TAB
	strReportFile = wshShell.ExpandEnvironmentStrings("%USERPROFILE%\desktop\SessionFileAuditor.xls")
	'Delete old report
	If fso.FileExists(strReportFile) then fso.DeleteFile strReportFile,true
	set AppendOut = fso.OpenTextFile(strReportFile, ForAppend, True)
	appendout.WriteLine "IP	Computer	User	First Seen	Last Seen	FileName"
	WScript.echo "Writing Report  ..."
	WScript.Sleep 3
	
	If objRS.State = 1 Then objRS.Close
	
	strsql ="SELECT DISTINCT Sessions.IP, Sessions.Computer, Resources.rUserName AS [User], Resources.FileName," & _
	"Sessions.[First Seen], Sessions.[Last Seen] FROM Resources LEFT JOIN Sessions ON Resources.rUserName = Sessions.sUserName " & _
	"ORDER BY Sessions.Computer;"
	
	objRS.Open strsql, objCon, adOpenStatic, adLockOptimistic
	objRS.MoveFirst
	
	'write out Report
	Do Until objRS.EOF
		If instr(objRS("FileName"),"PIPE") = 0  Then 
    		WriteLog objRS("IP") & vbTab & objRS("Computer") & vbTab & objRS("User") & vbTab & _
    		 objRS("First Seen") & vbTab &  objRS("Last Seen") & vbTab & objRS("FileName")
    	End If 
	    objRS.MoveNext
	Loop
	
	appendout.Close
	
	if objRS.State = 1 then objRS.Close
	if objCon.State - 1 then objCon.Close
	Set objRS = Nothing 
	Set objCon = Nothing
	
	message = "Do you want to delete the database file," & dbName & "?  It is no longer required.  However," & VbCrLf & VbCrLf & _  
	" if you have Access installed, you can see raw data collected.  Also, the script permits appending of data for later queries."
	retval = MsgBox(message,vbyesno + vbquestion,"Delete Temporary Access Database File?")
	
	If retval = vbyes Then 
	 	fso.DeleteFile(dbName)
	End If 
	
	SaveAsExcel(strReportFile)
	
	If bExcel Then 
		message = "Open report, " & strReportFile & ", now?"
	Else
		message= "Report, " & strReportFile & ", is a tab delimited text file.  Open it now?"
	End If 
	
	retval = MsgBox(message,vbYesNo+vbQuestion,"View Report File Now?")
	if retval = vbyes Then 
		wshShell.Run(strReportFile)
		WScript.Quit(0)
	Else
		WScript.Quit
	End If 
End Sub

Function DNSName(strIP)
	'Redo dictionary if it has too many items
	'too much work to switch this process to database query
	
	If d.Count > 500 Then d.RemoveAll

	dim	aname, strname, dnsmessage 
	Dim objExec, strNBTResults,retstring
	
	'Use a dictionary object so you don't have to ping multiple times for same IP
	'Look first to see if in dictionary, if not add
	If d.Exists(strIP) Then
	 	'WScript.Echo "Found " & strIP & " " & d.item(strip)
		DNSName =   d.item(strip)
		Exit Function 
	End If

	'ping the computer with ARP option
	Set objExec=wshShell.Exec("ping -n 1 -a "  & strIP)

'	One line at a Time
	While Not(objExec.StdOut.AtEndOfStream)
	retstring = lcase(objExec.StdOut.Readline()) 
		If (instr(retstring, "[")>0) and (instr(retString, "~")= 0) Then
			strname = retstring
			aname = split(retstring," [")
			dnsname = ucase(trim(aname(0)))
			aname = Array()
			aname = Split(DNSName)
			DNSName = aname(1)
		End If 
	Wend
	
	If Len(DNSName) < 2 Then DNSName = strIP
	d.Add strIP,DNSName
End Function 

Sub AddResourceRow(strUsername,strFilename)
	'if row does not exist add
	If Left(strFilename,1) = "\" Then Exit Sub 'Pipes
	strSQL = "select * from Resources where rUserName = '" & strUsername & "' and FileName = '" & strFilename & "'"
	objRS.open strSQL, objcon
 	If objRS.eof Then
		strSQL = "Insert into Resources (rUserName,FileName) values ('" & strUsername & "','" & strFilename & "')"
		SQLExecute
 	End If 
	If  objRS.State = 1 Then objRS.Close
End Sub 

Sub AddSessionRow( strUserName, strIP, strComputer)
	'If row does not exist, add.  If exists, update last seen timestamp
	strSQL = "select * from Sessions where IP = '" & strIP & "'"
	objRS.open strSQL, objCon
	'New Record
 	If objRS.eof Then	
		strSQL = "Insert into Sessions (sUserName, IP, Computer, [First Seen], [Last Seen])" & _
			" values ('" & strUserName & "','" & strIP & "','" & StrComputer & "',#" & Now & "#,#" & Now & "#)"
		SQLExecute
 	Else
 		strSQL = "Update Sessions set [Last Seen] = #"& Now & "# where IP = '" & strIP & "'"
 		SQLExecute
 	End If
	If  objRS.State = 1 Then objRS.Close
End Sub 

Sub SQLExecute()
	'overly elaborate code lifted from another of my scripts
	'WScript.Echo strsql
	On Error Resume Next

	objcon.execute strSQL
	'Try again if error
	If Err.Number <> 0 Then
		If  objRS.State = 1 Then objRS.Close
		If  objcon.State = 1 Then objcon.Close
		SQLError = SQLError + 1
		
		If sqlError = 10 Then
			WScript.Quit 
		End If 
		
		WScript.echo Err.Description
		WScript.Echo "Error Posting Data " & vbcrlf & strsql & vbcrlf & "Retrying..." 
		wscript.sleep 100
		DBConnect objcon, objRS
		wscript.sleep 1000
		SQLExecute
		Err.Clear
	End If
	On Error goto 0
End Sub


Function IsIP(strTest)
	IsIP = False
	Dim oRegEx, match, matches, strPattern
	Set oRegEx = New RegExp
	strPattern = "^(25[0-4]|2[0-4][0-9]|1[0-9]{2}|[1-9]{1}[0-9]{1}|[1-9])\.(25[0-4]|2[0-4][0-9]|1[0-9]{2}|[1-9]{1}[0-9]{1}|[1-9]|0)\.(25[0-4]|2[0-4][0-9]|1[0-9]{2}|[1-9]{1}[0-9]{1}|[1-9]|0)\.(25[0-4]|2[0-4][0-9]|1[0-9]{2}|[1-9]{1}[0-9]{1}|[1-9])$"
    oRegEx.Pattern = strPattern
	Set matches = oRegEx.Execute(strTest)   ' Execute search.
	For Each match In matches 
		If Matches.count = 1 Then
		   IsIP = True
		End If 
	Next 
	set oRegEx = Nothing
End Function

Function GetIP(strcomputer) 
	Dim objScriptExec, strPingResults
	Dim objRE, match, matches

	'RegEx pattern from Bill Stewart
	Set objRE = New RegExp
    objRE.Pattern = " [0-9]{1,3}\.[0-9]{1,3}\.[0-9]{1,3}\.[0-9]{1,3}: "
	
	'Three lines from Steve Cathersalc 
	Set objScriptExec=wshShell.Exec("ping -n 2 -w 1000 " & strComputer)
	Set Matches = objRE.Execute(objScriptExec.StdOut.Readall)   ' Execute search.

	If Matches.count = 1 Then 
	   'PingReply = True
	   For Each Match in Matches   ' Iterate Matches collection.
	     GetIP = trim(replace(Match.Value,":","")) 'Cleanup
	   Next
	Else
		GetIP = "Not Found"
		'PingReply = False
	End If 
End Function

Sub Runtime()
	dim iRunHours, dNow,iHours, iMinutes, tArray, strRunTime
	dNow = Now 
	message = "It is now " & dNow & ". Run data collection for how many hours?" & VbCrLf & _
	"(Use time format, ex 00:06 is 6 minutes, 1:30 is 1.5 hours, 36:00 hours is 1.5 days)"
	strRunTime = InputBox(message,"Duration")
	If isEmpty(strRunTime) Then WScript.Quit
	tArray =Split(strRunTime,":")
	iHours = Cint(Tarray(0))
	iMinutes = CInt(tArray(1))
	dFutureTime = DateAdd("h", iHours, dNow)
	dFutureTime = DateAdd("n",iMinutes,dFutureTime)
	retval = MsgBox ("End at " & dFutureTime & "?",vbYesNoCancel,"Verify Duration")
	If retval = vbCancel Then WScript.Quit
	If retval = vbNo Then Runtime
End Sub 

Sub SaveAsExcel(strFileName)
	bExcel =True 
	Const xlnormal = -4143
	Const xlAscending = 1
	Const xlDescending = 2
	Const xlYes = 1
	Const xlSortValues = 1
	 
	Dim oXL, objRange
	If Not fso.FileExists(strFileName) Then WScript.Quit
	On Error Resume Next
	Set oXL = CreateObject("Excel.Application")
	
	If Err <> 0 Then 'Excel not installed
		bExcel = False
		FSO.MoveFile strFileName, replace(strIniFilePath,".xls",".txt")
		Err.Clear
		On Error GoTo 0
		Exit Sub
	End If 

	oXL.DisplayAlerts=False ' don't display overwrite prompt.
	oXL.Workbooks.Open(strFileName)
	Set objRange = oXL.Worksheets(1).UsedRange
	Set objRange2 = oXL.Range("A2")
	objRange.Sort objRange2, xlAscending,,,,,, xlYes
	objRange.EntireColumn.Autofit()

	Dim oWS	
	Set oWS = oXL.Worksheets(1)
	oWS.Activate
	oXL.ActiveWorkBook.SaveAs strFileName,xlnormal,,,,,,,True 'overwrite existing
	oXL.ActiveWorkBook.Close
	oXL.Quit
	WScript.Echo "Done"
End Sub 

Sub WriteLog(message)
	'write to text log 
	'WScript.Echo message
	AppendOut.WriteLine message
End Sub  

Function IsCScript()
    If (InStr(UCase(WScript.FullName), "CSCRIPT") <> 0) Then
        IsCScript = True
    Else
        IsCScript = False
    End If
End Function