VBA来检查URL的状态

我已经创build了macros，我可以从任何网页获取每个url。

现在，我在列中有每个URL。

任何人都可以帮忙写macros来检查这个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 

此代码是从网页获取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 

但是，这个代码不起作用，请给我build议的变化。

问候，Mayur Alaspure

Answer 1

既然你有兴趣知道链接是否工作，xmlhttp可能是一个解决scheme。

 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