批量 URL 检查器宏 excel [英] Bulk Url checker macro excel
问题描述
我正在寻求帮助,因为我有大量链接来检查链接是否损坏我已经尝试了以下宏,但它工作了两次,之后它不再工作我正在使用 ms office 10 64bit 我想如果宏添加宏可以检查图像分辨率,例如,如果我在 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屋!