How to VBA catch request timeout error?

Question

I\'m using object MSXML2.ServerXMLHTTP60 send request to webservice; with this object, I can speed up data loading by asynchronous method and avoid lockups Exce

Answer 1

There are several complications here.

1. MSXML2.ServerXMLHTTP does not expose COM-usable events. Therefore it is not easily possible to instantiate an object using WithEvents and attach to its OnReadyStateChange event.
   The event is there, but the standard VBA way to handle it does not work.
2. The module that could handle the event cannot be created using the VBA IDE.
3. You need to call waitForResponse() when you use asynchronous requests (additionally to calling setTimeouts()!)
4. There is no timeout event. Timeouts are thrown as an error.

To resolve issue #1:

Usually a VBA class module (also applies to user forms or worksheet modules) allows you to do this:

Private WithEvents m_xhr As MSXML2.ServerXMLHTTP

so you can define an event handler like this:

Private Sub m_xhr_OnReadyStateChange()
  ' ...
End Sub

Not so with MSXML2.ServerXMLHTTP. Doing this will result in a Microsoft Visual Basic Compile Error: "Object does not source automation events".

Apparently the event is not exported for COM use. There is a way around this.

The signature for onreadystatechange reads

Property onreadystatechange As Object

So you can assign an object. We could create a class module with an onreadystatechange method and assign like this:

m_xhr.onreadystatechange = eventHandlingObject

However, this does not work. onreadystatechange expects an object and whenever the event fires, the object itself is called, not the method we've defined. (For the ServerXMLHTTP instance there is no way of knowing which method of the user-defined eventHandlingObject we intend to use as the event handler).

We need a callable object, i.e. an object with a default method (every COM object can have exactly one).
(For example: Collection objects are callable, you can say myCollection("foo") which is a shorthand for myCollection.Item("foo").)

To resolve issue #2:

We need a class module with a default property. Unfortunately these can't be created using the VBA IDE, but you can create them using a text editor.

• prepare the class module that contains an onreadystatechange function in the VBA IDE
• export it to a .cls file via right click
• open that in a text editor and add the following line beneath the onreadystatechange signature:
  Attribute OnReadyStateChange.VB_UserMemId = 0
• remove the original class module and and re-import it from file.

This will mark the modified method as Default. You can see a little blue dot in the Object Browser (F2), which marks the default method:

So every time the object is called, actually the OnReadyStateChange method is called.

To resolve issue #3:

Simply call waitForResponse() after send().

m_xhr.Send
m_xhr.waitForResponse timeout

In case of a timeout: If you did not call this method, the request simply never returns. If you did, an error is thrown after timeout milliseconds.

To resolve issue #4:

We need to use an On Error handler that catches the timeout error and transforms it into an event, for convenience.

Putting it all together

Here is a VB class module I wrote that wraps and handles an MSXML2.ServerXMLHTTP object. Save it as AjaxRequest.cls and import it into your project:

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "AjaxRequest"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

Private m_xhr As MSXML2.ServerXMLHTTP
Attribute m_xhr.VB_VarHelpID = -1
Private m_isRunning As Boolean

' default timeouts. TIMEOUT_RECEIVE can be overridden in request
Private Const TIMEOUT_RESOLVE As Long = 1000
Private Const TIMEOUT_CONNECT As Long = 1000
Private Const TIMEOUT_SEND As Long = 10000
Private Const TIMEOUT_RECEIVE As Long = 30000

Public Event Started()
Public Event Stopped()
Public Event Success(data As String, serverStatus As String)
Public Event Error(data As String, serverStatus As String, xhr As MSXML2.ServerXMLHTTP)
Public Event TimedOut(message As String)

Private Enum ReadyState
  XHR_UNINITIALIZED = 0
  XHR_LOADING = 1
  XHR_LOADED = 2
  XHR_INTERACTIVE = 3
  XHR_COMPLETED = 4
End Enum

Public Sub Class_Terminate()
  Me.Cancel
End Sub

Public Property Get IsRunning() As Boolean
  IsRunning = m_isRunning
End Property

Public Sub Cancel()
  If m_isRunning Then
    m_xhr.abort
    m_isRunning = False
    RaiseEvent Stopped
  End If
  Set m_xhr = Nothing
End Sub

Public Sub HttpGet(url As String, Optional timeout As Long = TIMEOUT_RECEIVE)
  Send "GET", url, vbNullString, timeout
End Sub

Public Sub HttpPost(url As String, data As String, Optional timeout As Long = TIMEOUT_RECEIVE)
  Send "POST", url, data, timeout
End Sub

Private Sub Send(method As String, url As String, data As String, Optional timeout As Long)
  On Error GoTo HTTP_error

  If m_isRunning Then
    Me.Cancel
  End If

  RaiseEvent Started

  Set m_xhr = New MSXML2.ServerXMLHTTP60

  m_xhr.OnReadyStateChange = Me
  m_xhr.setTimeouts TIMEOUT_RESOLVE, TIMEOUT_CONNECT, TIMEOUT_SEND, timeout

  m_isRunning = True
  m_xhr.Open method, url, True
  m_xhr.Send data
  m_xhr.waitForResponse timeout

  Exit Sub

HTTP_error:
  If Err.Number = &H80072EE2 Then
    Err.Clear
    Me.Cancel
    RaiseEvent TimedOut("Request timed out after " & timeout & "ms.")
    Resume Next
  Else
    Err.Raise Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
  End If
End Sub

' Note: the default method must be public or it won't be recognized
Public Sub OnReadyStateChange()
Attribute OnReadyStateChange.VB_UserMemId = 0
  If m_xhr.ReadyState = ReadyState.XHR_COMPLETED Then
    m_isRunning = False
    RaiseEvent Stopped

    ' TODO implement 301/302 redirect support

    If m_xhr.Status >= 200 And m_xhr.Status < 300 Then
      RaiseEvent Success(m_xhr.responseText, m_xhr.Status)
    Else
      RaiseEvent Error(m_xhr.responseText, m_xhr.Status, m_xhr)
    End If
  End If
End Sub

Note the line m_xhr.OnReadyStateChange = Me, which assigns the AjaxRequest instance itself as the event handler, as made possible by marking OnReadyStateChange() as the default method.

Be aware that if you make changes to OnReadyStateChange() you need to go through the export/modify/re-import routine again since the VBA IDE does not save the "default method" attribute.

The class exposes the following interface

• Methods:
  • HttpGet(url As String, [timeout As Long])
  • HttpPost(url As String, data As String, [timeout As Long])
  • Cancel()
• Properties
  • IsRunning As Boolean
• Events
  • Started()
  • Stopped()
  • Success(data As String, serverStatus As String)
  • Error(data As String, serverStatus As String, xhr As MSXML2.ServerXMLHTTP)
  • TimedOut(message As String)

Use it in another class module, for example in a user form, with WithEvents:

Option Explicit

Private WithEvents ajax As AjaxRequest

Private Sub UserForm_Initialize()
  Set ajax = New AjaxRequest
End Sub

Private Sub CommandButton1_Click()
  Me.TextBox2.Value = ""

  If ajax.IsRunning Then
    ajax.Cancel
  Else
    ajax.HttpGet Me.TextBox1.Value, 1000
  End If
End Sub

Private Sub ajax_Started()
  Me.Label1.Caption = "Running" & Chr(133)
  Me.CommandButton1.Caption = "Cancel"
End Sub

Private Sub ajax_Stopped()
  Me.Label1.Caption = "Done."
  Me.CommandButton1.Caption = "Send Request"
End Sub

Private Sub ajax_TimedOut(message As String)
  Me.Label1.Caption = message
End Sub

Private Sub ajax_Success(data As String, serverStatus As String)
  Me.TextBox2.Value = serverStatus & vbNewLine & data
End Sub

Private Sub ajax_Error(data As String, serverStatus As String, xhr As MSXML2.ServerXMLHTTP)
  Me.TextBox2.Value = serverStatus
End Sub

Make enhancements as you see fit. The AjaxRequest class was merely a byproduct of answering this question.