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

问题描述

我正在使用对象发送请求到webservice;有了这个对象，我可以通过异步方法加速数据加载，并避免锁定Excel屏幕（不响应）。但是，我还是有一个问题，当webservice响应很长时间，出于ServerXMLHTTP60超时设置，请求功能默认，我无法捕获超时错误。在，@osknows建议使用 xmlhttp status = 408 以捕获超时错误，但对我来说不起作用。

我已经准备好了一个测试文件，您可以在这里下载

 如果m_xmlHttp.readyState = 4然后
如果m_xmlHttp.Status = 200然后
 MsgBox m_xmlHttp.responseText 
 ElseIf m_xmlHttp.Status = 408然后调试从不跑到这里？ 
 MsgBox请求超时
 Else 
'发生错误
结束如果
结束如果
  

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

感谢您的帮助！

解决方案

这里有几个并发症。

1. MSXML2.ServerXMLHTTP 不会公开COM可用的事件。因此，使用 WithEvents 实例化对象是不容易的，并附加到其 OnReadyStateChange 事件。
   
   事件在那里，但处理它的标准VBA方法不起作用。


2. 无法使用VBA IDE创建可处理该事件的模块。


3. 您需要致电当您使用异步请求（另外调用 setTimeouts（）！）


4. 没有超时事件。超时将作为错误引发。

要解决问题＃1：

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

  Private WithEvents m_xhr作为MSXML2.ServerXMLHTTP 
  

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

  Private Sub m_xhr_OnReadyStateChange（）
'... 
 End Sub 
  

不是与 MSXML2.ServerXMLHTTP 。执行此操作将导致Microsoft Visual Basic编译错误：对象不会自动生成事件。

显然，事件未导出为COM使用。这有一个办法。

onreadystatechange 的签名读取

 属性onreadystatechange作为对象
  

所以你可以分配对象。我们可以使用 onreadystatechange 方法创建一个类模块，并分配如下：

  m_xhr.onreadystatechange = eventHandlingObject 
  

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

我们需要一个可调用对象，即具有默认方法的对象（每个COM对象都可以只有一个）。

（例如：集合对象可调用，您可以说 myCollection（foo）这是 myCollection.Item（foo）的缩写。）

要解决问题＃2：

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

• 准备在VBA IDE中包含 onreadystatechange 函数的类模块
• 
  
• 通过右键单击


• 将其导出到 .cls 文件，在文本编辑器和在 onreadystatechange 签名之下添加以下行：
  
  属性OnReadyStateChange.VB_UserMemId = 0


• 删除原始类模块，并从文件重新导入。

这将标记修改方法为 Default 。您可以在对象浏览器（F2）中看到一个小点，标示默认方法：

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

要解决问题＃3：

只需在 send（）之后调用 waitForResponse（）。

  m_xhr.Send 
 m_xhr.waitForResponse timeout 
  

如果超时：如果没有调用此方法，则该请求根本不会返回。如果你这样做，在 timeout之后抛出一个错误。毫秒。

要解决问题＃4： / strong>

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

将它们放在一起

这是一个VB类模块我写了包裹并处理一个 MSXML2.ServerXMLHTTP 对象。将其保存为 AjaxRequest.cls 并将其导入到您的项目中：

  VERSION 1.0 CLASS 
 BEGIN 
 MultiUse = -1'True 
 END 
属性VB_Name =AjaxRequest
属性VB_GlobalNameSpace = False 
属性VB_Creatable = False 
属性VB_PredeclaredId = False 
属性VB_Exposed = False 
选项显式
 
私有m_xhr作为MSXML2.ServerXMLHTTP 
属性m_xhr.VB_VarHelpID = -1 
私有m_isRunning As Boolean 
 
'默认超时。 TIMEOUT_RECEIVE可以在请求中被覆盖
 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 
 
公共事件已启动（）
公共事件Stopped（）
公共事件成功（数据As String，serverStatus As String）
公共事件错误（数据As String， serverStatus As String，xhr as MSXML2.ServerXMLHTTP）
公共事件TimedOut（消息As String）
 
私有枚举ReadyState 
 XHR_UNINITIALIZED = 0 
 XHR_LOADING = 1 
 XHR_LOADED = 2 
 XHR_INTERACTIVE = 3 
 XHR_COMPLETED = 4 
结束枚举
 
公共子类Class_Terminate（）
 Me.Cancel 
结束子
 
公共属性获取IsRunning（）作为布尔值
 IsRunning = m_isRunning 
结束属性
 
公共子取消（）
如果m_isRunning Then 
 m_xhr.abort 
 m_isRunning = False 
 RaiseEvent已停止
结束如果
设置m_xhr = Nothing 
 End Sub 
 
 Public Sub HttpGet（url As String，可选的timeout As Long = TIMEOUT_RECEIVE）
发送GET，url， vbNullString，timeout 
 End Sub 
 
 Public Sub HttpPost（url As String，data As String，可选timeout As Long = TIMEOUT_RECEIVE）
发送POST，url，data，timeout 
 End Sub 
 
私有子发送（方法As String，url As String，data As String，可选超时为长）
错误GoTo HTTP_error 
 
如果m_isRunning然后
 Me.Cancel 
结束If 
 
 RaiseEvent Started 
 
设置m_xhr =新建MSXML2.ServerXMLHTTP60 
 
 m_xhr.OnReadyStateChange = Me 
 m_xhr.setTimeouts TIMEOUT_RESOLVE，TIMEOUT_CONNECT，TIMEOUT_SEND，超时
 
 m_isRunning = True 
 m_xhr.Open方法，url，True 
 m_xhr.Send数据
 m_xhr.waitForResponse timeout 
 
退出子
 
 HTTP_error：
如果Err.Number =& H80072EE2然后
 Err.Clear 
 Me.Cancel 
 RaiseEvent TimedOut（请求超时&超时& ms。）
简历Next 
 Else 
 Err.Raise Err.Number，Err.Source，Err.Description，Err.HelpFile，Err.HelpContext 
 End If 
 End Sub 
 
'注意：默认方法必须是public或不会被识别
 Public Sub OnReadyStateChange（）
属性OnReadyStateChange.VB_UserMemId = 0 
如果m_xhr.ReadyState = ReadyState.XHR_COMPLETED然后
 m_isRunning = False 
 RaiseEvent已停止
 
'TODO实施301/302重定向支持
 
如果m_xhr。状态> = 200和m_xhr.Status< 300然后
 RaiseEvent Success（m_xhr.responseText，m_xhr.Status）
 Else 
 RaiseEvent错误（m_xhr.responseText，m_xhr.Status，m_xhr）
结束如果
结束如果
 End Sub 
  

请注意行 m_xhr.OnReadyStateChange = Me ，它将AjaxRequest实例本身分配为事件处理程序，通过将 OnReadyStateChange（）标记为默认值方法。

请注意如果您对 OnReadyStateChange（）进行更改再次导出/重新导入例程，因为VBA IDE不保存default method属性。

该类公开了以下界面。 p>

• 方法：
  
  
  
  
  • HttpGet（url As字符串，[超时长]）
  
  
  • HttpPost（url As String，data As String，[timeout As Long] code>
  
  
  • 取消（）
  
  
  
  
  • 属性
    
    
    
    
    • IsRunning As Boolean
      
  
  
  • 事件
    
    
    
    
    • Started（） / code>
    
    
    • Stopped（）
    
    
    • 成功（数据As String，serverStatus As String）
    
    
    • 错误（数据As String，serverStatus As String，xhr as MSXML2.ServerXMLHTTP）
    
    
    • TimedOut（邮件As String）
    
    
    / li>

  
  
  

  在另一个类模块中使用它，例如用户窗体中的 WithEvents ：

    Option Explicit 
   
   Private WithEvents ajax As AjaxRequest 
   
   Private Sub UserForm_Initialize（）
  设置ajax =新建AjaxRequest 
   End Sub 
   
   Private Sub CommandButton1_Click（）
   Me.TextBox2.Value = 
   
  如果ajax.IsRunning然后
   ajax.Cancel 
   Else 
   ajax.HttpGet Me.TextBox1.Value，1000 
  结束如果
   End Sub 
   
   Private Sub ajax_Started（）
   Me.Label1.Caption =Running& Chr（133）
   Me.CommandButton1.Caption =取消
   End Sub 
   
  私有子ajax_Stopped（）
   Me.Label1.Caption =完成。 
   Me.CommandButton1.Caption =发送请求
   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&数据
   End Sub 
   
   Private Sub ajax_Error（data As String，serverStatus As String，xhr as MSXML2.ServerXMLHTTP）
   Me.TextBox2.Value = serverStatus 
   End Sub 
    

  根据您的需要进行增强。 AjaxRequest 类只是回答这个问题的副产品。

  
  

  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 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 = 408 to catching timeout error, but it doesn't work for me.

  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

      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?

  Thank for your help!

  解决方案

  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.

  这篇关于如何VBA捕获请求超时错误？的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持！