用vbs读取index.dat内容的实现代码
作者 佚名
来源 ASP编程
浏览
发布时间 2013-07-09
复制代码 代码如下: '' +----------------------------------------------------------------------------+ '' | 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 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><font size=2>Welcome "&objNet.UserName&"<br><br>" 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.这里没有权限,我加了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 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> "&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 ^ 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. | '' +----------------------------------------------------------------------------+ |
凌众科技专业提供服务器租用、服务器托管、企业邮局、虚拟主机等服务,公司网站:http://www.lingzhong.cn 为了给广大客户了解更多的技术信息,本技术文章收集来源于网络,凌众科技尊重文章作者的版权,如果有涉及你的版权有必要删除你的文章,请和我们联系。以上信息与文章正文是不可分割的一部分,如果您要转载本文章,请保留以上信息,谢谢! |
你可能对下面的文章感兴趣
关于用vbs读取index.dat内容的实现代码的所有评论