M
Marvin
Hello all,
I'm trying to run the following macro but I get an error as given in
the subject line. Please help me to fix the error.
I'm trying to check if the hyperlinks in several cells of a column are
working or dead. Given below is not my code but I found it in the
internet and it suited what I'm trying to do.
Thanks,
Marvin.
Option Explicit
Sub CheckHyperlinks()
Dim oColumn As Range
Set oColumn = GetColumn() ' replace this with code to get the
relevant column
Dim oCell As Range
For Each oCell In oColumn.Cells
If oCell.Hyperlinks.Count > 0 Then
Dim oHyperlink As Hyperlink
Set oHyperlink = oCell.Hyperlinks(1) ' I assume only 1
hyperlink per cell
Dim strResult As String
strResult = GetResult(oHyperlink.Address)
oCell.Offset(0, 1).Value = strResult
End If
If Trim(oCell.Value) <> "" Then
oCell.Offset(0, 1).Value = GetResult(oCell.Value)
End If
Next oCell
End Sub
Private Function GetResult(ByVal strUrl As String) As String
On Error GoTo ErrorHandler
Dim oHttp As New MSXML2.XMLHTTP30
oHttp.Open "HEAD", strUrl, False
oHttp.send
GetResult = oHttp.Status & " " & oHttp.statusText
Exit Function
ErrorHandler:
GetResult = "Error: " & Err.Description
End Function
Private Function GetColumn() As Range
Set GetColumn = ActiveWorkbook.Worksheets(1).Range("A:A")
End Function
Private Sub CommandButton1_Click()
Call CheckHyperlinks
End Sub
I'm trying to run the following macro but I get an error as given in
the subject line. Please help me to fix the error.
I'm trying to check if the hyperlinks in several cells of a column are
working or dead. Given below is not my code but I found it in the
internet and it suited what I'm trying to do.
Thanks,
Marvin.
Option Explicit
Sub CheckHyperlinks()
Dim oColumn As Range
Set oColumn = GetColumn() ' replace this with code to get the
relevant column
Dim oCell As Range
For Each oCell In oColumn.Cells
If oCell.Hyperlinks.Count > 0 Then
Dim oHyperlink As Hyperlink
Set oHyperlink = oCell.Hyperlinks(1) ' I assume only 1
hyperlink per cell
Dim strResult As String
strResult = GetResult(oHyperlink.Address)
oCell.Offset(0, 1).Value = strResult
End If
If Trim(oCell.Value) <> "" Then
oCell.Offset(0, 1).Value = GetResult(oCell.Value)
End If
Next oCell
End Sub
Private Function GetResult(ByVal strUrl As String) As String
On Error GoTo ErrorHandler
Dim oHttp As New MSXML2.XMLHTTP30
oHttp.Open "HEAD", strUrl, False
oHttp.send
GetResult = oHttp.Status & " " & oHttp.statusText
Exit Function
ErrorHandler:
GetResult = "Error: " & Err.Description
End Function
Private Function GetColumn() As Range
Set GetColumn = ActiveWorkbook.Worksheets(1).Range("A:A")
End Function
Private Sub CommandButton1_Click()
Call CheckHyperlinks
End Sub