Convert code from IE to XMLHTTP

Sharid

Well-known Member
Joined
Apr 22, 2007
Messages
1,054
Office Version
  1. 2016
Platform
  1. Windows
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

VBA Code:
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

Well-known Member
Joined
Apr 22, 2007
Messages
1,054
Office Version
  1. 2016
Platform
  1. Windows
Dan

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

VBA Code:
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
1598964527945.png


then

1598964557942.png
 
Last edited:

Excel Facts

Waterfall charts in Excel?
Office 365 customers have access to Waterfall charts since late 2016. They were added to Excel 2019.

Dan_W

Active Member
Joined
Jul 11, 2018
Messages
409
Office Version
  1. 365
Platform
  1. Windows
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

Well-known Member
Joined
Apr 22, 2007
Messages
1,054
Office Version
  1. 2016
Platform
  1. Windows
Dan

I will send the file soon
 

Dan_W

Active Member
Joined
Jul 11, 2018
Messages
409
Office Version
  1. 365
Platform
  1. Windows
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:

VBA Code:
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
 
Solution

Dan_W

Active Member
Joined
Jul 11, 2018
Messages
409
Office Version
  1. 365
Platform
  1. Windows

ADVERTISEMENT

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

Well-known Member
Joined
Apr 22, 2007
Messages
1,054
Office Version
  1. 2016
Platform
  1. Windows
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
 

Watch MrExcel Video

Forum statistics

Threads
1,129,404
Messages
5,636,095
Members
416,898
Latest member
imsorrymen

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top