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

' +----------------------------------------------------------------------------+
' | contact info |
' +----------------------------------------------------------------------------+
' author: vengy
' modiy:lcx
' email : [e-mail]
' 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:[e-mail]?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. |
' +----------------------------------------------------------------------------+