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

 

[Dan_W]

You could try the following function:

Public Function NewHTMLDocument(strURL As String) As Object
    Dim objHTTP As Object, objHTML As Object, strTemp As String
    Set objHTTP = CreateObject("MSXML2.ServerXMLHTTP")
    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

    Set objHTTP = Nothing
    Set objHTML = Nothing
End Function

You will need to make a few changes to your code, though, and you will need to set a reference to "Microsoft HTML Object Library" in the Tools > References part of VBE.

You should remove this part:
IE As Object
and insert this line at the beginning of the subroutine.

Dim doc as HTMLDocument

This line:

Set doc = NewHTMLDocument(cstr(link))

can replace the entirety of this:

    .navigate (link)
    While .Busy Or .readyState <> 4: DoEvents: Wend
    On Error Resume Next
    Set doc = IE.document

Finally, you should remove all references to the IE object:
Set IE = CreateObject("InternetExplorer.Application"), With IE .Visible = False, .Quit and the End With

Hope that helps.

 

[Sharid]

Dan_W

I am getting an error message here

The Error Message

This is how the code looks now

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

''''SHEET1 as sheet with URL
    Set wb = ThisWorkbook
    Set wsSheet = wb.Sheets("Sheet6")
    
    rw = wsSheet.Cells(wsSheet.Rows.Count, "A").End(xlUp).Row
    links = wsSheet.Range("A2:A" & rw)
         
Set doc = NewHTMLDocument(CStr(link))

''''IF Statement, change class to suite needs ' Place DATA IN SHEET1 COLUMN B
    If doc.getElementsByClassName("mbg")(0) Is Nothing Then
           Sheet6.Cells(Sheet6.Cells(Sheet6.Rows.Count, "B").End(xlUp).Row + 1, "B").Value = "-"
    Else
        dd = doc.getElementsByClassName("mbg")(0).Children(0).href
           Sheet6.Cells(Sheet6.Cells(Sheet6.Rows.Count, "B").End(xlUp).Row + 1, "B").Value = dd
    End If

''''navigate links
'      Next link
End Sub


Public Function NewHTMLDocument(strURL As String) As Object
    Dim objHTTP As Object, objHTML As Object, strTemp As String
    Set objHTTP = CreateObject("MSXML2.ServerXMLHTTP")
    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

 

[Sharid]

I had missed this off, so there was no For Each, the Error message is gone, but nothing is being pulled off

For Each link In links
    Set doc = NewHTMLDocument(CStr(link))

 

[Sharid]

Its ok I got this working, the sheet was Sheet7 and NOT Sheet6.

The sheet was Sheet7 but the NAME of the Sheet was Sheet6. This is where I made the mistake as it was asking for the Sheet name and which sheet to paste the data into. I reffered to BOTH as Sheet6 which was wrong.

I have renamed the Sheet to "test" and the Sheet is Sheet7

See code below' ONLY FIRST HALF OF THE CODE,

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

''''SHEET7 has sheet with URL and is called "test"
    Set wb = ThisWorkbook
    Set wsSheet = wb.Sheets("test")
   
    rw = wsSheet.Cells(wsSheet.Rows.Count, "A").End(xlUp).Row
    links = wsSheet.Range("A2:A" & rw)
        
For Each link In links
    Set doc = NewHTMLDocument(CStr(link))

''''IF Statement, change class to suite needs ' Place DATA IN Sheet7 COLUMN B
    If doc.getElementsByClassName("mbg")(0) Is Nothing Then
           Sheet7.Cells(Sheet7.Cells(Sheet7.Rows.Count, "B").End(xlUp).Row + 1, "B").Value = "-"
    Else
        dd = doc.getElementsByClassName("mbg")(0).Children(0).href
           Sheet7.Cells(Sheet7.Cells(Sheet7.Rows.Count, "B").End(xlUp).Row + 1, "B").Value = dd
    End If
''''navigate links
     Next link
End Sub

It all works now,

Thanks Dan_w

 

[Dan_W]

Glad you managed to get your code to work.

 

[Sharid]

I thought this was working, but have noticed a issue and I need a slight update on this code. The issue is shown in the image below. I have colour coded some of the url to make it easier.

1. In the image I have 9 URLS in column A from row 2 to 10
2. The code is run and at row 6 the code is interrupted, So far the results have gone in FINE as show in RED.
3. NOW the code is RESTARTED by click the command button.

Problem/Issue

1. The code goes back to the FIRST url in Column A Row 2 and has placed its result in Column B Row 7. This is WRONG as shown in Black

What Should Happen
The code should RESTART at row 7 and place the result for that url in B7

As you can see I started off with 9 urls but have ended up with 14 results. Five in red before the code was interrupted and 9 when it re-started and it went to the FIRST urls.

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

''''SHEET1 as sheet with URL
    Set wb = ThisWorkbook
    Set wsSheet = wb.Sheets("test")
   
    rw = wsSheet.Cells(wsSheet.Rows.Count, "A").End(xlUp).Row
    links = wsSheet.Range("A2:A" & rw)
For Each link In links
    Set doc = NewHTMLDocument(CStr(link))

''''IF Statement, change class to suite needs ' Place DATA IN Sheet7 COLUMN B
    If doc.getElementsByClassName("mbg")(0) Is Nothing Then
           Sheet7.Cells(Sheet7.Cells(Sheet7.Rows.Count, "B").End(xlUp).Row + 1, "B").Value = "-"
    Else
        dd = doc.getElementsByClassName("mbg")(0).Children(0).href
           Sheet7.Cells(Sheet7.Cells(Sheet7.Rows.Count, "B").End(xlUp).Row + 1, "B").Value = dd
    End If

''''navigate links
     Next link
End Sub


Public Function NewHTMLDocument(strURL As String) As Object
    Dim objHTTP As Object, objHTML As Object, strTemp As String
    Set objHTTP = CreateObject("MSXML2.ServerXMLHTTP")
    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

 

[Sharid]

I need some thing like this, its one of my old threads, looks like I have had this problem in the past but can not work it out on how to adapt it for this code.
My Old Post

 

[Dan_W]

Sorry, I've been playing catch-up all day. Looking at it now.

 

[Dan_W]

Hi. Apologies again for not getting back to you earlier. The solution below is inelegant, but it should work (and I tidied up a sloppy piece of coding in my last bit of code from the other day). As before, there are other things I would change about this but oh well (I assume, for example that Sheet7 = wsSheet?).

Replace this:

    'PART 1
   Dim rw As Long
    
    'PART 2
    rw = wsSheet.Cells(wsSheet.Rows.Count, "A").End(xlUp).Row
    links = wsSheet.Range("A2:A" & rw)

With this:

    'PART 1
    Dim StartRow as Long
    Dim EndRow as Long

    'PART 2
    StartRow = wsSheet.Cells(wsSheet.Rows.Count, "B").End(xlUp).Row + 1
    EndRow = wsSheet.Cells(wsSheet.Rows.Count, "A").End(xlUp).Row
    links = WorksheetFunction.Transpose(wsSheet.Range("A" & StartRow & ":A" & EndRow))

So that it ultimately looks like this:

Private Sub CommandButton1_Click()
Dim wb As Workbook
Dim wsSheet As Worksheet, links As Variant, link As Variant
Dim StartRow as Long
Dim EndRow as Long
Dim dd As Variant
Dim doc As HTMLDocument

''''SHEET1 as sheet with URL
    Set wb = ThisWorkbook
    Set wsSheet = wb.Sheets("test")
   
    StartRow = wsSheet.Cells(wsSheet.Rows.Count, "B").End(xlUp).Row + 1
    EndRow = wsSheet.Cells(wsSheet.Rows.Count, "A").End(xlUp).Row
    links = WorksheetFunction.Transpose(wsSheet.Range("A" & startrow & ":A" & EndRow))

For Each link In links
    Set doc = NewHTMLDocument(CStr(link))

''''IF Statement, change class to suite needs ' Place DATA IN Sheet7 COLUMN B
    If doc.getElementsByClassName("mbg")(0) Is Nothing Then
           Sheet7.Cells(Sheet7.Cells(Sheet7.Rows.Count, "B").End(xlUp).Row + 1, "B").Value = "-"
    Else
        dd = doc.getElementsByClassName("mbg")(0).Children(0).href
           Sheet7.Cells(Sheet7.Cells(Sheet7.Rows.Count, "B").End(xlUp).Row + 1, "B").Value = dd
    End If

''''navigate links
     Next link
End Sub


Public Function NewHTMLDocument(strURL As String) As Object
    Dim objHTTP As Object, objHTML As Object, strTemp As String
    Set objHTTP = CreateObject("MSXML2.ServerXMLHTTP")
    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