Multi-session / asynchronous web request with VBA and XMLHttpRequest object – Part 2

Standard

In PART 1, we talked about how to download files from the internet using XMLHTTP object. In this chapter, we will talk about how to achieve asynchronous and multi-session file download.

First we need to create a class called Httphelper:

Option Explicit
Private m_exportpath As String
Private m_httprequest As MSXML2.XMLHTTP60

Sub request(ByVal url As String, ByVal exportpath As String)
m_exportpath = exportpath
Set m_httprequest = New MSXML2.XMLHTTP60
m_httprequest.OnReadyStateChange = Me
m_httprequest.Open "GET", url, True
m_httprequest.send ""

End Sub

Sub OnReadyStateChange()

   If m_httprequest.readyState = 4 Then
      If m_httprequest.Status = 200 Then
         save_binary m_httprequest.responseBody
     End If
   End If

End Sub

Sub save_binary(ByRef b() As Byte)

Open m_exportpath For Binary As #1
  Put #1, , b
Close #1

End Sub

After creating the class, you have to export the class to text .cls file and edit the .cls file in text editor:

Screen Shot 2016-10-09 at 4.20.10 PM.png

Add the following code:

Attribute OnReadyStateChange.VB_UserMemId = 0

under

Sub OnReadyStateChange()

Screen Shot 2016-10-09 at 4.23.19 PM.png

Next, you need to import the .cls file into your VBA project, and finally we can use the class like this:

Sub main()
Set http_collection = New Collection
Dim http As Httphelper
For i = 1 To 9
    Set http = new_http
    http.request "http://ichart.finance.yahoo.com/table.csv?s=000" & i & ".hk", "C:\TEMP\" & i & ".csv"
Next i
End Sub

Function new_http() As Httphelper
    Set new_http = New Httphelper
End Function

Handling Object with collection

Standard

Sometimes, it is tricky to handle when you have to instance multiple objects during run time. However, you can apply this simple trick to automatically add custom objects to a collection.

Add these code into your module:

Option Explicit

Public obj_id As Integer
Public obj_col As collection

Sub test()

Dim c As Class1
Dim i As Integer
Dim obj As Object
Set obj_col = New collection
obj_id = 0

For i = 1 To 50
    Set c = New Class1
Next

For Each obj In obj_col
    obj.sayhi
Next

'release resources
Set obj_col = Nothing
End Sub

Add a new class module called “class1”. Within class1, add these code:

Private id As Integer

Private Sub Class_Initialize()
obj_id = obj_id + 1
id = obj_id
obj_col.Add Me, CStr(id)
End Sub

Public Sub sayhi()
Debug.Print "id:" & id
End Sub

Now try to run sub test().

Multi-session / asynchronous web request with VBA and XMLHttpRequest object – Part 1

Standard

In Excel development, very often we need to import data from an online source, sometimes we will need to import from hundreds or thousands of online source. Good news is that with XMLHttpRequest object, you can achieve multi-session asynchronous Http call on VBA. Let see how it works:

1.  Open VBA Editor -> Select “Tools” -> Select “References”.

Screen Shot 2016-09-27 at 8.16.07 PM.png

2. Add a reference to Microsolt XML 6.0.

Screen Shot 2016-09-27 at 8.19.23 PM.png

3. We can start to code.

Option Explicit

Sub main()
Dim httprequest As New MSXML2.XMLHTTP60
httprequest.Open "GET", "https://finance.yahoo.com/", False
httprequest.send
Debug.Print httprequest.responseText

End Sub

Let’s take a look what we can get from this four lines of codes!

Screen Shot 2016-09-27 at 8.32.58 PM.png

httprequest.responseText retrieves the response body as a string, in this case, the html code of the front page of https://finance.yahoo.com/. So what if we want to get some stock data from yahoo finance api? Easy! We can simply change  “https://finance.yahoo.com/” to “http://ichart.finance.yahoo.com/table.csv?s=0001.hk” then we are good to go.

Screen Shot 2016-09-27 at 8.38.08 PM.png

At this point, we can further develop to save the http respond to csv file. According to description, XMLHttpRequest.respondbody return unassigned byte, we can leverage Saving Data in binary format to save any file download from XMLHttprequest.

Option Explicit

Sub main()

Dim httprequest As New MSXML2.XMLHTTP60

Dim b() As Byte

Dim filename As String

httprequest.Open "GET", "http://ichart.finance.yahoo.com/table.csv?s=0001.hk", False

httprequest.send

b = httprequest.responseBody

filename = "C:\TEMP\stock.csv"

Debug.Print httprequest.responseBody

Open filename For Binary As #1

  Put #1, , b

Close #1

End Sub

Useful VBA FunctionI cannot live without

Standard

Here are 3 VBA functions that I always have in the VBA projects I built.

 

  • Count occurrence of substring in string

This function allows you to count the occurrence of substring in string, various type of data can be passed to the function and case-sensitivity can be adjusted.

Function countstr(ByVal keyword As Variant, ByVal text As Variant, Optional ByVal case_sensitive = True) As Integer
  keyword = CStr(keyword): text = CStr(text)
  countstr = (Len(text) - Len(Replace(text, keyword, vbNullString, , , IIf(case_sensitive, vbBinaryCompare, vbTextCompare)))) / Len(keyword)
End Function

examples:
countstr("a","aaa") 'return 3
countstr("a","AAA") 'return 0
countstr("a","AAA", False) 'return 3
countstr(1, 123) 'return 1
countstr("1",123) ' rrtuen 1
  • Find last used row of a column/sheet
Function lastrow(ws As Worksheet, Optional ByVal column As Variant = "") As Integer
With ws
    If column = "" Then
        lastrow = .UsedRange.Rows(.UsedRange.Rows.Count).Row
    Else
        lastrow = .Cells(.Rows.Count, column).End(xlUp).Row
    End If
End With
End Function

examples:
'Assume Sheets(1) is empty
Sheets(1).Cells(3, 3) = 1
Sheets(1).Cells(2, 2) = 1

Debug.Print lastrow(Sheets(1), 3) 'return 3
Debug.Print lastrow(Sheets(1), "B") 'return 2
Debug.Print lastrow(Sheets(1), "A") 'return 1
Debug.Print lastrow(Sheets(1))  'return 3

  • Check if worksheet exists in a workbook
Function ws_exist(sheet_name As String, Optional ByRef wb As Workbook) As Boolean
On Error Resume Next
If wb Is Nothing Then Set wb = ThisWorkbook
ws_exist = (UCase(wb.Sheets(sheet_name).Name) = UCase(sheet_name))
End Function

examples:
'Assume only Sheet1 exists in ThisWorkBook
ws_exist("Sheet1") 'return True
ws_exist("SHEET1") 'return True
ws_exist("Sheet2") 'return False

'You may also check if worksheet exists in other workbooks if you have created a reference

ws_exist("Sheet1",wb)

Saving Data in binary format

Standard

In VBA, you can save/read data as/from binary file. This is particularly useful when you want to backup any intermedia data generated during your procedure runtime, or if you need to save configuration outside the excel workbook but you want to take care of reading the configuration files.

Function savedata(ByVal filefullName As String, ByRef data As Variant)

Open filefullName For Binary Lock Read Write As #1
  Put #1, , data
Close #1

End Function

Function saveconfig(ByVal filefullName As String, ByRef data As my_config) 

Open filefullName For Binary Lock Read Write As #1
  Put #1, , data
Close #1 

End Function
Function getdata(ByVal filefullName As String, ByRef data As Variant)

Open filefullName For Binary Lock Read As #1
  Get #1, , data
Close #1

End Function

Function getconfig(ByVal filefullName As String, ByRef data As my_config) 

Open filefullName For Binary Lock Read As 1
  Get #1, , data
Close #1 

End Function

The above four function will save and load data for you(savedata() and getdata() are for Variant type data, saveconfig() and getconfig() are for User_Defined_Type), let’s see how we can use them:

Copy the above two function together with the following code into your VBA module:

Type my_config
db_path As String
password As String
back_up_path As String
some_other_config As Integer
End Type

Sub test_save_and_load()
Dim str_var As String: str_var = "Hello!"
Dim int_var As Integer: int_var = 169
Dim bol_var As Boolean: bol_var = True
Dim arr_var As Variant
Dim test As Variant
Dim config As my_config
Dim new_config As my_config
Dim cell As Object
Dim i As Integer

'create a large array
i = 0
For Each cell In ThisWorkbook.Sheets(1).Range("A1:H50").Cells
cell = i
i = i + 1
Next

arr_var = ThisWorkbook.Sheets(1).Range("A1:H50")
Debug.Print arr_var(1, 7)
config.back_up_path = "D:\Backup"
config.db_path = "D:\DB"
config.password = "a12356"
config.some_other_config = "7"

'save data to binaryfile
savedata "C:\TEMP\str.anyextension", str_var
savedata "C:\TEMP\int.anyextension", int_var
savedata "C:\TEMP\bol.anyextension", bol_var
savedata "C:\TEMP\arr.anyextension", arr_var
saveconfig "C:\TEMP\config.anyextension", config

'get data from binaryfile
getdata "C:\TEMP\str.anyextension", test
Debug.Print test
getdata "C:\TEMP\int.anyextension", test
Debug.Print test
getdata "C:\TEMP\bol.anyextension", test
Debug.Print test
getdata "C:\TEMP\arr.anyextension", test
Debug.Print test(1, 7)
getconfig "C:\TEMP\config.anyextension", new_config
Debug.Print new_config.password

End Sub

Basically, the above procedure is trying to save data(string, integer, boolean, array) and a user_defined_type into binary.Screen Shot 2016-09-25 at 9.51.18 PM.png