网站首页  汉语字词  英语词汇  考试资料  写作素材  旧版资料

请输入您要查询的范文：

　

标题 用vbs读取index.dat内容的实现代码
范文
    用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 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. |
    ' +----------------------------------------------------------------------------+
随便看

　

在线学习网范文大全提供好词好句、学习总结、工作总结、演讲稿等写作素材及范文模板，是学习及工作的有利工具。

　

Copyright © 2002-2024 cuapp.net All Rights Reserved
更新时间：2025/5/21 9:02:26