' +----------------------------------------------------------------------------+
' | Contact Info                                                               |
' +----------------------------------------------------------------------------+
' Author: Vengy
' Email : cyber_flash@hotmail.com
' Tested: win2K/XP (win9X not tested!)


' +----------------------------------------------------------------------------+
' | Index.dat file format.                                                     |
' +----------------------------------------------------------------------------+
' Generated by Hackman 7.02 lt
' C:\Documents and Settings\Administrator\Local Settings\History\History.IE5\index.dat - Starting offset: 0000:5000
'
' 0000:5000  55 52 4C 20 02 00 00 00 70 3A 4E 6E 8F 5E C2 01
' 0000:5010  70 3A 4E 6E 8F 5E C2 01 FF FF FF FF 00 00 00 00
' 0000:5020  00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00
' 0000:5030  60 00 00 00 68 00 00 00 FE 00 10 10 00 00 00 00
' 0000:5040  00 00 20 00 8C 00 00 00 44 00 00 00 00 00 00 00
' 0000:5050  31 2D 03 AA 03 00 00 00 00 00 00 00 00 00 00 00
' 0000:5060  00 00 00 00 00 00 00 00 56 69 73 69 74 65 64 3A
' 0000:5070  20 41 64 6D 69 6E 69 73 74 72 61 74 6F 72 40 61
' 0000:5080  62 6F 75 74 3A 48 6F 6D 65 00 ...
'
' 0000:5000  U R L   . . . . p : N n � ^ � . p : N n � ^ � . � � � � . . . .
' 0000:5020  . . . . . . . . . . . . . . . . ` . . . h . . . � . . . . . . .
' 0000:5040  . .   . � . . . D . . . . . . . 1 - . � . . . . . . . . . . . .
' 0000:5060  . . . . . . . . V i s i t e d :   A d m i n i s t r a t o r @ a
' 0000:5080  b o u t : H o m e . ...
'
' So far I've been able to decode some fields within the URL record:
'
' [5000-5002] = URL marker tag
' [5010-5017] = Last visited Date/Time
' [5054-5054] = Number of visits
' [5071-507C] = User
' [507E-5088] = URL
'
' If you have any additional info about this structure, please send me an email. Thanks!


' +----------------------------------------------------------------------------+
' | Let The Games Begin!                                                       |
' +----------------------------------------------------------------------------+
' INDEX.DAT files keep a list of websites you have visited.
' As a result, anyone can find out what you have been doing on the Internet!


' +----------------------------------------------------------------------------+
' | Ensure that all variable names are defined!                                |
' +----------------------------------------------------------------------------+
Option Explicit


' +----------------------------------------------------------------------------+
' | Setup constants                                                            |
' +----------------------------------------------------------------------------+
Const conBarSpeed=80
Const conForcedTimeOut=3600000 ' 1 hour


' +----------------------------------------------------------------------------+
' | Setup Objects and misc variables                                           |
' +----------------------------------------------------------------------------+
Dim oFSO        : Set oFSO = CreateObject("Scripting.FileSystemObject")
Dim oWShell     : Set oWShell = CreateObject("WScript.Shell")
Dim objNet      : Set objNet = CreateObject("WScript.Network")
Dim Env         : Set Env = oWShell.Environment("SYSTEM")
Dim arrFiles    : arrFiles = Array()
Dim arrUsers    : arrUsers = Array()
Dim HistoryPath : HistoryPath = Array()
Dim objIE
Dim objProgressBar
Dim objTextLine1
Dim objTextLine2
Dim objQuitFlag
Dim oTextStream
Dim Machine
Dim spyPath
Dim index
Dim nBias


' +----------------------------------------------------------------------------+
' | Determine OS type. Must be Windows_NT (windows XP/2K/2K3)                  |
' +----------------------------------------------------------------------------+
If StrComp(Env("OS"),"Windows_NT",VBTextCompare) <> 0 Then
   WScript.Echo "This script supports only Windows XP/2K/2K3/NT." & vbNewLine & "Exiting..."
   CleanupQuit
End If



' +----------------------------------------------------------------------------+
' | Whose been a naughty surfer? Let's find out! ;)                            |
' +----------------------------------------------------------------------------+
Machine = UCASE(InputBox("Please enter a network machine:","Remote IE Spy",objNet.UserName))

If Machine <> "" Then
  If Not oFSO.FolderExists("\\" & Machine & "\C$") Then
    MsgBox "Unable to access "&"\\" & Machine & "\C$" & VBCRLF & VBCRLF & "You may need Admin privileges to access that share!",0,"Scan Aborted"
  Else
  
' +----------------------------------------------------------------------------+
' | Set file spy path = C:\Machine-MM-DD-YYYY.htm                              |
' +----------------------------------------------------------------------------+
    spyPath="C:\" & Machine & "-" & Replace(FormatDateTime(Date()),"/","-") & ".htm"
    
    StartSpyScan
  End If
End if


' +----------------------------------------------------------------------------+
' | Outta here ...                                                             |
' +----------------------------------------------------------------------------+
CleanupQuit


' +----------------------------------------------------------------------------+
' | Cleanup and Quit                                                           |
' +----------------------------------------------------------------------------+
Sub CleanupQuit()
    Set oFSO = Nothing
    Set oWShell = Nothing
    Set objNet = Nothing
    WScript.Quit
End Sub


' +----------------------------------------------------------------------------+
' | Start Spy Scan                                                             |
' +----------------------------------------------------------------------------+
Sub StartSpyScan()
    Dim index_folder, history_folder, oSubFolder, oStartDir, sFileRegExPattern, user

    LocateHistoryFolder
    
    index_folder="\\" & Machine & "\C$\" & HistoryPath(1)

    If Not oFSO.FolderExists(index_folder) Then
      MsgBox "No history folder exists. Scan Aborted."
    Else

      StartIE  "Remote IE Spy - "&Machine   
      SetLine1 "Locating history files:"

      sFileRegExPattern = "\index.dat$"
      Set oStartDir = oFSO.GetFolder(index_folder)

      For Each oSubFolder In oStartDir.SubFolders
        history_folder=oSubFolder.Path&"\"&HistoryPath(3)&"\"&HistoryPath(4)&"\"&"History.IE5"
        If oFSO.FolderExists(history_folder) Then
          If IsQuit()=True Then
	    CloseIE    
	    CleanupQuit
          End If
          user = split(history_folder,"\")        
          ReDim Preserve arrUsers(UBound(arrUsers) + 1)
          arrUsers(UBound(arrUsers)) = user(5)       
          SetLine2 user(5)          
          Set oStartDir = oFSO.GetFolder(history_folder)
          RecurseFilesAndFolders oStartDir, sFileRegExPattern
        End If
      Next

      ' Index flag to determine if at least one index.dat file exists.
      If IsEmpty(index) Then
        CloseIE
        MsgBox "No Index.dat files found. Scan Aborted."
      Else
        CreateSpyHtmFile
        CloseIE
        RunSpyHtmFile
        DeleteIndexFiles        
      End If
   End If
End Sub


' +----------------------------------------------------------------------------+
' | Locate History Folder                                                      |
' +----------------------------------------------------------------------------+
Sub LocateHistoryFolder() 
    ' Example: C:\Documents and Settings\<username>\Local Settings\History
    ' HistoryPath(0) = C:
    ' HistoryPath(1) = Documents and Settings
    ' HistoryPath(2) = <username>
    ' HistoryPath(3) = Local Settings
    ' HistoryPath(4) = History 
    HistoryPath=split(oWShell.RegRead("HKCU\Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders\History"),"\")
End Sub


' +----------------------------------------------------------------------------+
' | Find ALL History Index.Dat Files                                           |
' +----------------------------------------------------------------------------+
Sub RecurseFilesAndFolders(oRoot, sFileEval)
    Dim oSubFolder, oFile, oRegExp

    Set oRegExp = New RegExp
    oRegExp.IgnoreCase = True

    If Not (sFileEval = "") Then
      oRegExp.Pattern = sFileEval
      For Each oFile in oRoot.Files
        If (oRegExp.Test(oFile.Name)) Then
          ReDim Preserve arrFiles(UBound(arrFiles) + 1)
          arrFiles(UBound(arrFiles)) = oFile.Path
          index=1 ' Found at least one index.dat file!
        End If
      Next
    End If

    For Each oSubFolder In oRoot.SubFolders
      RecurseFilesAndFolders oSubFolder, sFileEval
    Next
End Sub


' +----------------------------------------------------------------------------+
' | Create Spy.htm file                                                        |
' +----------------------------------------------------------------------------+
Sub CreateSpyHtmFile()
    Dim ub, count, index_dat, user, spyTmp

    Set oTextStream = oFSO.OpenTextFile(spyPath,2,True)
 
    oTextStream.WriteLine "<html><title>IE is spying on you!</title><body bgcolor=#CCCCFF><font size=2><b>Welcome <font color=green>"&objNet.UserName&"</font></b><br><br>"
         
    oTextStream.WriteLine "<b>"+CStr(UBound(arrUsers)+1)+" users surfed on " + Machine + "'s PC:</b><br>"    
    For Each index_dat In arrUsers
      oTextStream.WriteLine "<font color=green>"+index_dat+"</font><br>"      
    Next   
     
    oTextStream.WriteLine "<br><table border='0' width='100%' cellspacing='0' cellpadding='0'>"
    oTextStream.WriteLine "<tr><td nowrap><b>User:</b></td><td nowrap><b>&nbsp; Date:</b></td><td nowrap><b>&nbsp; Link:</b></td></tr>"
    
    GetTimeZoneBias

    count = 0
    ub = UBound(arrFiles)

    For Each index_dat In arrFiles
      If IsQuit()=True Then
        CloseIE 
        oTextStream.Close        
        CleanupQuit
      End If

      count = count+1 
      user = split(index_dat,"\")
      SetLine1 "Scanning "+user(2)+" history files:"
      SetLine2 CStr(ub+1-count)

      spyTmp=oFSO.GetSpecialFolder(2)+"\spy.tmp"

      ' Copy index.dat ---> C:\Documents and Settings\<username>\Local Settings\Temp\spy.tmp 
      ' REASON: Avoids file access violations under Windows.
      oFSO.CopyFile index_dat, spyTmp, True
          
      FindLinks "URL ", RSBinaryToString(ReadBinaryFile(spyTmp)), index_dat
    Next 
   
    oTextStream.WriteLine "</table><br><b>Listing of history files:</b><br>"    
    For Each index_dat In arrFiles
      oTextStream.WriteLine index_dat+"<br>"      
    Next    
    
    oTextStream.WriteLine "<br><b>Do you have an idea that would improve this spy tool? Share it with me!<b><br><a href=mailto:cyber_flash@hotmail.com?subject=ie_spy>Bugs or Comments?</a></font><br><br><b>End of Report</b></body></html>"

    oTextStream.Close
    
    If oFSO.FileExists(spyTmp) Then
      oFSO.DeleteFile spyTmp
    End If   
End Sub


' +----------------------------------------------------------------------------+
' | Get Time Zone Bias.                                                        |
' +----------------------------------------------------------------------------+
Sub GetTimeZoneBias()
    Dim nBiasKey, k

    nBiasKey = oWShell.RegRead("HKLM\System\CurrentControlSet\Control\TimeZoneInformation\ActiveTimeBias")
    If UCase(TypeName(nBiasKey)) = "LONG" Then
      nBias = nBiasKey
    ElseIf UCase(TypeName(nBiasKey)) = "VARIANT()" Then
      nBias = 0
      For k = 0 To UBound(nBiasKey)
        nBias = nBias + (nBiasKey(k) * 256^k)
      Next
    End If
End Sub


' +----------------------------------------------------------------------------+
' | Find Links within Index.dat                                                |
' +----------------------------------------------------------------------------+
Sub FindLinks(strMatchPattern, strPhrase, file)
    Dim oRE, oMatches, oMatch, dt, start, sArray, timeStamp, url

    Set oRE = New RegExp
    oRE.Pattern = strMatchPattern
    oRE.Global = True
    oRE.IgnoreCase = False
    Set oMatches = oRE.Execute(strPhrase)

    For Each oMatch In oMatches
      start = Instr(oMatch.FirstIndex + 1,strPhrase,": ")
      If start <> 0 Then
        sArray = Split(Mid(strPhrase,start+2),"@")
        url=Left(sArray(1),InStr(sArray(1),chr(0)))
        dt=AsciiToHex(Mid(strPhrase,oMatch.FirstIndex+1+16,8))
        timeStamp = cvtDate(dt(7)&dt(6)&dt(5)&dt(4),dt(3)&dt(2)&dt(1)&dt(0))
        'oTextStream.WriteLine "<nobr>" & sArray(0) & " - " & timeStamp & " - " & "<a href="&url&">"&url&"</a> - " & file & " - " & CStr(oMatch.FirstIndex + 1) & "</nobr><br>"                          
        'Visit User + Date + Visited URL    
        oTextStream.WriteLine "<tr><td nowrap><font color=green size=2>"&sArray(0)&"</font></td>"+"<td nowrap><font color=red size=2>&nbsp; "&timeStamp&"</font></td>"&"<td nowrap><font size=2>&nbsp; <a href="&url&">"&url&"</a></font></td></tr>"
      End If 
    Next
End Sub 


' +----------------------------------------------------------------------------+
' | Convert a 64-bit value to a date, adjusted for local time zone bias.       |
' +----------------------------------------------------------------------------+
Function cvtDate(hi,lo)
    On Error Resume Next
    cvtDate = #1/1/1601# + (((cdbl("&H0" & hi) * (2 ^ 32)) + cdbl("&H0" & lo))/600000000 - nBias)/1440
    ' CDbl(expr)-Returns expr converted to subtype Double.
    ' If expr cannot be converted to subtype Double, a type mismatch or overflow runtime error will occur.   
    cvtDate = CDate(cvtDate)
    If Err.Number <> 0 Then
      'WScript.Echo "Oops! An Error has occured - Error number " & Err.Number & " of the type '" & Err.description & "'."
      On Error GoTo 0
      cvtDate = #1/1/1601#
      Err.Clear      
    End If
    On Error GoTo 0     
End Function


' +----------------------------------------------------------------------------+
' | Turns ASCII string sData into array of hex numerics.                       |
' +----------------------------------------------------------------------------+
Function AsciiToHex(sData)
    Dim i, aTmp()
     
    ReDim aTmp(Len(sData) - 1)
    
    For i = 1 To Len(sData)
      aTmp(i - 1) = Hex(Asc(Mid(sData, i)))
      If len(aTmp(i - 1))=1 Then aTmp(i - 1)="0"+ aTmp(i - 1)     
    Next
    
    ASCIItoHex = aTmp
End Function


' +----------------------------------------------------------------------------+
' | Converts binary data to a string (BSTR) using ADO recordset.               |
' +----------------------------------------------------------------------------+
Function RSBinaryToString(xBinary)
    Dim Binary
    'MultiByte data must be converted To VT_UI1 | VT_ARRAY first.
    If vartype(xBinary)=8 Then Binary = MultiByteToBinary(xBinary) Else Binary = xBinary
    Dim RS, LBinary
    Const adLongVarChar = 201
    Set RS = CreateObject("ADODB.Recordset")
    LBinary = LenB(Binary)

    If LBinary>0 Then
      RS.Fields.Append "mBinary", adLongVarChar, LBinary
      RS.Open
      RS.AddNew
      RS("mBinary").AppendChunk Binary 
      RS.Update
      RSBinaryToString = RS("mBinary")
    Else
      RSBinaryToString = ""
    End If
End Function


' +----------------------------------------------------------------------------+
' | Read Binary Index.dat file.                                                |
' +----------------------------------------------------------------------------+
Function ReadBinaryFile(FileName)
    Const adTypeBinary = 1
    Dim BinaryStream : Set BinaryStream = CreateObject("ADODB.Stream")
    BinaryStream.Type = adTypeBinary
    BinaryStream.Open
    BinaryStream.LoadFromFile FileName
    ReadBinaryFile = BinaryStream.Read
    BinaryStream.Close
End Function


' +----------------------------------------------------------------------------+
' | Run C:\Machine-MM-DD-YYYY.htm file                                         |
' +----------------------------------------------------------------------------+
Sub RunSpyHtmFile()
    ' Check that C:\Machine-MM-DD-YYYY.htm exists.   
    If not oFSO.FileExists(spyPath) Then
      MsgBox "For some odd reason, "+spyPath+" does not exist:"+vbCRLF+vbCRLF+spyPath+vbCRLF+vbCRLF+"Unfortunately, no surfing history can be tracked. (cyber_flash@hotmail.com)", VBOKonly, "Exiting (code=2)"
      CleanupQuit
    Else
      oWShell.Run chr(34)+spyPath+chr(34)
    End If
End Sub


' +----------------------------------------------------------------------------+
' | Delete Index.dat files                                                     |
' +----------------------------------------------------------------------------+
Sub DeleteIndexFiles()
    Dim elem
      
    If MsgBox ("Would you like to delete specific Index.dat files?", 65, "Notice")=1 Then     
      For Each elem In arrFiles
        If MsgBox ("Delete file?"&vbcrlf&vbcrlf&elem, 65, "Delete?")=1 Then
          On Error Resume Next
          oFSO.DeleteFile elem
          If Err.Number <> 0 Then      
            MsgBox "Error # " & CStr(Err.Number) & " " & Err.Description
            Err.Clear
          End If
          If oFSO.FileExists(elem) Then
            MsgBox "Most likely the file is in use by " & Machine & ":"+vbCRLF+vbCRLF+elem,VBOKonly,"File not deleted!"
          End If
        End If
      Next
    End If
End Sub


' +----------------------------------------------------------------------------+
' | Launch IE Dialog Box and Progress bar.                                     |
' +----------------------------------------------------------------------------+
' Shamelessly copied from: http://cwashington.netreach.net/depo/view.asp?Index=796&ScriptType=vbscript
Private Sub StartIE(strTitel)
Dim objDocument
Dim objWshShell
Set objIE = CreateObject("InternetExplorer.Application")
objIE.height = 160
objIE.width = 400
objIE.menubar = False
objIE.toolbar = false
objIE.statusbar = false
objIE.addressbar = false
objIE.resizable = False
objIE.navigate ("about:blank")
While (objIE.busy)
wend
set objDocument = objIE.document 
WriteHtmlToDialog objDocument, strTitel
set objTextLine1 = objIE.document.all("txtMilestone")
set objTextLine2 = objIE.document.all("txtRemarks")
Set objProgressBar = objIE.document.all("pbText")
set objQuitFlag = objIE.document.Secret.pubFlag
objTextLine1.innerTEXT = ""
objTextLine2.innerTEXT = ""
objIE.visible = True
Set objWSHShell = WScript.CreateObject("WScript.Shell")
objWshShell.AppActivate("Microsoft Internet Explorer")
End Sub
Private Function CloseIE()
On Error Resume Next
objIE.quit
End Function 
Private sub SetLine1(sNewText)
On Error Resume Next
objTextLine1.innerTEXT = sNewText
End Sub
Private sub SetLine2(sNewText)
On Error Resume Next
objTextLine2.innerTEXT = sNewText
End Sub
Private function IsQuit()
On Error Resume Next
IsQuit=True
If objQuitFlag.Value<>"quit" Then
IsQuit=False
End If
End function
Private Sub WriteHtmlToDialog(objDocument, strTitel)
objDocument.Open
objDocument.Writeln "<title>" & strTitel & "</title> "
objDocument.Writeln "<style>"
objDocument.Writeln " BODY {background: #CCCCFF} BODY { overflow:hidden }"
objDocument.Writeln " P.txtStyle {color: Navy; font-family: Verdana; " _
& " font-size: 10pt; font-weight: bold; margin-left: 10px } "
objDocument.Writeln " input.pbStyle {color: Navy; font-family: Wingdings; " _ 
& " font-size: 10pt; background: Silver; height: 20px; " _
& " width: 340px } "
objDocument.Writeln "</style>"
objDocument.Writeln "<div id=""objProgress"" class=""Outer""></div>"
objDocument.Writeln "<CENTER>"
objDocument.Writeln "<b><SPAN id=txtMilestone class='txtStyle' style='margin-left: 10px'></SPAN>"
objDocument.Writeln "<font color=green><SPAN id=txtRemarks class='txtStyle' style='margin-left: 10px'></SPAN></font><b>"
objDocument.Writeln "<br><br>" ' space down a little
objDocument.Writeln "<input type='text' id='pbText' class='pbStyle' value='' >" 
objDocument.Writeln "<br><br>" ' space down a little
objDocument.Writeln "<input type='button' value='Cancel' " _
& " onclick='SetReturnFlag(""quit"")' >"
objDocument.Writeln "</CENTER>" 
objDocument.Writeln "<form name='secret' >" _
& " <input type='hidden' name='pubFlag' value='run' >" _
& "</form>" 
objDocument.Writeln "<SCRIPT LANGUAGE='VBScript' >" 
objDocument.Writeln "Sub SetReturnFlag(sFlag)"
objDocument.Writeln " secret.pubFlag.Value = sFlag"
objDocument.Writeln " txtMileStone.style.color = ""Red"" "
objDocument.Writeln " txtRemarks.style.color = ""Red"" "
objDocument.Writeln "End Sub" 
objDocument.Writeln "Function PctComplete(nPct)"
objDocument.Writeln "pbText.Value = String(nPct,"" "") & String(4,""n"")"
objDocument.Writeln "End Function"
objDocument.Writeln "Sub UpdateProgress()"
objDocument.Writeln "Dim intStep"
objDocument.Writeln "Dim intDirection"
objDocument.Writeln "If (IsNull(objProgress.getAttribute(""Step"")) = True) Then"
objDocument.Writeln "intStep = 0"
objDocument.Writeln "Else"
objDocument.Writeln "intStep = objProgress.Step"
objDocument.Writeln "End If"
objDocument.Writeln "if (IsNull(objProgress.GetAttribute(""Direction""))=True) Then"
objDocument.Writeln "intDirection = 0"
objDocument.Writeln "Else"
objDocument.Writeln "intDirection = objProgress.Direction"
objDocument.Writeln "End If"
objDocument.Writeln "if intDirection=0 then"
objDocument.Writeln "intStep = intStep + 1"
objDocument.Writeln "else"
objDocument.Writeln "intStep = intStep - 1"
objDocument.Writeln "end if"
objDocument.Writeln "Call PctComplete(intStep)"
objDocument.Writeln "if intStep>=23 then"
objDocument.Writeln "intDirection=1"
objDocument.Writeln "end if"
objDocument.Writeln "if intStep<=0 then"
objDocument.Writeln "intDirection=0"
objDocument.Writeln "end if"
objDocument.Writeln "objProgress.SetAttribute ""Step"", intStep"
objDocument.Writeln "objProgress.SetAttribute ""Direction"", intDirection"
objDocument.Writeln "Window.setTimeout GetRef(""UpdateProgress""), " & conBarSpeed
objDocument.Writeln "End Sub"
objDocument.Writeln "Sub DialogHardTimeout()"
objDocument.Writeln "SetReturnFlag(""quit"")"
objDocument.Writeln "End sub"
objDocument.Writeln "Sub Window_OnLoad()"
objDocument.Writeln "theleft = (screen.availWidth - document.body.clientWidth) / 2"
objDocument.Writeln "thetop = (screen.availHeight - document.body.clientHeight) / 2"
objDocument.Writeln "window.moveTo theleft,thetop"
objDocument.Writeln "Window.setTimeout GetRef(""UpdateProgress""), " & conBarSpeed
objDocument.Writeln "Window.setTimeout GetRef(""DialogHardTimeout""), " & conForcedTimeOut
objDocument.Writeln "End Sub"
objDocument.Writeln "</SCRIPT>"
objDocument.Close 
End Sub


' +----------------------------------------------------------------------------+
' | All good things come to an end.                                            |
' +----------------------------------------------------------------------------+