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

Question

标题说明了这一点:

我有一个 Excel 工作表，其中有一列充满超链接。现在，我希望 VBA 脚本检查哪些超链接无效或有效，并使用文本 404 Error 或事件文本进入下一列。

希望有人能帮助我，因为我不太擅长 VB。

编辑:

我找到了@http://www.utteraccess.com/forums/printthread.php?Cat=&Board=84&main=1037294&type=thread

一个针对 Word 的解决方案，但问题是我需要这个针对 Excel 的解决方案。有人可以将此转换为 Excel 解决方案吗？

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

首先使用“工具”->“引用”添加对 Microsoft XML V3(或更高版本)的引用。然后粘贴此代码:

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