How to load information from the internet using the XMLHTTP Object – VBA Macro

Sometimes you want to retrieve information from the internet for use in an Office Application like Excel. For example, you might want to fetch the latest currency rates or the latest news topics from a website.

One way to do that is by using the XMLHTTP object. Generally this is considered to be faster than using the Internet Explorer Document Object Model (IE DOM) because, among other reasons, the latter requires an Internet Explorer instance.

Another advantage of the XMLHTTP object is that this object has equivalent implementations in other browsers such as Mozilla, Safari, Konquerer, Icebrowser and Opera, meaning written code around this object can be easily ported for use with other browsers.

How it works

The XMLHTTP object can be used to send or receive information to and from a webserver. Retrieved information can be parsed with the XML Document Object Model (XML DOM). In this first article about the XMLHTTP object I’ll show you how to use this object to retrieve selected information from a webpage for use in an VBA application.

For client-side communication with HTTP servers we are going to use the MSXML.XMLHTTPRequest object with the Open method. This initiates the actual request to webserver and parses the server response. To capture the return in simple text (HTML is simple text as well) we use the responseText property and assign it to a string variable. We then do some filtering on the string value in Excel to extract the information we need.

Code

Sub GetLatestScriptoriumPosts()
    Dim i As Integer
    Dim sURL As String, sHTML As String, sAllPosts As String
    Dim oHttp As Object
    Dim lTopicstart As Long, lTopicend As Long
    Dim blWSExists As Boolean
 
    'Create a new Worksheet "Latest Scriptorium Posts" if it doesnt'exist already.
    For i = 1 To Worksheets.Count
        If Worksheets(i).Name = "Latest Scriptorium Posts" Then
            blWSExists = True
            Worksheets(i).Activate
        End If
    Next
    If Not blWSExists Then
        Worksheets.Add.Move after:=Worksheets(Worksheets.Count)
        Worksheets(Worksheets.Count).Name = "Latest Scriptorium Posts"
    End If
 
     'URL to open
    sURL = "http://scriptorium.serve-it.nl/environments.php?eid=1"
 
    ' Create an XMLHTTP object and add some error trapping
    On Error Resume Next
    Set oHttp = CreateObject("MSXML2.XMLHTTP")
    If Err.Number <> 0 Then
        Set oHttp = CreateObject("MSXML.XMLHTTPRequest")
        MsgBox "Error 0 has occured while creating a MSXML.XMLHTTPRequest object"
    End If
    On Error GoTo 0
    If oHttp Is Nothing Then
        MsgBox "For some reason I wasn't able to make a MSXML2.XMLHTTP object"
        Exit Sub
    End If
 
    'Open the URL in browser object
    oHttp.Open "GET", sURL, False
    oHttp.Send
    sHTML = oHttp.responseText
 
    'Extract the desired information from the returned HTML code (text)
    'To make things a little easier I usually cut of most of the unwanted code first
    'so sHTML is smaller to work with.
    lTopicstart = InStr(1, sHTML, "Recent additions", vbTextCompare)
    lTopicend = InStr(1, sHTML, "</table>", vbTextCompare)
    sHTML = Mid(sHTML, lTopicstart, lTopicend - lTopicstart)
 
    'Now extract all text within the hyperlinks <a href..>..</a>
    'because they represent the topics
    i = 1
    lTopicstart = 1
    lTopicend = 1
    Do While lTopicstart <> 0
        i = i + 1
        lTopicstart = InStr(lTopicend, sHTML, "<a href=", vbTextCompare)
        If lTopicstart <> 0 Then
            lTopicstart = InStr(lTopicstart, sHTML, ">", vbTextCompare) + 1
            lTopicend = InStr(lTopicstart, sHTML, "</a>", vbTextCompare)
            Worksheets(Worksheets.Count).Range("A2").Offset(i, 0).Value = _
                Mid(sHTML, lTopicstart, lTopicend - lTopicstart)
            sAllPosts = sAllPosts & Chr(13) & Mid(sHTML, lTopicstart, lTopicend - lTopicstart)
        End If
    Loop
 
    'Clean up
    Set oHttp = Nothing
 
    Worksheets(Worksheets.Count).Range("A1").Value = "Latest posts on Scriptorium:"
    MsgBox ("Latest posts on Scriptorium:" & Chr(13) & sAllPosts)
End Sub

Usage

Add the sub routine to a new module and run it to see it work. This code loads the Scriptorium VBA webpage (my old website) and filters out the most recently added scripts titles. It then shows the titles of those in both a message (MsgBox) and in a worksheet with the name “Latest Scriptorium Posts”.

Courtesy: vba & excel