VBA 如何捕获请求超时错误？

How to VBA catch request timeout error?

提问by Davuz

I'm using object MSXML2.ServerXMLHTTP60send request to webservice; with this object, I can speed up data loading by asynchronousmethod and avoid lockups Excel screen (not responding). But, I'm still have a problem when webservice response for a long time, out of ServerXMLHTTP60 timeout setting, the request function was silently, I cannot catch timeout error. At another question, @osknows suggests using xmlhttp status = 408to catching timeout error, but it doesn't work for me.

我正在使用对象MSXML2.ServerXMLHTTP60向 webservice 发送请求；有了这个对象，我可以通过异步方法加速数据加载，避免锁定 Excel 屏幕（没有响应）。但是，我在 webservice 响应很长时间时仍然有问题，超出 ServerXMLHTTP60 超时设置，请求功能是静默的，我无法捕获超时错误。在另一个问题上，@osknows 建议使用xmlhttp status = 408捕获超时错误，但它对我不起作用。

I've prepaired a test file, you can download at here. Open VBA source by press Atl + F8, you will see class module CXMLHTTPHandler, that I copied from this guide

我准备了一个测试文件，你可以在这里下载。按打开 VBA 源代码Atl + F8，您将看到CXMLHTTPHandler我从本指南中复制的类模块

    If m_xmlHttp.readyState = 4 Then
        If m_xmlHttp.Status = 200 Then
            MsgBox m_xmlHttp.responseText
        ElseIf m_xmlHttp.Status = 408 Then 'Debug never run to here?
            MsgBox "Request timeout"
        Else
         'Error happened
        End If
    End If

How to VBA catch request timeout error?

VBA 如何捕获请求超时错误？

Thank for your help!

感谢您的帮助！

回答by Tomalak

There are several complications here.

这里有几个并发症。

1. MSXML2.ServerXMLHTTPdoes not expose COM-usable events. Therefore it is not easily possible to instantiate an object using WithEventsand attach to its OnReadyStateChangeevent.
   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 timeoutevent. Timeouts are thrown as an error.

1. MSXML2.ServerXMLHTTP不公开 COM 可用事件。因此，使用WithEvents和附加到它的OnReadyStateChange事件来实例化一个对象是不容易的。
   该事件在那里，但处理它的标准 VBA 方式不起作用。
2. 无法使用 VBA IDE 创建可以处理该事件的模块。
3. waitForResponse()使用异步请求时需要调用（除了调用setTimeouts()！）
4. 没有timeout事件。超时作为错误抛出。

To resolve issue #1:

解决问题#1：

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

通常，VBA 类模块（也适用于用户表单或工作表模块）允许您执行以下操作：

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".

不是这样的MSXML2.ServerXMLHTTP。这样做将导致 Microsoft Visual Basic 编译错误：“对象不提供自动化事件”。

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

显然，该事件没有导出供 COM 使用。有办法解决这个问题。

The signature for onreadystatechangereads

onreadystatechange读取签名

Property onreadystatechange As Object

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

所以你可以分配一个对象。我们可以用一个onreadystatechange方法创建一个类模块并像这样分配：

m_xhr.onreadystatechange = eventHandlingObject

However, this does not work. onreadystatechangeexpects an object and whenever the event fires, the object itselfis called, not the method we've defined. (For the ServerXMLHTTPinstance there is no way of knowing which method of the user-defined eventHandlingObjectwe intend to use as the event handler).

但是，这不起作用。onreadystatechange期望一个对象，每当事件触发时，都会调用对象本身，而不是我们定义的方法。（例如，ServerXMLHTTP无法知道eventHandlingObject我们打算使用用户定义的哪个方法作为事件处理程序）。

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

我们需要一个可调用对象，即一个带有默认方法的对象（每个 COM 对象都可以有一个）。
（例如：Collection对象是可调用的，您可以说myCollection("foo")哪个是 的简写myCollection.Item("foo")。）

To resolve issue #2:

解决问题#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.

我们需要一个具有默认属性的类模块。不幸的是，这些不能使用 VBA IDE 创建，但您可以使用文本编辑器创建它们。

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

• onreadystatechange在 VBA IDE 中准备包含函数的类模块
• .cls通过右键单击将其导出到文件
• 在文本编辑器中打开它并在onreadystatechange签名下方添加以下行：
  Attribute OnReadyStateChange.VB_UserMemId = 0
• 删除原始类模块并从文件中重新导入它。

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:

这会将修改后的方法标记为Default。您可以在对象浏览器 (F2) 中看到一个小蓝点，它标志着默认方法：

So every time the object is called, actuallythe OnReadyStateChangemethod is called.

所以每对象被调用时，实际上该OnReadyStateChange方法被调用。

To resolve issue #3:

解决问题#3：

Simply call waitForResponse()after send().

只需waitForResponse()在 之后调用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 timeoutmilliseconds.

在超时的情况下：如果您没有调用此方法，则请求将永远不会返回。如果您这样做了，则会在timeout几毫秒后引发错误。

To resolve issue #4:

解决问题#4：

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

On Error为方便起见，我们需要使用一个处理程序来捕获超时错误并将其转换为事件。

Putting it all together

把这一切放在一起

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

这是我编写的包装和处理MSXML2.ServerXMLHTTP对象的 VB 类模块。将其另存为AjaxRequest.cls并将其导入到您的项目中：

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 itselfas the event handler, as made possible by marking OnReadyStateChange()as the default method.

请注意m_xhr.OnReadyStateChange = Me将 AjaxRequest 实例本身指定为事件处理程序的行，这可以通过标记OnReadyStateChange()为默认方法来实现。

Be aware thatif 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.

请注意，如果您进行更改，则OnReadyStateChange()需要再次执行导出/修改/重新导入例程，因为 VBA IDE 不保存“默认方法”属性。

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)

• 方法：
  • HttpGet(url As String, [timeout As Long])
  • HttpPost(url As String, data As String, [timeout As Long])
  • Cancel()
• 特性
  • IsRunning As Boolean
• 活动
  • 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:

在另一个类模块中使用它，例如在用户表单中，使用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 AjaxRequestclass was merely a byproduct of answering this question.

进行您认为合适的增强。这AjaxRequest门课只是回答这个问题的副产品。