Check the URL before opening a website!

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.

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
 

Users who are viewing this thread

Back
Top Bottom