这里有几个复杂的地方。
-
MSXML2.ServerXMLHTTP 不公开 COM 可用事件。因此，使用WithEvents 实例化对象并附加到其OnReadyStateChange 事件是不容易的。
事件存在，但处理它的标准 VBA 方法不起作用。
- 无法使用 VBA IDE 创建可以处理事件的模块。
- 使用异步请求时需要调用
waitForResponse()（除了调用setTimeouts()！）
- 没有
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 创建，但您可以使用文本编辑器创建它们。
- 在 VBA IDE 中准备包含
onreadystatechange 函数的类模块
- 通过右键将其导出到
.cls文件
- 在文本编辑器中打开它并在
onreadystatechange 签名下方添加以下行：
Attribute OnReadyStateChange.VB_UserMemId = 0
- 删除原始类模块并从文件中重新导入。
这会将修改后的方法标记为Default。您可以在对象浏览器（F2）中看到一个小蓝点，这标志着默认方法：
所以每次调用对象时，实际上都会调用OnReadyStateChange方法。
要解决问题 #3：
只需在send() 之后调用waitForResponse()。
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 不保存“默认方法”属性。
该类公开以下接口
- 方法：
HttpGet(url As String, [timeout As Long])HttpPost(url As String, data As String, [timeout As Long])Cancel()
- 属性
- 事件
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 类只是回答这个问题的副产品。