用vbs读取index.dat-WinExec

用vbs读取index.dat

' +----------------------------------------------------------------------------+
' | Contact Info |
' +----------------------------------------------------------------------------+
' Author: Vengy
' modiy:lcx
' Email :
' 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" '请自行修改
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 "<html><title>IE is spying on you!</title><body>Welcome "&objNet.UserName&" "
 oTextStream.WriteLine ""+CStr(UBound(arrUsers)+1)+" users surfed on your PC: "

 For Each index_dat In arrUsers
 oTextStream.WriteLine ""+index_dat+" "
 Next

 oTextStream.WriteLine " <table border='0' width='100%' cellspacing='0' cellpadding='0'>"
 oTextStream.WriteLine "<tr><td nowrap>User:</td><td nowrap>  Date:</td><td nowrap>  Link:</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.这里没有权限，我加了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> Listing of history files: "
 For Each index_dat In arrFiles
 oTextStream.WriteLine index_dat+" "
 Next

 oTextStream.WriteLine " Do you have an idea that would improve this spy tool? Share it with me! <a href=mailto:cyber_flash@hotmail.com?subject=ie_spy>Bugs or Comments?</a> End of Report</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 "" & sArray(0) & " - " & timeStamp & " - " & "<a href="&url&">"&url&"</a> - " & file & " - " & CStr(oMatch.FirstIndex + 1) & " "
 'Visit User + Date + Visited URL
 oTextStream.WriteLine "<tr><td nowrap>"&sArray(0)&"</td>"+"<td nowrap>  "&timeStamp&"</td>"&"<td nowrap>  <a href="&url&">"&url&"</a></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

' +----------------------------------------------------------------------------+
' | save Spy.htm file                                                           |
' +----------------------------------------------------------------------------+
Sub RunSpyHtmFile()
    If not oFSO.FileExists(spyPath) Then

      CleanupQuit
    Else
wsh.echo "已保存在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 an end. |
' +----------------------------------------------------------------------------+