Joe Boatman
New member
- Local time
- Today, 23:53
- Joined
- May 30, 2020
- Messages
- 25
Using the built-in VBA hyperlink routine is useful - in one click the web page is opened by the default browser. But if the URL is incorrect then either Access or the browser may display a message which most users will not understand (including me).
I prefer to test the URL first so I authored the below fCheckURL() function which you can test using the fCheckURL_TEST routine with some sample website addresses. Please let me know if you find an address that causes an untrapped error!
The routine requires a reference to Microsoft WinHTTP Services which can be found in C:\WINDOWS\system32\WINHTTP.dll.
I prefer to test the URL first so I authored the below fCheckURL() function which you can test using the fCheckURL_TEST routine with some sample website addresses. Please let me know if you find an address that causes an untrapped error!
The routine requires a reference to Microsoft WinHTTP Services which can be found in C:\WINDOWS\system32\WINHTTP.dll.
Code:
Public gnErr As Long 'Last err number
Public gsErr As String 'Last error message
'17 Apr 2020 v1
'Help from kjm87 at http://www.utteraccess.com/forum/validate-hyperlink-VBA-t1037294.html
'Requires reference to Microsoft WinHTTP Services (C:\WINDOWS\system32\WINHTTP.dll)
Private Function fCheckURL(ByRef sURL As String, _
Optional ByRef sReturn As String) As Boolean
Dim sAddress As String, sDate As String
Dim oHTTP As New WinHttpRequest
On Error GoTo ErrH
sDate = VBA.Format$(VBA.Date, "dd mmm yyyy")
sAddress = sURL
TryAgain:
oHTTP.Open "GET", sAddress, False
'oHTTP.Open "HEAD", sAddress, False
oHTTP.Send
temp = oHTTP.StatusText
'Debug.Print oHTTP.ResponseText
If oHTTP.Status = 200 Then
fCheckURL = True
sReturn = sDate & ": Address successfully resolved"
Else
fCheckURL = False
sReturn = sDate & ": " & oHTTP.StatusText
Err.Raise vbObjectError + 32, "fCheckURL", oHTTP.Status & ": " & oHTTP.StatusText
End If
If fCheckURL = True Then sURL = sAddress 'Return the valid address
ExitRoutine:
Set oHTTP = Nothing
Exit Function
ErrH:
gnErr = Err.Number: gsErr = Err.description
If gnErr = vbObjectError + 32 Then '403 Forbudden
sURL = sAddress
sReturn = gsErr
Resume ExitRoutine
ElseIf gnErr = -2147012858 Then 'The host name in the certificate is invalid or does not match
sAddress = VBA.Replace(sAddress, "https://", "http://", , , vbTextCompare)
Resume TryAgain
ElseIf gnErr = -2147012889 Then '19 Apr 2020: The server name or address could not be resolved eg http://www.bathandwest.co.uk
sURL = sAddress
sReturn = gsErr
Resume ExitRoutine 'Long delay if allowed to continue
ElseIf sAddress Like "http://www.*" Then
sAddress = VBA.Replace(sAddress, "http://www.", "https://www.", 1, 1, vbTextCompare)
Resume TryAgain
ElseIf sAddress Like "https://www.*" Then
sAddress = VBA.Replace(sAddress, "https://www.", "http://www.", 1, 1, vbTextCompare)
sReturn = gsErr
Resume ExitRoutine
ElseIf sAddress Like "https://www.*" Then
sAddress = VBA.Replace(sAddress, "https://www.", "https://", 1, 1, vbTextCompare)
Resume TryAgain
ElseIf sAddress Like "http://www.*" Then
sAddress = VBA.Replace(sAddress, "http://www.", "www.", 1, 1, vbTextCompare)
Resume TryAgain
ElseIf sAddress Like "http://www.*" Then
sAddress = VBA.Replace(sAddress, "http://www.", "http://", 1, 1, vbTextCompare)
Resume TryAgain
ElseIf Not (sAddress Like "www.*") Then
sAddress = "www." & sAddress
Resume TryAgain
ElseIf sAddress Like "www.*" Then
sAddress = VBA.Replace(sAddress, "www.", "http://www.", 1, 1, vbTextCompare)
Resume TryAgain
sReturn = "Tried different prefixes but cannot resolve this URL"
End If
If sReturn = "" Then sReturn = gsErr
fCheckURL = False
Resume ExitRoutine
End Function
Private Sub fCheckURL_TEST()
Dim sURL As String, sReturn As String
Dim bRetVal As Boolean 'Return address
' sURL = "adrianprice.co.uk": bRetVal = fCheckURL(sURL, sReturn) 'http://www.adrianprice.co.uk, OK
' sURL = "twaddle.xxx": bRetVal = fCheckURL(sURL, sReturn) 'Cannot resolve
' sURL = "adsltech.com": bRetVal = fCheckURL(sURL, sReturn) 'Resolved http://www.adsltech.com
' sURL = "http://bbc.co.uk": bRetVal = fCheckURL(sURL, sReturn) 'OK
' sURL = "http://www.bbc.co.uk": bRetVal = fCheckURL(sURL, sReturn) 'OK
' sURL = "http://192.168.0.1/": bRetVal = fCheckURL(sURL, sReturn) 'OK
' sURL = "http://secures14.brinkster.com/": bRetVal = fCheckURL(sURL, sReturn) 'OK
' sURL = "http://www.gardenvisit.com/g/stour2.htm": bRetVal = fCheckURL(sURL, sReturn) '404 Not found
' sURL = "http://www.palantir.net/2001/": bRetVal = fCheckURL(sURL, sReturn)
' sURL = "http://www.mobipocket.com": bRetVal = fCheckURL(sURL, sReturn) '403: Forbidden
' sURL = "http://www.webopedia.com": bRetVal = fCheckURL(sURL, sReturn) 'OK but Edge had problems 1st tme, then OK
' sURL = "http://www.dumblaws.com/countries/countries.php?Country=England": bRetVal = fCheckURL(sURL, sReturn) 'Timed out
' sURL = "http://directory.google.com/Top/Computers/Software/Databases/MS_Access/": bRetVal = fCheckURL(sURL, sReturn) '502: Bad gateway
' sURL = "https://utilitypoint.co.uk": bRetVal = fCheckURL(sURL, sReturn) 'OK
sURL = "http://www.bathandwest.co.uk/": bRetVal = fCheckURL(sURL, sReturn) 'Could not be resolved
End Sub