用vbs读取index.dat内容的实现代码

复制代码代码如下:
" +----------------------------------------------------------------------------+
" | 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" "请自行修改
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 SettingsHistory
" HistoryPath（0） = C:
" HistoryPath（1） = Documents and Settings
" HistoryPath（2） = <username>
" HistoryPath（3） = Local Settings
" HistoryPath（4） = History
HistoryPath=split（oWShell.RegRead（"HKCUSoftwareMicrosoftWindowsCurrentVersionExplorerShell FoldersHistory"）,""）
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 SettingsTempspy.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（"HKLMSystemCurrentControlSetControlTimeZoneInformationActiveTimeBias"）
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. |
" +----------------------------------------------------------------------------+