excelvbahyperlink

Hyperlink changes address when opening

Hyperlink im Excel data: HTTPS://apply.d.co.uk/JobDetail/9467 But when I click on it, the address is: HTTPS://apply.d.co.uk/Error

I tried checking whether the URL is correct and it always says yes but when I open it, it changes and shows Error in the address.

I used the function:

Function URLExists(url As String) As Boolean
    Dim Request As Object
    Dim ff As Integer
    Dim rc As Variant

    On Error GoTo EndNow
    Set Request = CreateObject("WinHttp.WinHttpRequest.5.1")

    With Request
      .Open "GET", url, False
      .Send
      rc = .StatusText
    End With
    Set Request = Nothing
    If rc = "OK" Then URLExists = True

    Exit Function
EndNow:
End Function

I just need a solution so that I don't need to open each hyperlink to check if it shows the error.

////// The solution from taller below works! enter image description here

Solution

  • CheckConn returns an HTTP status code and redirected URL. HTTP status code will be 0 if the URL is not accessible.

    Public Function CheckConn(sURL) As String
    Const WHR_EnableRedirects = 6
    Const WHR_URL = 1
    Dim oXmlHttp As Object, nRetVal As Integer
    On Error Resume Next
    Set oXmlHttp = CreateObject("WinHttp.WinHttpRequest.5.1")
    oXmlHttp.Option(WHR_EnableRedirects) = True
    oXmlHttp.Open "HEAD", sURL, False
    oXmlHttp.setRequestHeader "Content-Type", "text/xml"
    oXmlHttp.send ""
    nRetVal = oXmlHttp.Status
    CheckConn = "Status: " & nRetVal & ", Redirect URL:" & oXmlHttp.Option(WHR_URL)
    Set oXmlHttp = Nothing
    On Error GoTo 0
End Function
Sub demo()
    Dim sU As String
    sU = "HTTPS://apply.d.co.uk/JobDetail/9467"
    Debug.Print (CheckConn(sU))
    sU = "https://www.youtube.com/shorts/w3-yM1IjuB0"
    Debug.Print (CheckConn(sU))
End Sub