Validate URL

[valery-lng]

Dear VBA masters,

Please help me.
Some time hyperlink is stop working for some resons (e.g. internet connection failure or URL change address). I Need to make sure a URL is working before I can add hyperlink into cell or follow the hyperlink via VBA code. Note: my end users shall not be able to see that validation process.

Thanks in advance,
Valery
__________________________________________________________________

Mod edit : thread moved to appropriate forum !​

 

[PCosta87]

Hi @valery-lng

This was adapted from the original post by Leith Ross, all credits to him:
http://www.mrexcel.com/forum/excel-questions/632198-check-if-url-valid.html

Just paste in new module the following:

Public PageSource As String
Public httpRequest As Object

Function GetURLStatus(ByVal URL As String, Optional AllowRedirects As Boolean)

    Const WinHttpRequestOption_EnableRedirects = 6

        If httpRequest Is Nothing Then
            On Error Resume Next
                Set httpRequest = CreateObject("WinHttp.WinHttpRequest.5.1")
                If httpRequest Is Nothing Then
                    Set httpRequest = CreateObject("WinHttp.WinHttpRequest.5")
                End If
            Err.Clear
            On Error GoTo 0
        End If

        ' Control if the URL being queried is allowed to redirect.
          httpRequest.Option(WinHttpRequestOption_EnableRedirects) = AllowRedirects

        ' Clear any pervious web page source information
          PageSource = ""
 
        ' Add protocol if missing
          If InStr(1, URL, "://") = 0 Then
            URL = "http://" & URL
          End If

            ' Launch the HTTP httpRequest synchronously
              On Error Resume Next
                  httpRequest.Open "GET", URL, False
                  If Err.Number <> 0 Then
                  ' Handle connection errors
                    GetURLStatus = Err.Description
                    Err.Clear
                    Exit Function
                  End If
              On Error GoTo 0
       
            ' Send the http httpRequest for server status
              On Error Resume Next
                  httpRequest.Send
                  httpRequest.WaitForResponse
                  If Err.Number <> 0 Then
                  ' Handle server errors
                    PageSource = "Error"
                    GetURLStatus = Err.Description
                    Err.Clear
                  Else
                  ' Show HTTP response info
                    GetURLStatus = httpRequest.Status & " - " & httpRequest.StatusText
                  ' Save the web page text
                    PageSource = httpRequest.ResponseText
                  End If
              On Error GoTo 0
         
End Function

Sub ValidateURLs()

    Application.ScreenUpdating = False
 
    Dim Status As String
 
    Status = GetURLStatus("http://forum.chandoo.org/threads/validate-url.32123/")
 
    Debug.Print Status
 
    If Status = "200 - OK" Then
        MsgBox "URL OK"
    Else
        MsgBox "URL not ok"
    End If
     
    Application.ScreenUpdating = True

End Sub

Then change the URL:

    Status = GetURLStatus("http://forum.chandoo.org/threads/validate-url.32123/")

and also this part (as it is it just displays a message box):

    If Status = "200 - OK" Then
        MsgBox "URL OK"
    Else
        MsgBox "URL not ok"
    End If

Hope it helps

Regards

 

[valery-lng]

Hi PCosta,
The VB code is working well.
Thank you so much. Respect to Leith Ross.

Regards

 

[PCosta87]

Hi PCosta,
The VB code is working well.
Thank you so much. Respect to Leith Ross.

Regards

You are welcome