Hi
i have this code which is supposed to record all the urls hit during IE web navigation into a file sort of like the cache file IE produces. but it is in VB5 and i am using VBA.
the part i can't get a handle on is where the actual web page navigation is taking place, or how the routine is actually picking up the URLs, etc. this'll probably go down as another goose egg thread, but if anyone knows how to translate this code to VBA i'd appreciate the insight.
or maybe there is a VB to VBA translator?
Form
Class
i have this code which is supposed to record all the urls hit during IE web navigation into a file sort of like the cache file IE produces. but it is in VB5 and i am using VBA.
the part i can't get a handle on is where the actual web page navigation is taking place, or how the routine is actually picking up the URLs, etc. this'll probably go down as another goose egg thread, but if anyone knows how to translate this code to VBA i'd appreciate the insight.
or maybe there is a VB to VBA translator?
Form
Code:
Option Explicit
Private mCol As Collection
Private WithEvents IE1 As SHDocVw.InternetExplorer
Private m_lLineCnt As Long
Private Sub GetBrowserData()
Dim doc As Variant
Dim htmlDoc As HTMLDocument
Dim SWs As SHDocVw.ShellWindows
Dim sUrl As String
Dim i As Long
Dim lWinCnt As Long
Dim sCaption As String
Dim lUrlCnt As Long
Dim IE2 As SHDocVw.InternetExplorer
Static lCount As Long
On Error Resume Next
lCount = lCount + 1
' Find the active browser window
Set SWs = New SHDocVw.ShellWindows
' Scan all windows
For Each IE2 In SWs
Set IE1 = IE2
With IE1
On Error Resume Next
Set doc = .document
If TypeOf doc Is HTMLDocument Then
Set htmlDoc = .document
lWinCnt = lWinCnt + 1
sUrl = IE1.LocationURL
If htmlDoc.frames.Length > 0 Then
For i = 0 To htmlDoc.frames.Length - 1
ParseFrames htmlDoc.frames.Item(i), lCount
Next i
End If
AddUrl sUrl, htmlDoc.referrer, lCount, False, (htmlDoc.frames.Length > 0), False
End If
End With
Next
lUrlCnt = SaveData(lCount)
If lUrlCnt > 0 Or lWinCnt > 0 Then
sCaption = "Windows: " & lWinCnt & vbLf & "Urls: " & lUrlCnt
Else
sCaption = "IE Logger v1.0"
End If
If sCaption <> lblLog.Caption Then lblLog.Caption = sCaption
If Me.Caption <> sCaption Then Me.Caption = sCaption
End Sub
Private Function SaveData(Counter As Long) As Long
Dim iFF As Integer
Dim cMonitor As clsMonitor
Dim i As Long
Dim bOpen As Boolean
bOpen = False
iFF = FreeFile
For i = mCol.Count To 1 Step -1
Set cMonitor = mCol(i)
If cMonitor.Counter <> Counter Then
If Not bOpen Then
Open App.Path & "\IE" & Format(Now, "yyyymmdd") & ".url" For Append As iFF
bOpen = True
End If
mCol.Remove i
With cMonitor
If Len(.Location) > 0 Then
m_lLineCnt = m_lLineCnt + 1
Print #iFF, .StartDate & vbTab & .EndDate & vbTab & .Location & vbTab & .Parameters & vbTab & .FrameSet & vbTab & .Frame & vbTab & .NavError
End If
End With
Else
If Not cMonitor.FrameSet Then
SaveData = SaveData + 1
End If
End If
Next i
If bOpen Then Close iFF
Set cMonitor = Nothing
End Function
Private Sub ParseFrames(frameWindow As HTMLWindow2, Counter As Long)
Dim i As Integer
With frameWindow
If .frames.Length > 0 Then
For i = 0 To .frames.Length - 1
ParseFrames .frames.Item(i), Counter
Next i
End If
AddUrl .Location, "", Counter, True, (.frames.Length > 0), False
End With
End Sub
Private Sub AddUrl(sUrl As String, sReferrer As String, Counter As Long, bFrame As Boolean, bFrameSet As Boolean, bError As Boolean)
Dim cMonitor As clsMonitor
On Error Resume Next
Set cMonitor = mCol(sUrl)
If Err.Number <> 0 Then
Set cMonitor = New clsMonitor
cMonitor.StartDate = Now()
cMonitor.URL = sUrl
cMonitor.Counter = Counter
cMonitor.Frame = bFrame
cMonitor.FrameSet = bFrameSet
cMonitor.NavError = bError
mCol.Add cMonitor, sUrl
Debug.Print "Open: " & sUrl, cMonitor.StartDate, bError
Else
If bError Then cMonitor.NavError = True
cMonitor.EndDate = Now
cMonitor.Counter = Counter
End If
On Error GoTo 0
Set cMonitor = Nothing
End Sub
Private Sub Form_Load()
Set mCol = New Collection
End Sub
Private Sub Form_Unload(Cancel As Integer)
'Just to be sure that the most recent data will be saved
SaveData -1
Set mCol = Nothing
End Sub
Private Sub IE1_NavigateError(ByVal pDisp As Object, URL As Variant, Frame As Variant, StatusCode As Variant, Cancel As Boolean)
AddUrl CStr(URL), "", 0, False, False, True
Debug.Print URL, StatusCode
End Sub
Private Sub lblLog_Click()
Me.WindowState = vbMinimized
End Sub
Private Sub Timer1_Timer()
GetBrowserData
End SubClass
Code:
Option Explicit
Dim m_URL As String
Dim m_dtStart As Date
Dim m_dtEnd As Date
Dim m_lCounter As Long
Dim m_bFrame As Boolean
Dim m_bFrameSet As Boolean
Dim m_bNavError As Boolean
Public Property Let NavError(ByVal bValue As Boolean)
m_bNavError = bValue
End Property
Public Property Get NavError() As Boolean
NavError = m_bNavError
End Property
Public Property Let URL(ByVal sValue As String)
m_URL = sValue
End Property
Public Property Get URL() As String
URL = m_URL
End Property
Public Property Let StartDate(ByVal Value As Date)
m_dtStart = Value
m_dtEnd = Value
End Property
Public Property Get StartDate() As Date
StartDate = m_dtStart
End Property
Public Property Let EndDate(ByVal Value As Date)
m_dtEnd = Value
End Property
Public Property Get EndDate() As Date
EndDate = m_dtEnd
End Property
Public Property Let Counter(ByVal Value As Long)
m_lCounter = Value
End Property
Public Property Get Counter() As Long
Counter = m_lCounter
End Property
Public Property Let Frame(ByVal Value As Boolean)
m_bFrame = Value
End Property
Public Property Get Frame() As Boolean
Frame = m_bFrame
End Property
Public Property Let FrameSet(ByVal Value As Boolean)
m_bFrameSet = Value
End Property
Public Property Get FrameSet() As Boolean
FrameSet = m_bFrameSet
End Property
Public Function Location() As String
Dim lPos As Long
lPos = InStr(1, m_URL, "?", vbBinaryCompare)
If lPos > 1 Then
Location = Left$(m_URL, lPos - 1)
Else
Location = m_URL
End If
End Function
Public Function Parameters() As String
Dim lPos As Long
lPos = InStr(1, m_URL, "?", vbBinaryCompare)
If lPos > 0 Then
Parameters = Mid$(m_URL, lPos + 1)
Else
Parameters = ""
End If
End Function