url checker VBA在重定向时显示重定向的url

Question

我对EXCEL VBA很陌生，而且我找不到创建MACRO的方法来显示网址是否仍处于活动状态（200 ok）， 或者可能被重定向，如果是，我想知道什么URL。如果它根本不起作用，那么返回正确的代码，原因是URL不起作用。

所以目前我有一个实际可行的脚本，但它没有返回重定向到url的url。 它仅在网址仍处于活动状态时返回（200 OK），或者原始网址已重定向到的网址仍处于活动状态。所以我知道哪些URL已经死亡或被重定向到死URL。

但我想更进一步。 由于我要检查的网址位于＆＃34; A＆＃34;目前列，结果返回＆＃34; B＆＃34;我希望每当有重定向的网址时，都希望看到我在C列中重定向的网址。

我确实在网上找到了一些可以完成这项工作的功能，但出于某种原因，我无法在他的SUB中使用它们。就像我之前提到的那样，这对我来说都很新鲜。

这就是我现在所拥有的：

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.ServerXMLHTTP30

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

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

    Exit Function

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

End Function

我希望你们中的一个可以帮助我。

Answer 1

最好使用WinHttp COM对象。这将让你＆＃34;禁用＆＃34;重定向处理。 Read this forum post。 您需要引用的组件是 Microsoft WinHTTP服务。

Public Function GetResult(ByVal strUrl As String, Optional ByRef isRedirect As Boolean, Optional ByRef target As String) As String
    Dim oHttp As New WinHttp.WinHttpRequest

    oHttp.Option(WinHttpRequestOption_EnableRedirects) = False
    oHttp.Open "HEAD", strUrl, False
    oHttp.send
    GetResult = oHttp.Status & " " & oHttp.statusText
    If oHttp.Status = 301 Or oHttp.Status = 302 Then
        isRedirect = True
        target = oHttp.getResponseHeader("Location")
    Else
        isRedirect = False
        target = Nothing
    End If
End Function