lhouk
Thu Jun 17 09:34:46 CDT 2004
Brian Staff <brianstaff@[NoSpam]compuserve.com> wrote in message news:<VA.00000274.338dfc26@bstaffw2k>...
> Leslie,
>
> > Hmm. So there's no easy way to write a VBScript program that would dump
> > the contents of my 12-year-old son's IE history and mail it to me, so I
> > can make sure he isn't learning more about sex than I know?
>
> hmmm! I have 3 early teenagers too - I'll be interested if you find anything.
>
> Brian
Brian,
This is what I finally came up with. I've been using it for a week or
so, and I've been getting an email every time my son logs in, since I
put it in his Startup folder. Hope you find it useful,
Leslie
----- cut here -----
Option Explicit
On Error Resume Next
Const READONLY = 1
Const MAX_BUFFER_SIZE = 32000
Dim objWShell, objFileSys, objFile, strUserProfile, strHistoryFile
Dim strSchema, objConfig, objMessage, objPOP3, Server
Dim strFrom, strTo, strSubject, strServer, strPassword
Dim strCommand, strURL, strOldURL, strBuffer, strByte
Dim intByteCode, intURLCount, intBufLen, intNewURL, intIndex, intI
Dim strURLList()
' Set these to the correct values for you
strFrom = "sender@yourISP.com"
strTo = "recipient@yourISP.com"
strServer = "yourISP.com"
strPassword = "yourPassword"
Set objWShell = CreateObject( "WScript.Shell" )
strUserProfile = objWShell.ExpandEnvironmentStrings( "%USERPROFILE%" )
strHistoryFile = strUserProfile & _
"\Local Settings\Temporary Internet Files\Content.IE5\index.dat"
Set objFileSys = CreateObject( "Scripting.FileSystemObject" )
If objFileSys.FileExists( strHistoryFile ) Then
' ' Scan the history file for URLs
Set objFile = objFileSys.OpenTextFile( strHistoryFile, READONLY )
intIndex = MAX_BUFFER_SIZE
intBufLen = MAX_BUFFER_SIZE
ReDim strURLList(0)
intNewURL = 0
Do
strByte = NextByte( strBuffer, intBufLen, intIndex )
For intI = 1 To 7
If strByte = Mid( "
http://", intI, 1 ) Then
If intI < 7 Then
strByte = NextByte(strBuffer, intBufLen, intIndex)
Else
strURL = "
http://"
strByte = NextByte(strBuffer, intBufLen, intIndex)
intByteCode = Asc( strByte )
' ' Read URL, omitting trailing parameters
Do While intByteCode > 31 And intByteCode <> 34 _
And strByte <> "?"
strURL = strURL & strByte
strByte = NextByte( strBuffer, intBufLen, _
intIndex )
intByteCode = Asc( strByte )
Loop
intNewURL = 1
End If
Else
Exit For
End If
Next
If intNewURL = 1 Then
' ' Truncate long URLs
strURL = Left( strURL, 72 )
' ' Skip immediately duplicated URLs
If strOldURL <> strURL Then
intURLCount = UBound( strURLList ) + 1
ReDim Preserve strURLList( intURLCount )
strURLList( intURLCount ) = strURL
strOldURL = strURL
End If
intNewURL = 0
End If
Loop Until objFile.AtEndOfStream
objFile.Close
Set objFile = Nothing
Set objFileSys = Nothing
' ' Clean cache using Marty List's IECache.exe:
' '
http://www.optimumx.com/download/
objWShell.Run "C:\Progra~1\IECache.exe /DELETE", 0, True
' ' Since my ISP requires POP3-before-SMTP, do a POP3 login
' ' using Simon Fell's Zaks.POP3 module:
' '
http://www.zaks.demon.co.uk/code/cpts/pop/index.html
Set objPOP3 = CreateObject( "zakspop3.Server" )
objPOP3.mailServerHost = "pop." & strServer
objPOP3.mailAccount = strFrom
objPOP3.mailPassword = strPassword
If Not objPOP3.Login Then
WScript.Echo( "POP3 login to pop." & strServer & " failed." )
' ' Give me time to read the error message
WScript.Sleep 10000
WScript.Quit( 7 )
End If
strSchema = "
http://schemas.microsoft.com/cdo/configuration/"
Set objConfig= CreateObject( "CDO.Configuration" )
objConfig.Fields.Item( strSchema & "sendusing" ) = 2
objConfig.Fields.Item( strSchema & "smtpserverport" ) = 25
objConfig.Fields.Item( strSchema & "smtpserver" ) = "smtp." & _
strServer
objConfig.Fields.Item( strSchema & "smtpauthenticate" ) = 1
objConfig.Fields.Item( strSchema & "sendusername" ) = strFrom
objConfig.Fields.Item( strSchema & "sendpassword" ) = strPassword
objConfig.Fields.Update
set objMessage = CreateObject( "CDO.Message" )
objMessage.Configuration = objConfig
objMessage.From = strFrom
objMessage.To = strTo
intIndex = InStrRev( strUserProfile, "\" ) + 1
objMessage.Subject = "URLs accessed by " & Mid( strUserProfile, _
intIndex )
objMessage.TextBody = Join( strURLList, vbCrLf )
For intIndex = 1 To 3
WScript.Sleep 5000
intI = objMessage.Send
If intI = 0 Then
Set objMessage=Nothing
Set objConfig=Nothing
Set objWShell = Nothing
WScript.Quit( 0 )
End If
Next
WScript.Echo( "objMessage.Send returned " & intI )
WScript.Echo( "Error Number: " & Err.Number )
WScript.Echo( "Error Description: " & Err.Description )
' ' Give me time to read the error message
WScript.Sleep 10000
Set objMessage=Nothing
Set objConfig=Nothing
Set objWShell = Nothing
WScript.Quit( 3 )
Else
WScript.Echo( "Can not read history file:" & vbCrLf & _
" " & strHistoryFile )
' ' Give me time to read the error message
WScript.Sleep 10000
WScript.Quit( 5 )
End If
' ===== SUBROUTINES AND FUNCTIONS =====
Function NextByte( strBuffer, intBufLen, intIndex )
If intIndex = intBufLen Then
strBuffer = objFile.Read( MAX_BUFFER_SIZE )
intIndex = 1
intBufLen = Len( strBuffer )
Else
intIndex = intIndex + 1
End If
NextByte = Mid( strBuffer, intIndex, 1 )
End Function