Bulk Url checker macro excel

Question

Im ищет помощь, поскольку у меня есть масса ссылок, чтобы проверить, не была ли эта ссылка повреждена. Я пробовал макрос ниже, но он работает дважды, а после этого он больше не работает. Я использую ms office 10 64-разрядные я хотел бы добавить на макрос, если макрос может проверить разрешение изображения, например, если я вставить 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 

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