'EnumRecent.vbs  Alan dot Kaplan at VA dot gov, 12/7/2009
'This script reads the MRU and Recent Doc Folders for a user on a local or remote PC
'and logs results to Excel file

Const HKLM = &H80000002 
Const HKCU = &H80000001

Dim wshShell : Set wshShell = WScript.CreateObject("WScript.Shell")

Dim objReg
Dim quote : quote=chr(34)
Dim sTempRegPath, strPath

Dim fso
Set fso = CreateObject("Scripting.FileSystemObject")

If (Not IsCScript()) Then 		'If not CScript, re-run with cscript...
	Dim strArgs, i
	For i  = WScript.Arguments.Count -1 to  0 Step -1
		strArgs = WScript.Arguments(i) & Space(1) &  strArgs
	Next
	
	WshShell.Run "CScript.exe " & quote & WScript.ScriptFullName & quote & space(1) & strArgs, 1, true
    WScript.Quit            	'...and stop running as WScript
End If

message = "This script will create a log of recent documents from the registry and filesystem. " & _
" Registry information has the file name only, items from Recent Documents include the full path." & _
vbNewLine & vbNewLine & "Check Recent Documents for a user on what PC"

If WScript.Arguments.Count = 1 Then
	strComputer = WScript.Arguments(0)
Else
	strComputer = wshShell.ExpandEnvironmentStrings("%COMPUTERNAME%")
	strComputer = InputBox(message,"Recent Documents",strComputer)
End If 

If strcomputer = "" Then WScript.Quit
strComputer = UCase(strComputer)

Dim atemp, strUser
Dim logfile, appendout
Dim bLocalUser, bLocalComputer

If ucase(strUser) = UCase(wshShell.ExpandEnvironmentStrings("%USERNAME%")) Then bLocalUser = True
If ucase(strComputer) = UCase(wshShell.ExpandEnvironmentStrings("%COMPUTERNAME%")) Then bLocalComputer = True

If Not bLocalComputer Then 
	If not PingReply(strComputer) Then 
		MsgBox "No reply.",vbCritical + vbOKOnly,StrComputer
		WScript.Quit
	End If 
End If 
	
strProfilepath = ProfileFolder()
'WScript.Echo "Getting Profile Folder"
sRD = BrowseForFolder("Choose a user's profile folder, then click OK:", _
	BIF_returnonlyfsdirs,strProfilePath)
If Len(sRD) = 0 Then wscript.Quit 

atemp = Split(sRD,"\")
strUser = atemp(UBound(atemp))

logfile = wshShell.ExpandEnvironmentStrings("%userprofile%") & "\desktop\" & strComputer &_
	"_" & strUser & "_RecentDocs.xls"
logfile = InputBox("Save log to:","Log File",logfile) 
If logfile = "" Then WScript.Quit

'Delete old log 
If fso.FileExists(logfile) Then fso.DeleteFile logfile,True

'setup log
Const ForAppend = 8
set appendout = fso.OpenTextFile(logfile, ForAppend, True)
appendout.writeline "File	Where Reference Found"
sRD = sRD &"\Recent"

If bLocalUser And bLocalComputer   Then 
	WScript.Echo "Current User"
	LocalReg
Else
	readReg 
End If

GetRecent
appendout.Close
SaveAsExcel(logfile)
WScript.Echo "Done."

'======== Functions and Subs =====
Function PingReply(strcomputer) 
	Dim objScriptExec, strPingResults
	'Three lines from Steve Cathersalc 
	Set objScriptExec=wshShell.Exec("ping -n 2 -w 1000 " & strComputer)
	strPingResults = LCase(objScriptExec.StdOut.Readall)
	
	If InStr(strPingResults, "bytes=") Then
		PingReply = True
	Else
		PingReply = False
	End If
End Function

Sub readReg()
	WScript.Echo "From Registry"
 
	strPath = strProfilepath & "\" & strUser
	On Error Resume Next

	sTempRegPath="HKLM\LoadedKey"
	If not fso.FileExists (strPath & "\ntuser.dat") Then 	
		WScript.Echo strPath & "\ntuser.dat  not found!"
		WScript.Quit
	Else
		Wscript.Echo strPath & "\ntuser.dat loading..."
		Dim strCommand
		strCommand = "reg.exe load " & sTempRegPath & Space(1) & quote & strPath & "\NTuser.dat" & quote
		'WScript.Echo strCommand
		' Attempt to load the users registry hive.
		' This fails sometimes for reason that aren't obvious.
		Dim oExec, strAllOut
		Set oExec = WshShell.Exec(strCommand)
		wscript.sleep 2000
		
		If Not oExec.StdOut.AtEndOfStream Then
		    strAllOut = oExec.StdOut.ReadAll
		End If
	
		If oExec.ExitCode <> 0 Then
			message = "Failed to load registry for " & strUser & _
			". Typically this is a file in use error. The command attempted was: " & _
			vbNewLine & vbNewLine & strCommand & vbNewLine & vbNewLine & _
			" Continuing with Recent Documents folder."

		     wshShell.Popup message,20,"Registry Not Read!"
		     Exit Sub 
		End If
		
		strPath = sTempRegPath & "\Software\Microsoft\Windows\CurrentVersion\Explorer\RecentDocs"
		EnumSubkeys strPath  
		
		'Then unload
		wshShell.Run ("reg.exe unload " & sTempRegPath ), 0, True
	 End If 
End Sub


'From Registry
Sub LocalReg()
	'Set objReg = GetObject("winmgmts:\\" & strComputer &  "\root\default:StdRegProv")
	strPath = "Software\Microsoft\Windows\CurrentVersion\Explorer\RecentDocs"
	EnumSubkeys strPath  
End Sub 


Sub EnumSubkeys(strKeyPath)
	'Resetting to local
	Set objReg = GetObject("winmgmts:\\.\root\default:StdRegProv")
	'WScript.Echo strkeypath
	
	If instr(strKeyPath , "LoadedKey") Then  
		strKeyPath = mid(strKeyPath,InStr(strKeypath,"\")+1)
		objReg.EnumKey HKLM, strKeyPath, arrSubkeys      
	Else
		objReg.EnumKey HKCU, strKeyPath, arrSubkeys   	
	End If 
	
	If IsArray(arrSubkeys) Then          
		For Each strSubkey In arrSubkeys
			EnumSubkeys strKeyPath & "\" & strSubkey
		Next
	Else
		'WScript.Echo "No Subkeys found under " & strKeyPath
	End If 
	
	If InStr(strKeyPath,".") Then 
		strKeyPath =  replace(strKeyPath,"\\","\")  
		CheckRecent strKeyPath 
	End If 
End Sub 


'From Recent Files
Sub GetRecent()
	WScript.Echo "From Recent Files folder"
	Set oSRD= fso.GetFolder(sRD)
	Set ofiles = oSRD.Files
	For Each file In ofiles
		If LCase(right(file.name,3)) = "lnk" Or LCase(Right(file.name,3)) = "url" Then 
			EchoAndLog GetLinkPath(file.path) & vbTab & replace(file.path,"\\" & lcase(strComputer) & "\c$\","C:\")
		End If 
	Next
End Sub 

Function GetLinkPath(strLink)
		On Error Resume Next 
		'WScript.Echo strLink
		Set oLnk = wshShell.CreateShortcut(strlink)
		GetLinkPath = oLnk.TargetPath
End Function 


Sub CheckRecent(strPath)
	On Error Resume Next 
	objReg.EnumValues HKCU, strPath, arrEntryNames, arrValueTypes
	For i=0 To UBound(arrEntryNames)
	  If arrEntryNames(i) <> "MRUListEx" Then 
	    'WScript.Echo
	      objReg.GetBinaryValue HKCU,  strPath, arrEntryNames(i), arrValue
	      strOut = ""
		  iSkip = 0
	      For Each byteValue in arrValue     	   
      	    If ByteValue = 0 Then iSkip = iSkip + 1
	      	If byteValue <> 0 Then 
	      		strout = strOut &  chr(byteValue)
	      		iSkip = 0
	       	End If 
	       	If iSkip = 3 Then Exit For 
	      Next
	      
	      EchoAndLog strout & vbTab & "HKCU\" & strPath & "\" & arrEntryNames(i)   
	End If 
	Next
End Sub 


Function BrowseForFolder(title, flag, dir)
	' title = Text shown in the dialog box
	' flag = values controlling BrowseForFolder behavior
	' dir = Initial directory (can be "").  
	'	dir most useful when not using BIF_ShowAllObjects    
	On Error Resume Next
    Dim oShell, oItem, strSelection
    
    ' Create Shell object.
    Set oShell = WScript.CreateObject("Shell.Application")

    ' Invoke Browse For Folder dialog box.
    Set oItem = oShell.BrowseForFolder(&H0, title, flag, dir)
		strSelection = oItem.Title 
		If Err <> 0 Then 'cancelled
            Set oShell = Nothing
            Set oItem = Nothing
            Exit Function
        End If
	
    ' If colon found then get drive letter from the title. No array
    If InStr(strSelection, ":") Then 
        BrowseForFolder = mid(strSelection,InStr(strSelection, ":")-1, 2)
	Else
	'Handle all other special cases where path not returned 
		Select Case strSelection
			Case "Desktop"
				BrowseForFolder = wshShell.SpecialFolders("Desktop")
			Case "My Documents"
				BrowseForFolder = wshShell.SpecialFolders("MyDocuments")
			Case "My Computer"
				MsgBox "Invalid selection",vbCritical + vbOKOnly,"Error"
				Quit
			Case "My Network Places"
				MsgBox "Invalid selection",vbCritical + vbOKOnly,"Error"
				Quit
			Case Else		
			    ' Finally try to retrieve the full path a la Born
			    BrowseForFolder = oItem.ParentFolder.ParseName(oItem.Title).Path
			    strNTName = oItem.Title
		End Select
	End If
	
	'Cleanup 
    Set oShell = Nothing
    Set oItem = Nothing	


	'Alternate make sure they all end without \
     If Right(browseForFolder,1) = "\" Then
     	browseforfolder = left(BrowseForFolder,Len(BrowseForFolder)-1)
     End If

  	On Error Goto 0
End Function


Function ProfileFolder ()
	On Error Resume Next
	Dim strKeyPath, strKeyName, strLocalProfiles

	strKeyPath = "SOFTWARE\Microsoft\Windows NT\CurrentVersion\ProfileList"
	strKeyName = "ProfilesDirectory"
	Set objReg = GetObject("winmgmts:\\" & strComputer & "\root\default:StdRegProv")
	
	If Err <> 0 Then 
		MsgBox "Failed to read profile directory on " & strComputer & ". " & Err.Description, _
			vbCritical + vbOKOnly,"Error"
	End If 
	
	objReg.GetExpandedStringValue HKLM, strKeyPath, strKeyName, strLocalProfiles
	
	If isnull(strLocalProfiles) Then 
			MsgBox "Failed to read profile directory on " & strComputer & ". ", _
			vbCritical + vbOKOnly,"Error"
			WScript.Quit
	End If 
	
	ProfileFolder = "\\"& strComputer & "\" & Replace(strLocalProfiles,":","$")
	On Error GoTo 0
End Function 


Sub EchoAndLog (message)
	'Echo output and write to 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

	
Sub SaveAsExcel(strFileName)
	'I do this at end because Excel may not have been on system running script
	'and it is easy to write text files.
	WScript.Echo "Converting logfile to Excel, please wait..."
	Const xlnormal = -4143 
	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
		Err.Clear
		On Error GoTo 0
		fso.MoveFile logfile, Replace(logfile,"xls","txt")
		MsgBox strFileName & " is a tab delimited text file",vbOKOnly,"Excel convert failed"
		Exit Sub
	End If 
	
	'oXL.Visible = True
	oXL.DisplayAlerts=False ' don't display overwrite prompt.
	oXL.Workbooks.Open(strFileName)
	Set objRange = oXL.Worksheets(1).UsedRange
	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
	MsgBox "Done.  The logfile is " & vbNewLine & logfile,vbInformation + vbOKOnly,"Script complete"
End Sub