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

Question

标题说:

我有一个excel Sheet,其中包含一个包含超链接的列.现在我想要一个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-> 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 - >插入 - >模块)并将代码粘贴到模块中.

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

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