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

我准备了一个测试文件，大家可以下载at here .按 Atl + F8 打开 VBA 源代码, 你会看到类模块 CXMLHTTPHandler ，我从 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

最佳答案

这里有几个并发症。

Private WithEvents m_xhr As MSXML2.ServerXMLHTTP

Private Sub m_xhr_OnReadyStateChange()
  ' ...
End Sub

Property onreadystatechange As Object

m_xhr.onreadystatechange = eventHandlingObject

m_xhr.Send
m_xhr.waitForResponse timeout

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

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

关于xml - VBA 如何捕获请求超时错误？，我们在Stack Overflow上找到一个类似的问题： https://stackoverflow.com/questions/11607677/