url 检查器 VBA，重定向时显示重定向的 url

Question

我对 EXCEL VBA 很陌生，我有点困于寻找一种创建宏的方法来显示 url 是否仍然有效（200 ok），或者可能被重定向，如果是这样，我想知道什么 URL 。当它根本不起作用时，则返回正确的代码以及 URL 不起作用的原因。

因此，目前我有一个实际有效的脚本，但它不会返回 url 重定向到的 url。仅当 url 仍处于活动状态或原始 url 已重定向到的 url 仍处于活动状态时，它才会返回 (200 OK)。这样我就知道哪些 URL 无效或被重定向到无效 URL。

但我想更进一步。由于我现在要检查的 URL 在“A”列中，而结果在“B”列中返回，因此每次我都想在 C 列中看到我被重定向到的 URL URL 已重定向。

我确实在网上找到了一些可以完成这项工作的函数，但由于某种原因我无法将它们放入我的 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 对象。这将使您“禁用”重定向处理。阅读此论坛帖子。您需要引用的组件是Microsoft WinHTTP Services。

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