URLのステータスを確認するVBA

Question

私はいずれかのWebページから各URLを取得できるマクロを作成しました。

ここでは、各URLが列にあります。

このURLが動作しているかどうかを確認するために、マクロを書くのに助けてください。 このURLのいずれかが動作していない場合は、次の列のURLの隣で作業しないでください。以下は

私はしかし、これが動作していないようだ書いたコードです：

Sub CommandButton1_Click() 
Dim ie As Object 
Dim html As Object 
Dim j As Integer 
j = 1 
Set ie = CreateObject("InternetExplorer.Application") 
ie.Visible = True 
url = "www.mini.co.uk" 
ie.navigate url 
Do While ie.READYSTATE <> READYSTATE_COMPLETE 
Application.StatusBar = "Trying to go to website ..." 
Loop 
Application.StatusBar = " " 
Set html = ie.document 
'Dim htmltext As Collection 
Dim htmlElements As Object 
Dim htmlElement As Object 
Set htmlElements = html.getElementsByTagName("*") 
For Each htmlElement In htmlElements 
    'If htmlElement.getAttribute("href") <> "" Then Debug.Print htmlElement.getAttribute("href") 
    If htmlElement.getAttribute("href") <> "" Then Cells(j, 1).Value = htmlElement.getAttribute("href") 
    j = j + 1 
Next 

    ActiveSheet.Range("$A$1:$A$2752").removeDuplicates Columns:=1, Header:=xlNo 

End Sub 

このコードはWebページからURLを取得することです。

以下のコードの下では、URLの状態を確認するために、そのURLが動作しているかどうかを確認しようとしています。

Sub CommandButton2_Click() 
Dim k As Integer 
Dim j As Integer 
k = 1 
j = 1 
'Dim Value As Object 
'Dim urls As Object 
'urls.Value = Cells(j, 1) 
For Each url In Cells(j, 1) 
Dim ie As Object 
Set ie = CreateObject("InternetExplorer.Application") 
ie.Visible = False 
url = Cells(j, 1) 
ie.navigate url 
Do While ie.READYSTATE <> READYSTATE_COMPLETE 
Application.StatusBar = "checking the Data. Please wait..." 
Loop 
Cells(k, 2).Value = "OK" 
'Set html = ie.document 
ie.Quit 
j = j + 1 
k = k + 1 
Next 
End Sub 

ただし、このコードは機能していません。変更を提案してください。

よろしく、 マユールAlaspure

Answer 1

あなたは、リンクが機能しているかどうかを知って興味を持っているので、XMLHTTPは1つの溶液であってもよいです。

Set sh = ThisWorkBook.Sheets("Sheet1") 
Dim column_number: column_number = 2 

'Row starts from 2 
For i=2 To 100 
    strURL = sh.cells(i,column_number) 
    sh.cells(i, column_number+1) = CallHTTPRequest(strURL) 
Next 


Function CallHTTPRequest(strURL) 
    Set objXMLHTTP = CreateObject("MSXML2.XMLHTTP") 
    objXMLHTTP.Open "GET", strURL, False 
    objXMLHTTP.send 
    status = objXMLHTTP.Status 
    'strContent = "" 

    'If objXMLHTTP.Status = 200 Then 
    ' strContent = objXMLHTTP.responseText 
    'Else 
    ' MsgBox "HTTP Request unsuccessfull!", vbCritical, "HTTP REQUEST" 
    ' Exit Function 
    'End If 
    Set objXMLHTTP = Nothing 
    CallHTTPRequest = status 
End Function 

Answer 2

Public Function IsURLGood(url As String) As Boolean 
    Dim request As New WinHttpRequest 

    On Error GoTo IsURLGoodError 
    request.Open "HEAD", url 
    request.Send 
    If request.Status = 200 Then 
     IsURLGood = True 
    Else 
     IsURLGood = False 
    End If 
    Exit Function 

IsURLGoodError: 
    IsURLGood = False 
End Function 

Sub testLink() 

Dim source As Range, req As Object, url$ 



    Set source = Range("A2:B2") 


    source.Columns(2).Clear 


    For i = 1 To source.Rows.Count 

    url = source.Cells(i, 1) 
    If IsURLGood(url) Then 
    source.Cells(i, 2) = "OK" 
    Else 
    source.Cells(i, 2) = "Down" 
    End If 

Next 

    MsgBox "Done" 

End Sub