' +----------------------------------------------------------------------------+
' | Contact Info |
' +----------------------------------------------------------------------------+
' Author:vengy
' Modiy:lcx
' Email:cyber_flash@hotmail.com
' Tested:win2k/xp (Win9x not tested!)
Option Explicit
' +----------------------------------------------------------------------------+
' | Setup Constants |
' +----------------------------------------------------------------------------+
Const conbarspeed=80
Const conforcedtimeout=3600000 ' 1 hour
' +----------------------------------------------------------------------------+
' | Setup Objects and Misc Variables |
' +----------------------------------------------------------------------------+
Dim spypath:spypath= "c:\spy.htm" ' please modify it yourself
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 Index
Dim Nbias
' +----------------------------------------------------------------------------+
' | Whose been a naughty surfer? Let ' s find out! ;) |
' +----------------------------------------------------------------------------+
Startspyscan
' +----------------------------------------------------------------------------+
' | 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=historypath (0) & "\" &historypath (1)
If not ofso.folderexists (index_folder) Then
Wsh.echo "No History folder exists. Scan aborted. "
Else
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
Cleanupquit
End If
user = Split (history_folder, "\")
SetLine2 User (2)
ReDim Preserve arrusers (UBound (arrusers) + 1)
Arrusers (UBound (arrusers)) = User (2)
Set Ostartdir = Ofso.getfolder (History_folder)
Recursefilesandfolders Ostartdir, Sfileregexpattern
End If
Next
If IsEmpty (Index) Then
Wsh.echo "No Index.dat files found. Scan aborted. "
Else
Createspyhtmfile
Runspyhtmfile
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 "Otextstream.writeline "<b>" +cstr (UBound (arrusers) +1) + "Users surfed on your 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> DATE:</B></TD><TD nowrap><b> link:</b></td></tr> "
Gettimezonebias
Count = 0
UB = UBound (arrfiles)
For each index_dat in Arrfiles
If isquit () =true Then
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. There is no permission, I added on Error Resume Next
On Error Resume Next
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 a idea that would improve spy of this 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>
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& amp; " > "&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> "&timeStamp&" </font></td> " & "<td nowrap><font size=2> <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 ^)) + CDbl ("&h0" & Lo))/600000000-nbias)/1440
' CDbl (expr)-returns expr converted to subtype Double.
' If expr cannot is converted to subtype Double, a type mismatch or overflow runtime error would 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.
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
' +----------------------------------------------------------------------------+
' | Save spy.htm File |
' +----------------------------------------------------------------------------+
Sub Runspyhtmfile ()
If not ofso.fileexists (Spypath) Then
Cleanupquit
Else
Wsh.echo "Saved in c:\spy.htm"
End If
End Sub
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
' +----------------------------------------------------------------------------+
' | All good things come to a end. |
' +----------------------------------------------------------------------------+
