批量 URL 检查器宏 excel

Question

我正在寻求帮助，因为我有大量链接来检查链接是否损坏我已经尝试了下面的宏，但它工作了两次，之后它不再工作我正在使用 ms office 10 64bit 我想如果宏添加宏 可以检查图像分辨率，例如，如果我在 A 列上粘贴 url，它将突出显示损坏的链接，在 b 列上它将显示图像分辨率

Sub Audit_WorkSheet_For_Broken_Links()

If MsgBox("Is the Active Sheet a Sheet with Hyperlinks You Would Like to Check?", vbOKCancel) = vbCancel Then

    Exit Sub

End If

On Error Resume Next
For Each alink In Cells.Hyperlinks
    strURL = alink.Address

    If Left(strURL, 4) <> "http" Then
        strURL = ThisWorkbook.BuiltinDocumentProperties("Hyperlink Base") & strURL
    End If

    Application.StatusBar = "Testing Link: " & strURL
    Set objhttp = CreateObject("MSXML2.XMLHTTP")
    objhttp.Open "HEAD", strURL, False
    objhttp.Send

    If objhttp.statustext <> "OK" Then

        alink.Parent.Interior.Color = 255
    End If

Next alink
Application.StatusBar = False
On Error GoTo 0
MsgBox ("Checking Complete!" & vbCrLf & vbCrLf & "Cells With Broken or Suspect Links are Highlighted in RED.")

End Sub

Answer 1

编辑：我更改了您的宏以正确声明变量并在宏完成时释放对象；这应该解决任何潜在的内存问题。请尝试此代码并告诉我它是否有效。

Sub Audit_WorkSheet_For_Broken_Links()

If MsgBox("Is the Active Sheet a Sheet with Hyperlinks You Would Like to Check?", vbOKCancel) = vbCancel Then

    Exit Sub

End If

Dim alink As Hyperlink
Dim strURL As String
Dim objhttp As Object

On Error Resume Next
For Each alink In Cells.Hyperlinks
    strURL = alink.Address

    If Left(strURL, 4) <> "http" Then
        strURL = ThisWorkbook.BuiltinDocumentProperties("Hyperlink Base") & strURL
    End If

    Application.StatusBar = "Testing Link: " & strURL
    Set objhttp = CreateObject("MSXML2.XMLHTTP")
    objhttp.Open "HEAD", strURL, False
    objhttp.Send

    If objhttp.statustext <> "OK" Then

        alink.Parent.Interior.Color = 255
    End If

Next alink
Application.StatusBar = False

'Release objects to prevent memory issues
Set alink = Nothing
Set objhttp = Nothing
On Error GoTo 0
MsgBox ("Checking Complete!" & vbCrLf & vbCrLf & "Cells With Broken or Suspect Links are Highlighted in RED.")

End Sub

下面的旧答案

将您的宏（似乎来自here）与在excelforum 上找到的替代方法相结合会产生以下代码。试一试，让我知道它是否适合你。

Sub TestHLinkValidity()
Dim rRng As Range
Dim fsoFSO As Object
Dim strPath As String
Dim cCell As Range

If MsgBox("Is the Active Sheet a Sheet with Hyperlinks You Would Like to Check?", vbOKCancel) = vbCancel Then

    Exit Sub

End If

Set fsoFSO = CreateObject("Scripting.FileSystemObject")
Set rRng = ActiveSheet.UsedRange.Cells
For Each cCell In rRng.Cells
    If cCell.Hyperlinks.Count > 0 Then
        strPath = GetHlinkAddr(cCell)
        If fsoFSO.FileExists(strPath) = False Then cCell.Interior.Color = 65535
   End If
Next cCell
End Sub

Function GetHlinkAddr(rngHlinkCell As Range)
    GetHlinkAddr = rngHlinkCell.Hyperlinks(1).Address
End Function