'InternetImageAudit.vbs, formerly WhereHaveYouBeen.vbs creates an HTML file (webpage) containing list of graphic file 
'elements from users's temporary internet files.  It was designed to be used for porn investigations.
'Do not use on original drive if court action expected!
'Alan Kaplan 9-21-2006 alan dot kaplan at va dot gov
'
'3-25-08, version 2 added remote exam, and is better forensic format 
'adds Date sort, row number, movie file support

'4-4-2009, version 3 switch to storage in MDB file to avoid 
'65K file limit, and adds selective printing.  UI dressed up with better dialog boxes
'MS Vista compatible

'The latest version can be found at www dot akaplan dot com whack blog

Const adInteger = 3
Const adDate = 7
Const adVarChar = 200
Const ForAppend = 8
Const adOpenStatic = 3
Const adOpenForward = 0
Const adLockOptimistic = 3

Dim strUserFullName, strNTName
Dim strProfilePath
Dim iSpindex
dim wshShell
Dim fso 
Dim strFolder 
Dim iMinFile
Dim oIE
Dim strComputer, strBorder, strFont
Dim strFormatOn, strFormatOff, iTSViewoPage
Dim PicPath
Dim iRow, message
Dim oConnMDB 			'connection to Access
Dim dbName, mdbRS
Dim  retval
Dim ocommand, strsql 	'As ADODB.Command
dim quote
Dim strReportPath
Dim iUserDef
Dim tArray,strFilter, strExtList
Dim desktop, tempfolder, strOperator 

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

iUserDef = 0
quote=chr(34)
iRow = 1

'========== You can edit this list ================
'removed SWF, almost exclusively ads.
strExtList = "BMP,GIF,JPG,PNG,3GP,ASF,ASX,AVI,FLV,FLI,MOV,MP4,MPEG,MOV,MPG,QT,RM,WMV"
'===================================================

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

'Open the FSO object
Set fso = CreateObject("Scripting.FileSystemObject")

Set mdbRS = CreateObject("ADODB.Recordset")
desktop = wshShell.ExpandEnvironmentStrings("%userprofile%") & "\desktop\"
tempfolder = wshShell.ExpandEnvironmentStrings("%Temp%") & "\"

Set fso = CreateObject("Scripting.FileSystemObject")
dbName = tempfolder  & "InternetAuditTemp.mdb"

Set fso = CreateObject("Scripting.FileSystemObject")
dbName = tempfolder  & "InternetImageTemp.mdb"

'Delete old Acess DB 
If fso.FileExists(dbName) Then
	fso.DeleteFile(dbName)
End If

strNTName = wshShell.ExpandEnvironmentStrings("%USERNAME%")

message = "This script creates an HTML file which displays images from a user's Internet Explorer cache.  " & _
"It also attempts to create links to movie files in the cache.  " & _
"The images are sorted by timestamp and are placed into a table with the path to the files. " & _
"This script is used to add weight to pornography investigations.  Do not use it on the " & _
"original drive if you expect court action." & VbCrLf & VbCrLf & _
"The script can be run locally or remotely, but it must be run with administrator rights. " 

strComputer = wshShell.ExpandEnvironmentStrings("%COMPUTERNAME%")

WScript.Echo "This window has status messages" & VbCrLf 
WScript.Echo "Getting Computer Name"
strComputer	= UCase(strComputer)
strComputer = InputBox (message,"Examine what computer?",strComputer)
If strComputer = "" Then Quit
WScript.Echo vbTab & strComputer & VbCrLf 

strProfilePath = GetProfileFolder

WScript.Echo "Getting Profile Folder"
PicPath = BrowseForFolder("Choose a user's profile folder, then click OK:", _
	BIF_returnonlyfsdirs,strProfilePath)
If Len(PicPath) = 0 Then Quit 

PicPath = PicPath &"\Local Settings\Temporary Internet Files\Content.IE5"
WScript.Echo vbTab & PicPath & VbCrLf 

If Not FSO.FolderExists(PicPath) Then 
	MsgBox "Could not find temporary IE folders at " & picPath,vbCritical + vbOKOnly,"Error"
	Quit
End If 

strReportPath = desktop & strNTName &"_TempInternetFiles_on_"&strComputer &".html"
WScript.Echo "Getting path for report to be saved as"
strReportPath = ExcelSaveAsDialog("Choose name and path for report","Web Files, *.htm;*.html,All Files, *.*",strReportPath) 
WScript.Echo vbTab & strReportPath & VbCrLf 

'Delete old report
If fso.FileExists(strReportPath) Then	fso.DeleteFile(strReportPath)

set oPage = fso.OpenTextFile(strReportPath, ForAppend, True)
WScript.Echo "Getting minimimum file size"

iMinFile = Inputbox("Ignore image files smaller than this size in bytes:","Minimum File Size",2048)
If iMinFile = "" Then Quit
WScript.Echo vbTab & iMinFile & VbCrLf 

WScript.Echo "Getting name of User"
strUserFullName = UserFullName(strNTName)
WScript.Echo vbTab & strUserFullName

WScript.Echo "Getting name of Report Operator"
strOperator = UserFullName(wshShell.ExpandEnvironmentStrings("%USERNAME%"))
WScript.Echo vbTab & strOperator

iMinFile = CInt(iMinFile)

tArray = split(lcase(strExtList),",")
For i = 0 To UBound(tArray)
	strFilter = strFilter & "'." & tArray(i) & "'," 
Next

strFilter = Left(strFilter,Len(strFilter)-1)

CreateDB
ReadRoot PicPath, True 

If mdbRS.State = 1 Then mdbRS.Close 

strsql = "SELECT * FROM [ImageTable] WHERE ImageTable.FileExt In (" & strFilter & ") AND ImageTable.FileSize > " _
& iMinFile & " ORDER BY ImageTable.DateCreated;"

mdbRS.Open strsql, oConnMDB, adOpenStatic, adLockOptimistic

If mdbRS.EOF And mdbRS.BOF Then 
	MsgBox "No image file found meeting your criteria, quitting",vbCritical + vbOKOnly,"No Records Found"
	Quit
End If 

mdbRS.MoveFirst()

If mdbRS.RecordCount = 0 Then 
	WScript.Echo "Quitting"
	MsgBox "No files found meeting criteria.",vbCritical + vbOKOnly,"Search Failed"
	Quit
End If 

WScript.Echo "Creating file ..."
PageWrite
PageClose

wshShell.Popup "Done. IE will now open with the report.  To permit selective printing of rows, you must allow ActiveX if prompted.",0,"Done"

'Show the file
Set oIE = CreateObject("InternetExplorer.Application")
with oIE
    .Width=900
    .Height=700
    .Left=150
    .Top=50
    .Visible=true
    .navigate strReportPath
end With

'a little cleanup 
oconnmdb.close
Set mdbRS = Nothing
Set oConnMDB = Nothing 

If fso.FileExists(dbName) Then
	fso.DeleteFile(dbName)
End If

Do while oIE.readystate<>4 : wscript.sleep 50 : loop

'======================= Function and Sub =======================
' AK: File ID stuff comes from http://www.4guysfromrolla.com/webtech/050300-1.shtml
' My subs are noted below
	
  ':::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
  ':::                                                             :::
  ':::  This routine will attempt to identify any filespec passed  :::
  ':::  as a graphic file (regardless of the extension). This will :::
  ':::  work with BMP, GIF, JPG and PNG files.                     :::
  ':::                                                             :::
  ':::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
  ':::          Based on ideas presented by David Crowell          :::
  ':::                   (credit where due)                        :::
  ':::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
  ':::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
  ':::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
  '::: blah blah blah blah blah blah blah blah blah blah blah blah :::
  '::: blah blah blah blah blah blah blah blah blah blah blah blah :::
  '::: blah blah     Copyright *c* MM,  Mike Shaffer     blah blah :::
  '::: blah blah      ALL RIGHTS RESERVED WORLDWIDE      blah blah :::
  '::: blah blah  Permission is granted to use this code blah blah :::
  '::: blah blah   in your projects, as long as this     blah blah :::
  '::: blah blah      copyright notice is included       blah blah :::
  '::: blah blah blah blah blah blah blah blah blah blah blah blah :::
  '::: blah blah blah blah blah blah blah blah blah blah blah blah :::
  ':::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

  ':::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
  ':::                                                             :::
  ':::  This function gets a specified number of bytes from any    :::
  ':::  file, starting at the offset (base 1)                      :::
  ':::                                                             :::
  ':::  Passed:                                                    :::
  ':::       flnm        => Filespec of file to read               :::
  ':::       offset      => Offset at which to start reading       :::
  ':::       bytes       => How many bytes to read                 :::
  ':::                                                             :::
  ':::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
  
Function GetBytes(flnm, offset, bytes)
     Dim objFTemp
     Dim objTextStream
     Dim lngSize

     On Error Resume next
     
     ' First, we get the filesize
     Set objFTemp = FSO.GetFile(flnm)
     lngSize = objFTemp.Size
     Set objFTemp = nothing

     fsoForReading = 1
     Set objTextStream = FSO.OpenTextFile(flnm, fsoForReading)

     If offset > 0 then
        strBuff = objTextStream.Read(offset - 1)
     End if

     If bytes = -1 then		' Get All!
        GetBytes = objTextStream.Read(lngSize)  'ReadAll
     Else
        GetBytes = objTextStream.Read(bytes)
     End If

     objTextStream.Close
     set objTextStream = Nothing

	On Error GoTo 0
  End  Function


':::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
':::                                                             :::
':::  Functions to convert two bytes to a numeric value (long)   :::
':::  (both little-endian and big-endian)                        :::
':::                                                             :::
':::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
Function  lngConvert(strTemp)
     lngConvert = clng(asc(left(strTemp, 1)) + ((asc(right(strTemp, 1)) * 256)))
End  function

function lngConvert2(strTemp)
     lngConvert2 = clng(asc(right(strTemp, 1)) + ((asc(left(strTemp, 1)) * 256)))
End  function


':::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
':::                                                             :::
':::  This function does most of the real work. It will attempt  :::
':::  to read any file, regardless of the extension, and will	::: 
'::: identify if it is a graphical image. 						::: 
'::: 															::: 
'::: Passed:													::: 
'::: flnm => Filespec of file to read 							::: 
'::: width => width of image 									::: 
'::: height => height of image 									::: 
'::: depth =>' color depth (in number of colors) 				::: 
'::: strImageType=> type of image (e.g. GIF, BMP, etc.) 		::: 
':::															 :::
':::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

Function gfxSpex(flnm, width, height, depth, strImageType) 
	dim strPNG
	dim strGIF 
	Dim strBMP 
	dim strType 
	strType = "" 
	strImageType ="(unknown)" 
	gfxSpex = False 
	strPNG = chr(137) & chr(80) & chr(78) 
	strGIF = "GIF" 
	strBMP = chr(66) & chr(77) 
	strType = GetBytes(flnm, 0, 3) 
	
	if strType = strGIF then ' is GIF 
		strImageType ="GIF" 
		Width = lngConvert(GetBytes(flnm, 7, 2)) 
		Height = lngConvert(GetBytes(flnm, 9, 2)) 
		Depth = 2 ^ ((asc(GetBytes(flnm, 11,1)) and 7) + 1) 
		gfxSpex = True 
	elseif left(strType, 2) = strBMP then 'is BMP 
		strImageType = "BMP" 
		Width = lngConvert(GetBytes(flnm, 19, 2))
		Height = lngConvert(GetBytes(flnm, 23, 2)) 
		Depth = 2 ^(asc(GetBytes(flnm, 29, 1))) 
		gfxSpex = True 
	elseif strType = strPNG then ' Is PNG 
		strImageType = "PNG" 
		Width = lngConvert2(GetBytes(flnm,19, 2)) 
		Height = lngConvert2(GetBytes(flnm, 23, 2)) 
		Depth = getBytes(flnm, 25, 2) 
			select case asc(right(Depth,1)) 
				case 0 
					Depth = 2^ (asc(left(Depth, 1))) 
					gfxSpex = True 
				Case 2 
					Depth = 2 ^(asc(left(Depth, 1)) * 3) 
					gfxSpex = True 
				case 3 
					Depth = 2 ^(asc(left(Depth, 1))) '8 
					gfxSpex = True 
				case 4 
					Depth = 2 ^(asc(left(Depth, 1)) * 2) 
					gfxSpex = True 
				case 6 
					Depth = 2 ^(asc(left(Depth, 1)) * 4) 
					gfxSpex = True 
				case Else 
					Depth = -1 
				end Select 
			else strBuff = GetBytes(flnm, 0, -1) ' Get all bytes from file
				lngSize = len(strBuff) 
				flgFound = 0 
				strTarget = chr(255) & chr(216)& chr(255) 
				flgFound = instr(strBuff, strTarget) 
				
				if flgFound = 0 Then 
					exit Function 
				end If 
				
				strImageType = "JPG" 
				lngPos = flgFound + 2
				ExitLoop = False 
				
				do while ExitLoop = False and lngPos < lngSize 
				do while asc(mid(strBuff, lngPos, 1)) = 255 and lngPos < lngSize lngPos = lngPos + 1 
					Loop 
				if asc(mid(strBuff, lngPos, 1)) < 192 or asc(mid(strBuff, lngPos, 1)) > 195 Then 
				lngMarkerSize = lngConvert2(mid(strBuff, lngPos + 1, 2)) 
				lngPos = lngPos + lngMarkerSize + 1 
			Else 
				ExitLoop = True 
			end If 
		loop ' 
		If ExitLoop = False Then 
			Width = -1 
			Height = -1 
			Depth = -1 
		Else 
			Height = lngConvert2(mid(strBuff, lngPos + 4, 2)) 
			Width =lngConvert2(mid(strBuff, lngPos + 6, 2)) 
			Depth = 2 ^ (asc(mid(strBuff,lngPos + 8, 1)) * 8) 
			gfxSpex = True 
		end If 
	End If 
End Function


'================ Kaplan Functions and Subs ==============

Sub PageWrite()	
	strFont = "Arial"
	strBGColor = "azure"
	strTitle = "Internet Files Seen by " & UCase(strNTName) 
	'oPage is an FSO object
	oPage.Writeline ("<HTML>")
	oPage.Writeline ("<!-- This page was generated by InternetImageAudit.vbs by Alan Kaplan, alan dot kaplan at va dot gov -->")
	oPage.Writeline ("<HEAD>")
	oPage.Writeline "<title>" & strTitle & "</title>"
	oPage.Writeline ("<style type=""text/css"">")
	'Create scripts
	oPage.Writeline ("<!--")
	oPage.Writeline ("@media print {")
	oPage.Writeline ("  .DONTPrint{ display:none }")
	oPage.Writeline ("  .DOCheck        { display:table}")
	oPage.Writeline ("}")
	oPage.Writeline ("-->")
	oPage.Writeline ("</style>")
	oPage.WriteBlankLines(1)
	oPage.Writeline ("<script type=""text/javascript"">")
	oPage.WriteBlankLines (1)
	oPage.Writeline ("/* This script and many more are available free online at")
	oPage.Writeline ("The JavaScript Source :: http://javascript.internet.com")
	oPage.Writeline ("Created by: Thony den Braber :: http://www.orangespirits.nl ")
	oPage.Writeline ("modified by AK to support check all*/")
	oPage.WriteBlankLines(1)
	oPage.Writeline ("function select_row(row, color) {")
	oPage.Writeline ("  if(row.parentNode.parentNode.style.backgroundColor != color) {")
	oPage.Writeline ("    row.parentNode.parentNode.style.backgroundColor = color;")
	oPage.Writeline ("    row.parentNode.parentNode.className = 'DOPrint'")
	oPage.Writeline ("  } else {")
	oPage.Writeline ("  row.parentNode.parentNode.style.backgroundColor = '';")
	oPage.Writeline ("  row.parentNode.parentNode.className = 'DONTprint'")
	oPage.Writeline ("  }")
	oPage.Writeline ("}")
	oPage.WriteBlankLines(1)
	oPage.Writeline ("function mouseover(row, font_color, checkedcolor) {")
	oPage.Writeline ("  if(row.style.color != checkedcolor) {")
	oPage.Writeline ("    row.style.color = font_color;")
	oPage.Writeline ("  }")
	oPage.Writeline ("}")
	oPage.WriteBlankLines(1)
	oPage.Writeline ("function mouseout(row, font_color, checkedcolor) {")
	oPage.Writeline ("  if(row.style.color != checkedcolor) {")
	oPage.Writeline ("    row.style.color = font_color;")
	oPage.Writeline ("  }")
	oPage.Writeline ("}")
	oPage.WriteBlankLines(1)
	oPage.Writeline ("checked = false;")
	oPage.Writeline (" function checkedAll () {")
	oPage.Writeline ("        if (checked == false){checked = true}else{checked = false}")
	oPage.Writeline ("	for (var i = 0; i < document.getElementById('myform').elements.length; i++) {")
	oPage.Writeline ("	  document.getElementById('myform').elements[i].checked = checked;")
	oPage.Writeline ("      select_row(document.getElementById('myform').elements[i], '#cccccc');")
	oPage.Writeline ("	}")
	oPage.Writeline (" }")
	oPage.WriteBlankLines(1)
	oPage.Writeline ("</script>")
	oPage.WriteBlankLines(1)
	oPage.Writeline ("</HEAD>")
	oPage.WriteBlankLines(2)
	oPage.Writeline "<body bgcolor='"& strBGcolor & "'>"
	oPage.Writeline "<Font face ='"& strFont & "'>"
	oPage.Writeline "<Center><h2>" & strTitle &  "<br>- " & strUserFullName & " -<br> on " & ucase(strComputer) & "</center></h2>"
	oPage.Write "Each image found in this report was found on a page viewed by " & strUserFullName & " in Internet Explorer. These files are saved " 
	oPage.Write "by IE in a cache to speed the process of going back to a previous page. The files shown are the "
	oPage.Writeline "results of searching " & PicPath 
	oPage.Writeline "for temporary internet files larger than " & iMinFile &	" bytes with one of these extensions: " 
	oPage.WriteLine Replace(strExtList,",",", ")  & "."
	oPage.Writeline "If only selected images were printed, row numbers refer to location in full report."
	oPage.Writeline "<p Align = right>Report Operator: " & strOperator & "<br>"
	oPage.Writeline "Report Timestamp: " & Now & "</p><br><br>"
	oPage.Writeline "Signature of Examiner(s) present: ____________________________________________________<br><br>"
	oPage.WriteBlankLines(1)
	oPage.Writeline "<p class='DONTPrint' align='Right'>Note: Only checked rows are printed.  "
	opage.WriteLine "Check/uncheck all: <input type='checkbox' name='checkall' onclick='checkedAll();'> </p>"
	oPage.Writeline ("<form id=""myform"">")
	oPage.Writeline ("<div align=""center"">")
	oPage.WriteBlankLines(1)
	oPage.Writeline "<table border='1' cellpadding='3' bordercolor='#000000' width='85%'>" 
	oPage.Writeline "<th align='center'>Row</th><th align='center'>File Name</th><th align='center'>Date Created</th>"	
	oPage.WriteLine "<th align='center'>Size</th><th align='center'>Image</th><td width='24' align='center'></td></tr>"
    oPage.WriteBlankLines(1)
    
	'Now the inside of the document from the database
	
	Dim strDisplayFolder

	While Not mdbRS.EOF
		
		If  mdbRS("Filesize").Value > iMinFile Then 
			strName =  mdbRS("Filename").Value
			strFolder = "." & Mid(mdbRS("FilePath").Value,Len(PicPath)+1)			
			'Parent folder and file name, ex" .\P8TBPCHI\img1[1].gif
			strPath = mdbRS("FilePath").Value
	
			If Len(strFolder) > 30 Then 
				strDisplayFolder  = BreakLine(strFolder,30)
			Else
				strDisplayFolder = strFolder
			End If 
	 
			oPage.Writeline ("<tr onmouseover=""mouseover(this,'#cc6600','#cc6600');"" onmouseout=""mouseout(this,'#000000','#000000')"" class='DONTPrint'>")
			oPage.Write "<td>" & iRow& "</td><td>" & strDisplayFolder& "</td><td>" & mdbRS("DateCreated").Value & "</td>"
			oPage.Writeline "<td>" & mdbRS("FileSize").Value & "</td><td>" 
	
			strIEPath = IEPath(strpath)
	
			If isGraphic( mdbRS("Filename").Value) Then 
				If gfxSpex(mdbRS("FilePath").Value, w, h, c, strType) = True Then 		
					iMaxW = 320
				
					If w > iMaxW Then 
						iNewH = Resize(iMaxW,w,h)
						iNewW = iMaxW
					Else
						iNewH = h
						iNewW = w
					End If 
				End If 
				
				oPage.Writeline  "<a href = '" & strIEPath & "' target='_blank'>"
				oPage.WriteLine  "<img border='0' src='" & strIEPath & "' width ='" & iNewW & "' height ='" & iNewH & "'></a>"			
			Else 
				oPage.Writeline "Movie file. Click <a href = '" & strIEPath & "' target='_blank'> here</a> to try to view."
			End If 
			 
			oPage.Writeline "</td>"
			oPage.Writeline ("<td class=""DONTPrint""><input type=""checkbox""name=""checkbox"" onclick=""select_row(this, '#cccccc');""></td>")
			oPage.Writeline "</tr>"
			oPage.WriteBlankLines(1) 
		    iRow = iRow +1
		End If 
		
	   	mdbRS.MoveNext()	
	Wend
		 
	 
End Sub

Sub PageClose()
	oPage.Writeline "</table></div>"
	oPage.Writeline "</form>"
	oPage.WriteLine "<HR><br>"
	oPage.Write "<p align ='center'><font size='2'>Created with InternetImageAudit.vbs, version 3 by "
	oPage.Write " <a href='mailto:alan.kaplan@va.gov?subject=InternetImage.vbs version 3'>Alan Kaplan</a></font></p>"
	oPage.Writeline "</font></body></html>"
	oPage.Close 
End Sub 

Function IsGraphic(strName)
	strName = UCase(strName)
	iGraphic = False
	tArray = array("BMP", "GIF", "JPG","PNG")
	For i = 0 To UBound(tArray)
		If InStr(strName,tArray(i)) > 0 Then
			IsGraphic = True
			Exit For 
		End If 
	Next
End Function

Function IEPath(strPath)
	IEPath = Replace(strPath,"\","//")
	IEPath = Replace(IEPath," ","%20")
	IEPath = "FILE://" & strPath 
End Function 

Function Resize (iMaxW, iCurrentW, iCurrentH)
	iFactor = iCurrentW / iMaxw
	Resize = round(iCurrentH / iFactor,2)
End Function 

Sub  ReadRoot(strFolder,bRecurse)
	Dim objFolder, File, strExt
    WScript.Echo vbcrlf & "Reading Temporary Internet files under " & strFolder & vbcrlf 
	'go get the folder to output it's contents
	
	On Error Resume Next
	Set objFolder = fso.GetFolder(strFolder)
	
	If Err <> 0 Then
		MsgBox "Failed to open " & strFolder & ". " & Err.Description,vbCritical + vbOKOnly,"Fatal Error"
		Quit
	End If 
	On Error GoTo 0
	
	'no files at this level go straight to sub folders
	if bRecurse then ShowSubFolders(objFolder)
End Sub 

Sub ShowSubFolders(objFolder)
  Dim colFolders, objSubFolder, colFiles, File, strExt
  Set colFolders = objFolder.SubFolders

  For Each objSubFolder In colFolders
    WScript.Echo "Reading files in " & objSubFolder.Path & VbCrLf 

    Set colFiles = objSubFolder.Files
	  	If mdbRS.State = 1 Then mdbRS.Close 
  		mdbRS.Open "SELECT * FROM ImageTable", oConnMDB, adOpenStatic, adLockOptimistic		

    For Each File In colFiles
    	Spin     
	    If instr(File.name,".") > 0 Then  
	    	strExt = lcase(Mid(File.name,instrrev(File.name,".")))
	 	Else
	 		strExt = "."
	 	End If 
	 	
	 	If Len(strExt) > 10 Then strExt = Left(strExt,10)
	 	If (strExt <> ".ico") And (Left(strExt,3)<> ".htm") Then 
	    	mdbRS.AddNew
		    mdbRS("FileName") = File.Name
		    mdbRS("FileExt") = strExt 
		    mdbRS("FilePath") = File.Path
		    mdbRS("DateCreated") = File.DateCreated
		    mdbRS("FileSize") = File.Size
		    mdbRS.Update
		End If
    Next
    ShowSubFolders(objSubFolder)
  Next
    If mdbRS.State = 1 Then mdbRS.Close 
End Sub

Function UserFullName (strName)
	iUserDef = iUserDef + 1
 	If wshShell.ExpandEnvironmentStrings("%LOGONSERVER%") = strComputer Then
 		UserFullName =""
 		Exit Function  
 	End If 

	'I could bind directly using the CN from oSI, but this was already written...
	Dim objConnection, oRS, objCommand, root, sDomain
	Const ADS_SCOPE_SUBTREE = 2
	Set objConnection = CreateObject("ADODB.Connection")
	Set objCommand = CreateObject("ADODB.Command")
	objConnection.Provider = ("ADsDSOObject")
	objConnection.Open "Active Directory Provider"
	objCommand.ActiveConnection = objConnection
	
	On Error Resume Next 
	'Get the ADsPath for the domain to search. 
	Set root = GetObject("LDAP://rootDSE")
	
	If Err <> 0 Then 
		If iUserDef = 1 Then 
			message = "What is the full name for " & strName
		Else
			message = "What your name (the person running the report)"
		End If 
		
		UserFullName = InputBox(message & "?","Full Name")
		Exit Function
	End If 
	
	sDomain = root.Get("defaultNamingContext")
	
	objCommand.CommandText = "SELECT samAccountName,description, givenname, sn FROM " & _
	    "'LDAP://" & sDomain & "' WHERE samAccountName = '" & strName &  "'"

	objCommand.Properties("SearchScope") = ADS_SCOPE_SUBTREE
	Set oRS = objCommand.Execute
	
	
	If oRS.RecordCount = 0 Then
	   UserFullName = ""
	Else
	    UserFullName = oRS("givenName").value & space(1) & oRS("sn").value 

	    If IsArray(oRS("Description")) Then 
	    	tArray = oRS("Description")
	    	strDescription = tArray(0)
	    Else
			If Len(oRS("Description"))>0 Then
				strDescription = oRS("Description")	
			End If
		End If 
	End If 
	
	If Len(strDescription) > 0 Then 
		UserFullName = UserFullName & ", " & strDescription 
	Else
		UserFullName = UserFullName & ", [NO DESCRIPTION]"
	End If 
	
	Set root = Nothing
	Set oRS = Nothing
	Set objCommand = Nothing
	Set objConnection = Nothing
End Function 


Function GetProfileFolder() 'Returns with trailing slash
	WScript.Echo "Creating WMI connection to " & strComputer
	On Error Resume Next
	Dim objReg, sSubKeyName,sValuename,Svalue
	Dim retval
	Const HKLM=&H80000002 'HKEY_LOCAL_MACHINE
	
	sSubKeyName="SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders\"
	sValuename="Common Desktop" 
	
	Set objReg = GetObject("winmgmts://" & strComputer & "/root/default:StdRegProv")
	
	retval=(objReg.GetStringValue(HKLM,sSubKeyName,sValueName,sValue))
	If Err<>0 Then
		message = "Error reaching " & strComputer & ", or using WMI on it." & Space(1) & Err.Description
		MsgBox message, vbCritical + vbOKOnly,"Fatal Error"
		Quit
	End If
	
	If retval=0 Then
		GetProfileFolder = left(sValue,instr(4,Svalue,"\"))
	Else
		WScript.Echo("Failed to read "& sSubKeyName)
		message = "Could not read registry on " & strComputer & "." & Space(1) & Err.Description
		MsgBox message, vbCritical + vbOKOnly,"Fatal Error"
		Quit
	End If
	
	If strComputer = wshShell.ExpandEnvironmentStrings("%COMPUTERNAME%") Then 
		Exit Function 
	Else
		GetProfileFolder = "\\"& strComputer & "\" & Replace(GetProfileFolder,":","$")
	End If 
	On Error GoTo 0
End Function 



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

Sub CreateDB() 
	'Makes an Access DB even if you don't have Access installed
 	Set OConnMDB = CreateObject("ADOX.Catalog")
 	OConnMDB.Create _
 	    "Provider = Microsoft.Jet.OLEDB.4.0; " & _
 	        "Data Source = " &dbname 
 	Set OConnMDB = Nothing
 	
 	Set oConnMDB = CreateObject("ADODB.Connection")
	
	OConnMDB.Open _
	    "Provider= Microsoft.Jet.OLEDB.4.0; " & _
	        "Data Source=" & dbName 
	
	OConnMDB.Execute "CREATE TABLE ImageTable([FileName] TEXT(200),[FileExt] TEXT(10),[FilePath] MEMO, [DateCreated] DATE,[FileSize] Number);"
End Sub 


Function ExcelSaveAsDialog(sPrompt, sFilter, InitFileName ) 
	'Creates Excel based SaveAs Dialog
	'inspired by code by Michael Hardt, http://www.softimage.com/community/xsi/discuss/archives/xsi.archive.0111/msg00066.htm
	Dim oExcelApp 
	On Error Resume Next 
	Set oExcelApp = CreateObject("Excel.Application") 
	If Err =  0 Then 
	   	Dim sFile 
	   	sFile = oExcelApp.GetSaveAsFilename (InitFileName,  sFilter, , sPrompt)    	
	   	'Cancel or no file name? 
	   	If sFile <> False Then 
	      	ExcelSaveAsDialog = sFile 
	   	Else 
	     	 Wscript.quit
	   	End If 
	 Else
	 	Err.Clear
		ExcelSaveAsDialog = InputBox(sPrompt,"Path to Save file",InitFileName)
	 End If 
	On Error GoTo 0
	If IsObject(oExcelApp) Then Set oExcelApp = Nothing 
End Function 




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



Sub Quit
	WScript.Echo "Quitting."
	If IsObject(oConnMDB) Then Set oConnMDB = nothing
	If IsObject(mdbRS) Then Set mdbRS = Nothing
	If fso.FileExists(dbName) Then
		fso.DeleteFile(dbName)
	End If
	WScript.Quit
End Sub 

Function BreakLine (strText, iMax)
	Dim i, sBL
	i = 1
	While i < Len(strText) 
		sBL = sBL &  Mid(strText,i,imax) & VbCrLf  
		i = i + iMax
	Wend
	BreakLine = Left(sBL,Len(sBL)-1)
End Function 

Sub Spin()
	If iSpinDex >= 4 Then iSpinDex = 0

	Select Case iSpinDex
	Case 0
		strSpin = "\"
	Case 1
		strSpin =  "|"
	Case 2
		strSpin = "/"
	Case 3
		strSpin = "-"
	End Select
	
	WScript.StdOut.Write strSpin
	WScript.Sleep(200)
	WScript.StdOut.Write Chr(8)
	iSpindex = iSpinDex + 1
End Sub