如何查看 URL 的状态？

Question

我创建了一个宏，我可以在其中从任何网页获取每个 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

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

Answer 1

您实际上可以使用 IE 自动化来获取状态代码，但它需要处理事件和对 Microsoft Internet 控件库的引用。

Private Declare PtrSafe Sub SleepEx Lib "Kernel32.dll" (ByVal dwMilliseconds As Long, Optional ByVal bAlertable As Boolean = True)
Private WithEvents ie As SHDocVw.InternetExplorer
Private LastStatusCode As Long

Private Sub ie_NavigateError(ByVal pDisp As Object, URL As Variant, TargetFrameName As Variant, StatusCode As Variant, Cancel As Boolean)
    LastStatusCode = StatusCode
End Sub

Public Sub NavigateReturnStatus(url As String) As Long
    Set ie = CreateObject("InternetExplorer.Application")
    Status = 0
    ie.Navigate url
    Do While IEObject.ReadyState <> READYSTATE_COMPLETE Or IEObject.Busy
         SleepEx 50 'No busy waiting, short wait time
         DoEvents 'Need to receive events from IE application
    Loop
    NavigateReturnStatus = LastStatusCode
End Sub

这不会返回传统的 HTTP 状态代码，而是返回 NavigateError status code。这意味着您可以获得有关错误的更详细信息，但无法获得有关成功导航的信息。当然，如果为0，则表示没有发生错误，所以状态很可能是200。

速度比 WinHTTP/MSXML 方法慢得多，但我主要是在有人已经使用 Internet Explorer 进行导航的情况下分享这个。

当然，可以（并且可能应该）修改代码以重用 Internet Explorer 应用程序。

Answer 2

子 URLWorkingorNot()

'确保选择包含 URL 的单元格

暗淡无光

添加引用 我= 1

    Selection.Replace "#N/A", "NA": Selection.Offset(0, 1).EntireColumn.Insert
    Dim IE As InternetExplorer
        If ActiveWorkbook Is Nothing Then Exit Sub
        For Each cell In Selection
        If cell.Value <> "" Then
            Set IE = New InternetExplorer
                IE.Navigate2 cell.Value
                IE.Left = 900
                IE.Width = 900
                IE.Visible = True
                While IE.Busy: DoEvents: Wend
                On Error Resume Next
                If InStr(1, IE.document.body.innerText, "The webpage cannot be found", vbBinaryCompare) <> 0 Then cell.Offset(0, 1).Value = "Not Available"
                'MsgBox IE.document.body.innerText
                If err.Number <> 0 Then err.Clear: On Error GoTo 0
                IE.Quit: Set IE = Nothing
        End If
            i = i + 1:
            ProgressBar Selection.Count, i, "Working on " & i & " Cell": DoEvents
        If ActiveWorkbook.Path <> "" And Left(i, 3) = "00" Then ActiveWorkbook.Save
        Next cell
        Unload UProgressBar
Application.StatusBar = ""
End Sub

子 AddReference() '从互联网复制

     'Macro purpose:  To add a reference to the project using the GUID for the
     'reference library

    Dim strGUID As String, theRef As Variant, i As Long

     'Update the GUID you need below.
    'strGUID = "{00020905-0000-0000-C000-000000000046}"
     strGUID = "{EAB22AC0-30C1-11CF-A7EB-0000C05BAE0B}"
     'iNTERNET cONTROLS - "{EAB22AC0-30C1-11CF-A7EB-0000C05BAE0B}" MAJOR 1 MINOR 1
     'HTMLOBJECT "{3050F1C5-98B5-11CF-BB82-00AA00BDCE0B}" MAJOR 4 MINOR 0

     'Set to continue in case of error
    On Error Resume Next

     'Remove any missing references
    For i = ThisWorkbook.Vbproject.References.Count To 1 Step -1
        Set theRef = ThisWorkbook.Vbproject.References.Item(i)
        If theRef.isbroken = True Then
            ThisWorkbook.Vbproject.References.Remove theRef
        End If
    Next i

     'Clear any errors so that error trapping for GUID additions can be evaluated
    err.Clear

     'Add the reference
    ThisWorkbook.Vbproject.References.AddFromGuid _
    GUID:=strGUID, Major:=1, Minor:=0
    ThisWorkbook.Vbproject.References.AddFromFile "C:\Windows\System32\UIAutomationCore.dll"
     'If an error was encountered, inform the user
    Select Case err.Number
    Case Is = 32813
         'Reference already in use.  No action necessary
    Case Is = vbNullString
         'Reference added without issue
    Case Else
         'An unknown error was encountered, so alert the user
        MsgBox "A problem was encountered trying to" & vbNewLine _
        & "add or remove a reference in this file" & vbNewLine & "Please check the " _
        & "references in your VBA project!", vbCritical + vbOKOnly, "Error!"
    End Select
    On Error GoTo 0
End Sub

Answer 3

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

Answer 4

由于您有兴趣知道链接是否有效，xmlhttp 可能是一种解决方案。

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