Question

标题说：

我有一张带有超链接列的Excel工作表。现在我想要一个VBA脚本检查哪些超链接已经死亡或工作，并使用404错误或活动文本进入下一列。

希望有人可以帮助我，因为我并不擅长VB。

编辑：

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

一个单词解决方案，但问题是我需要这个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

首先使用Tools-＆gt; References添加对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

Answer 2

Gary的代码是完美的，但我宁愿在模块中使用公共函数，并将其作为函数在单元格中使用。优点是您可以在您选择的单元格或任何其他更复杂的功能中使用它。

在下面的代码中，我调整了Gary的代码以返回布尔值，然后您可以在= IF中使用此输出（CHECKHYPERLINK（A1）;“OK”;“FAILED”）。或者你可以返回一个Integer并返回状态本身（例如：= IF（CHECKHYPERLINK（A1）= 200;“OK”;“FAILED”））

A1：http://www.whatever.com
A2：= IF（CHECKHYPERLINK（A1）;“OK”;“FAILED”）

要使用此代码，请遵循Gary的说明并另外向工作簿添加一个模块（右键单击VBAProject - ＆gt;插入 - ＆gt;模块）并将代码粘贴到模块中。


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

另请注意，如果页面关闭，则超时可能很长。

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

2 个答案: