Function NavigateTo(Link As String, Optional WaitSeconds = 5) As Long
' ZVI:2011-08-04 VBA Macro For Already Open IE Window
' Navigate (Internet)Explorer to the Link with [WaitSeconds=5] timeout.
' If (Internet)Explorer is already navigated to the Link then it's just activated,
' else the new (Internet)Explorer is navigated to the Link.
' Returns error number (zero at success)
' Note: comment "Application.StatusBar" lines for VB & VBScript compatibility
Dim i As Long, t As Single, Url As String, w As Object, wUrl As String
' Uniform Link string
Url = Trim(Replace(Replace(Link, "%20", " "), "\", "/"))
' Find "://" prefix
i = InStr(Url, "://")
If i > 1 And i < 7 Then Url = Mid(Url, i + 3)
' Delete "/" at the end
If Right(Url, 1) = "/" Then Url = Left(Url, Len(Url) - 1)
' Seach Link in IE windows
Application.StatusBar = "Finding link: " & Link & " ..."
For Each w In CreateObject("Shell.Application").Windows
' Uniform LocationURL string
wUrl = Trim(Replace(Replace(w.LocationURL, "%20", " "), "\", "/"))
' Find "://" prefix
i = InStr(wUrl, "://")
If i > 1 And i < 7 Then wUrl = Mid(wUrl, i + 3)
' Del 3d "/" in prefix for local Link
If Mid(wUrl, 1, 1) = "/" Then wUrl = Mid(wUrl, 2)
' Delete "/" at the end
If Right(wUrl, 1) = "/" Then wUrl = Left(wUrl, Len(wUrl) - 1)
If StrComp(Url, wUrl, 1) = 0 Then
' Link is found - activate it's IE window
w.Visible = True
Exit For
Else
wUrl = ""
End If
Next
' If Link is not found then create new IE and navigate to the Link
On Error Resume Next
If Len(wUrl) = 0 Then
With CreateObject("InternetExplorer.Application")
' Disable pop-up msgs
.Silent = True
' Navigate
Application.StatusBar = "Navigating to: " & Link & " ..."
.Navigate Link
' Charge the timeout
t = Timer + WaitSeconds
' Wait for "IE is ready" state
Application.StatusBar = "Waiting for IE's complete state..."
While .ReadyState <> 4 And Timer < t: DoEvents: Wend
' Wait for "IE.Document is completely downloaded" state
If Timer < t Then
Application.StatusBar = "Waiting for Document's downloaded state..."
While .Document Is Nothing And Timer < t: DoEvents: Wend
Else
Err.Raise vbObjectError + 513, , "Timeout happens: " & WaitSeconds & " seconds"
End If
' Activate IE
Application.StatusBar = False
If Err Then .Quit Else .Visible = True
End With
End If
' Release the memory of object variable
Set w = Nothing
' Return error number (zero if successful)
NavigateTo = Err.Number
' Show error message
If Err.Number <> 0 Then
Application.StatusBar = "NavigateTo: " & Replace(Err.Description, vbLf, " - ")
' Uncomment the line below to show error message
'MsgBox Err.Description, vbExclamation, "NavigateTo"
End If
End Function
