vba 检查 Excel 中损坏的超链接
声明：本页面是StackOverFlow热门问题的中英对照翻译，遵循CC BY-SA 4.0协议，如果您需要使用它，必须同样遵循CC BY-SA许可，注明原文地址和作者信息，同时你必须将它归于原作者（不是我）：StackOverFlow
原文地址: http://stackoverflow.com/questions/22256522/
Warning: these are provided under cc-by-sa 4.0 license. You are free to use/share it, But you must attribute it to the original authors (not me):
StackOverFlow
Checking for broken hyperlinks in Excel
提问by user3393685
I have a large list of hyperlinks (plus a few cells of nonsense) that I need to check. I need to know which links are still active and which no longer exist or return a 404 (or other) Error. I have been using the advice in this entry: Sort dead hyperlinks in Excel with VBA?and it worked great in a small selection of links, some of which I deliberately broke myself. However, now that I try to use the same macro on my actual list of hyperlinks it won't work at all! I've manually checked a few and have found links with 404 errors. Again, when I deliberately mistype one of the addresses it will pick that up but it won't pick up any in the list that were broken already.
我有一大堆超链接（加上一些无意义的单元格）需要检查。我需要知道哪些链接仍然有效，哪些不再存在或返回 404（或其他）错误。我一直在使用此条目中的建议：使用 VBA 对 Excel 中的死超链接进行排序？它在一小部分链接中效果很好，其中一些是我故意破坏的。但是，现在我尝试在我的实际超链接列表上使用相同的宏，它根本不起作用！我已经手动检查了一些，发现有 404 错误的链接。同样，当我故意错误输入其中一个地址时，它会选择该地址，但不会选择列表中已损坏的任何地址。
I'm totally new to macros and am really stumbling about in the dark here. Any help/advice would be very much appreciated!
我对宏完全陌生，我真的在这里摸黑摸索。任何帮助/建议将不胜感激！
回答by tbur
I've been using this for a while and it has been working for me.
我已经使用了一段时间，它一直在对我来说有效。
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
回答by PlanetPie
Specify an actual address in place of alinkor define alinkas a variable which contains a web address.
指定实际地址代替链接或将链接定义为包含网址的变量。
回答by SomeGuy
variable definitions missing, URL to working code below
缺少变量定义，下面是工作代码的 URL
Dim alink As Hyperlink
Dim strURL As String
Dim objhttp As Object
回答by Jason Coigny
I have been using the suggested code above. I had to adapt it further so that it can differentiate between a URL and a File as I have both in my excel spreadsheet. It works well for my particular spreadsheet with about 50 links to files and URLs.
我一直在使用上面建议的代码。我不得不进一步调整它，以便它可以区分 URL 和文件，因为我的 Excel 电子表格中都有。它适用于我的特定电子表格，其中包含大约 50 个指向文件和 URL 的链接。
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
Dim count As Integer
On Error Resume Next
count = 0 'used to track the number of non-working links
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 'if url does exist
alink.Parent.Interior.ColorIndex = 0 'clear cell color formatting
ElseIf objhttp.statustext <> "OK" Then 'if url doesn't exist
If Dir(strURL) = "" Then 'check if the file exists
alink.Parent.Interior.Color = 255 'set cell background to red its not a valid file or URL
count = count + 1 'update the count of bad cell links
Else
alink.Parent.Interior.ColorIndex = 0 'clear cell color formatting
End If
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 & count & " Cell(s) With Broken or Suspect Links. Errors are Highlighted in RED.")
End Sub
I hope this helps someone else as much as it has helped me... A little better everyday!
我希望这对其他人的帮助和对我的帮助一样多......每天都好一点！
