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

Question

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

我已经准备好了一个测试文件,你可以在这里下载.按下打开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

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

谢谢您帮忙!

Answer 1

这里有几个复杂的问题.

1. MSXML2.ServerXMLHTTP不公开COM可用事件.因此,不容易使用WithEvents和附加到其OnReadyStateChange事件来实例化对象.
   事件就在那里,但处理它的标准VBA方法不起作用.
2. 无法使用VBA IDE创建可以处理事件的模块.
3. 您需要waitForResponse()在使用异步请求时调用(除了调用setTimeouts()!)
4. 没有timeout事件.超时被视为错误.

要解决问题#1:

通常,VBA类模块(也适用于用户表单或工作表模块)允许您执行此操作:

Private WithEvents m_xhr As MSXML2.ServerXMLHTTP

所以你可以像这样定义一个事件处理程序:

Private Sub m_xhr_OnReadyStateChange()
  ' ...
End Sub

不是这样的MSXML2.ServerXMLHTTP.执行此操作将导致Microsoft Visual Basic编译错误:"对象不源自动化事件".

显然,该事件不会导出以供COM使用.有一种解决方法.

onreadystatechange读取的签名

Property onreadystatechange As Object

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

m_xhr.onreadystatechange = eventHandlingObject

但是,这不起作用.onreadystatechange期望一个对象,每当事件触发时,都会调用对象本身,而不是我们定义的方法.(对于ServerXMLHTTP实例,无法知道eventHandlingObject我们打算将哪个用户定义的方法用作事件处理程序).

我们需要一个可调用的对象,即一个带有默认方法的对象(每个COM对象只能有一个).
(例如:Collection对象是可调用的,你可以说myCollection("foo")哪个是速记myCollection.Item("foo").)

要解决问题#2:

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

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

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

因此,每次调用对象时,实际上OnReadyStateChange都会调用该方法.

要解决问题#3:

只需调用waitForResponse()后send().

m_xhr.Send
m_xhr.waitForResponse timeout

如果超时:如果您没有调用此方法,则请求永远不会返回.如果您这样做,则在timeout几毫秒后抛出错误.

要解决问题#4:

On Error为方便起见,我们需要使用捕获超时错误并将其转换为事件的处理程序.

把它们放在一起

这是我写的一个VB类模块,它包装和处理一个MSXML2.ServerXMLHTTP对象.将其另存为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

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

请注意,如果您进行了更改,则OnReadyStateChange()需要再次执行导出/修改/重新导入例程,因为VBA IDE不会保存"default method"属性.

该类公开以下接口

• 方法:
  • 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)

在另一个类模块中使用它,例如在用户表单中,使用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

根据需要进行增强.这AjaxRequest堂课只是回答这个问题的副产品.