使用VBA在Excel中对死去的超链接进行排序？

Question

The title says it:

I have an excel Sheet with an column full of hyperlinks. Now I want that an VBA Script checks which hyperlinks are dead or work and makes an entry into the next columns either with the text 404 Error or active.

Hopefully someone can help me because I am not really good at VB.

EDIT:

I found @ http://www.utteraccess.com/forums/printthread.php?Cat=&Board=84&main=1037294&type=thread

A solution which is made for word but the Problem is that I need this solution for Excel. Can someone translate this to Excel solution?

Private Sub testHyperlinks()
    Dim thisHyperlink As Hyperlink
    For Each thisHyperlink In ActiveDocument.Hyperlinks
        If thisHyperlink.Address <> "" And Left(thisHyperlink.Address, 6) <> "mailto" Then
            If Not IsURLGood(thisHyperlink.Address) Then
                Debug.Print thisHyperlink.Address
            End If
        End If
    Next
End Sub


Private Function IsURLGood(url As String) As Boolean
    ' Test the URL to see if it is good
    Dim request As New WinHttpRequest

    On Error GoTo IsURLGoodError
    request.Open "GET", url
    request.Send
    If request.Status = 200 Then
        IsURLGood = True
    Else
        IsURLGood = False
    End If
    Exit Function
IsURLGoodError:
        IsURLGood = False
End Function

Answer 1

First add a reference to Microsoft XML V3 (or above), using Tools->References. Then paste this code:

Option Explicit

Sub CheckHyperlinks()

    Dim oColumn As Range
    Set oColumn = GetColumn() ' replace this with code to get the relevant column

    Dim oCell As Range
    For Each oCell In oColumn.Cells

        If oCell.Hyperlinks.Count > 0 Then

            Dim oHyperlink As Hyperlink
            Set oHyperlink = oCell.Hyperlinks(1) ' I assume only 1 hyperlink per cell

            Dim strResult As String
            strResult = GetResult(oHyperlink.Address)

            oCell.Offset(0, 1).Value = strResult

        End If

    Next oCell


End Sub

Private Function GetResult(ByVal strUrl As String) As String

    On Error Goto ErrorHandler

    Dim oHttp As New MSXML2.XMLHTTP30

    oHttp.Open "HEAD", strUrl, False
    oHttp.send

    GetResult = oHttp.Status & " " & oHttp.statusText

    Exit Function

ErrorHandler:
    GetResult = "Error: " & Err.Description

End Function

Private Function GetColumn() As Range
    Set GetColumn = ActiveWorkbook.Worksheets(1).Range("A:A")
End Function

Answer 2

Gary's code is perfect, but I would rather use a public function in a module and use it in a cell as function. The advantage is that you can use it in a cell of your choice or anyother more complex function.

In the code below I have adjusted Gary's code to return a boolean and you can then use this output in an =IF(CHECKHYPERLINK(A1);"OK";"FAILED"). Alternatively you could return an Integer and return the status itself (eg.: =IF(CHECKHYPERLINK(A1)=200;"OK";"FAILED"))

A1: http://www.whatever.com
A2: =IF(CHECKHYPERLINK(A1);"OK";"FAILED")

To use this code please follow Gary's instructions and additionally add a module to the workbook (right click on the VBAProject --> Insert --> Module) and paste the code into the module.

Option Explicit

Public Function CheckHyperlink(ByVal strUrl As String) As Boolean

    Dim oHttp As New MSXML2.XMLHTTP30

    On Error GoTo ErrorHandler
    oHttp.Open "HEAD", strUrl, False
    oHttp.send

    If Not oHttp.Status = 200 Then CheckHyperlink = False Else CheckHyperlink = True

    Exit Function

ErrorHandler:
    CheckHyperlink = False
End Function

Please also be aware that, if the page is down, the timeout can be long.