Question

我创建了宏，我可以从任何网页中获取每个网址。

现在，我在列中有每个网址。

任何人都可以帮助编写宏来检查这个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的状态是否有效。

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

但是这段代码不起作用，请告诉我更改。

此致 Mayur Alaspure

Answer 1

由于您有兴趣知道链接是否正常工作，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

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

Answer 3

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

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 4

Sub URLWorkingorNot（）

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

我尽可能地昏昏欲睡

AddReference i = 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

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

VBA检查URL的状态

4 个答案: