Convert code from IE to XMLHTTP

[Sharid]

I have traditionally used IE for pulling data of the web, this is my code. I now want to change it to XMLHTTP as it tends to be faster, can some please help me make a few changes as I have made a few attempts but nothing works as i'm not 100% sure what I am doing. The code below works but is slow as it uses IE

Private Sub CommandButton1_Click()
Dim wb As Workbook
Dim wsSheet As Worksheet, links As Variant, IE As Object, link As Variant
Dim rw As Long
Dim dd As Variant

''''SHEET1 as sheet with URL
    Set wb = ThisWorkbook
    Set wsSheet = wb.Sheets("Sheet1")
    
''''Set IE = InternetExplorer
    Set IE = CreateObject("InternetExplorer.Application")
'''' Source sheet, URLS are in Sheet1 column A row2    
    rw = wsSheet.Cells(wsSheet.Rows.Count, "A").End(xlUp).Row
    links = wsSheet.Range("A2:A" & rw)
    
    With IE
       .Visible = False
       
    For Each link In links
        .navigate (link)
    While .Busy Or .readyState <> 4: DoEvents: Wend
On Error Resume Next
    Set doc = IE.document
    
''''IF Statement, change class to suite needs ' Place DATA IN SHEET1 COLUMN B
    If doc.getElementsByClassName("mbg")(0) Is Nothing Then
           Sheet1.Cells(Sheet1.Cells(Sheet1.Rows.Count, "B").End(xlUp).Row + 1, "B").Value = "-"
    Else
        dd = doc.getElementsByClassName("mbg")(0).Children(0).href
           Sheet1.Cells(Sheet1.Cells(Sheet1.Rows.Count, "B").End(xlUp).Row + 1, "B").Value = dd
    End If
''''navigate links
      Next link     
''''Close IE Browser
    .Quit
End With
    Set IE = Nothing
End Sub

As always thanks in advance

 

[Sharid]

Dan

Come to think of it I resolved the dead Url by using On Error Resume Next

If email_list Is Nothing Then
'On Error Resume Next
wsSheet.Cells(Sheet1.Cells(Sheet1.Rows.Count, "c").End(xlUp).Row + 1, "c").Value = "-"
Else
On Error Resume Next
wsSheet.Cells(Sheet1.Cells(Sheet1.Rows.Count, "c").End(xlUp).Row + 1, "c").Value = email_list(0)
End If
End With

The problem is URLS with outdated security certificates that need confirming and the error message. Possibly need a stop button

When the code crashes

then

 

[Dan_W]

On Error Resume Next will probably work, but it's only masking the problem. Can you give me an example URL to test a few things on? I can't reproduce your problem.

 

[Sharid]

Dan

I will send the file soon

 

[Dan_W]

For the security certificate issue, the problem is that this is an error message arising outside of Excel so it is not something that is readily controllable (without using Hocus Pocus). Can you please try replacing the NewHTMLDocument function with the following code and trying again:

Public Function NewHTMLDocument(strURL As String) As Object
    Dim objHTTP As Object, objHTML As Object, strTemp As String
    Set objHTTP = CreateObject("MSXML2.ServerXMLHTTP")
    objHTTP.setOption(2) = 13056
    objHTTP.Open "GET", strURL, False
    objHTTP.send
    If objHTTP.Status = 200 Then
        strTemp = objHTTP.responseText
    Set objHTML = CreateObject("htmlfile")
    objHTML.body.innerHTML = strTemp
    Set NewHTMLDocument = objHTML
Else
   'There has been an error
End If
End Function

 

[Dan_W]

Hi Sharid, can you please just confirm whether or not this code assisted with your issue? It would be useful for other you encounter the same problem. Thank you! Hope it's going well.

 

[Sharid]

Hi Sharid, can you please just confirm whether or not this code assisted with your issue? It would be useful for other you encounter the same problem. Thank you! Hope it's going well.

It works fine

 

[Dan_W]

Excellent. Thank you.