批量URL检查器宏excel [英] Bulk Url checker macro excel

问题描述

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

Im seeking for help as i have a bulk of links to check if the link is broken i have tried the below macro but it works twice and after that it is no longer working i am using ms office 10 64bit i would like to add on the macro if macro can check the image resolution for example if i paste url on column A it will highlight the broken links and on column b it will show the image resolution

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

推荐答案

修改在宏完成后正确声明变量并释放对象;这应该解决任何潜在的记忆问题。请尝试此代码，让我知道如果它有效。

Edit: I changed your macro to declare variables properly and release objects upon macro completion; this should address any potential memory issues. Please try this code and let me know if it works.

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

以下答案

组合您的宏（似乎来自这里），在 excelforum 得到以下代码。尝试一下，让我知道如果它适用于你。

Combining your macro (which seems to be from here) with an alternative found on excelforum yields the below code. Give it a try and let me know if it works for you.

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

这篇关于批量URL检查器宏excel的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！