Excel VBA中MSXML2.ServerXMLHTTP.6.0请求超时问题求助

运行Excel VBA调用本地服务器时，偶尔会触发以下错误并停止运行：

运行时错误 '2147012894 (80072ee2)': 操作超时。

原始代码：

Set http = CreateObject("MSXML2.ServerXMLHTTP.6.0")
http.Open "GET", myurl, False
http.send

错误发生在http.send行。当前同时运行4个Excel实例，每个实例每分钟调用一次本地服务器，需要实现报错后代码仍能继续运行的效果。

尝试过两种修改方案但未解决问题：

UPDATE 1 代码 #

Set http = CreateObject("MSXML2.ServerXMLHTTP.6.0")

http.Open "GET", myurl, False, "", ""
http.send
If http.readyState = 4 Then
'Debug.Print http.responseText
Else: Debug.Print "xmlhttp.ReadyState =" & http.readyState
End If

'*** process received JSON-response in code below 
Set JSON = ParseJson(http.responseText)

关闭本地服务器时，代码仍在http.send行停止。

UPDATE 2 代码 #

Set http = CreateObject("MSXML2.ServerXMLHTTP.6.0")

    minute_to_wait_api = 50
    flag_api = True
    starttime_api = Timer

    http.Open "GET", myurl, False, "", ""
    http.send

    Do
        DoEvents
        DoEvents
        endtime_api = Timer
        endtime_api = Round(endtime_api - starttime_api, 0)
        If endtime_api >= minute_to_wait_api Then
            flag_api = False
            Exit Do
        End If
    Loop While http.readyState <> 4
    
    If flag_api = False Then
      Debug.Print "API Taking too long to respond"
      Exit Sub
    End If
            
    If http.Status <> 200 Then
        Debug.Print "http_error: " & http.Status
        Exit Sub
    End If

问题依旧存在。

1. 主动设置请求超时时间 #

MSXML2.ServerXMLHTTP.6.0支持自定义超时参数，在Open之后、Send之前添加SetTimeouts方法，避免默认超时逻辑导致的崩溃：

Set http = CreateObject("MSXML2.ServerXMLHTTP.6.0")
' 参数依次为：解析DNS超时、连接服务器超时、发送数据超时、接收响应超时（单位：毫秒）
http.SetTimeouts 1000, 2000, 3000, 5000
http.Open "GET", myurl, False
http.send

可根据本地服务器的响应速度调整数值，比如本地服务可将接收超时设为5000（5秒）以内。

2. 添加错误捕获机制 #

用错误捕获语句包裹请求逻辑，直接捕获send阶段的超时错误，确保代码不会中断：

Sub CallLocalServer()
    Dim http As Object
    Dim myurl As String
    myurl = "你的本地服务器地址"
    
    On Error Resume Next ' 开启错误捕获
    Set http = CreateObject("MSXML2.ServerXMLHTTP.6.0")
    http.SetTimeouts 1000, 2000, 3000, 5000
    http.Open "GET", myurl, False
    http.send
    
    ' 检查并处理错误
    If Err.Number <> 0 Then
        Debug.Print "请求出错：" & Err.Description & "（错误码：" & Err.Number & "）"
        Err.Clear ' 清除错误状态
        Set http = Nothing
        Exit Sub
    End If
    On Error GoTo 0 ' 关闭错误捕获
    
    ' 正常处理响应
    If http.readyState = 4 And http.Status = 200 Then
        Dim JSON As Object
        Set JSON = ParseJson(http.responseText)
        ' 后续业务逻辑...
    Else
        Debug.Print "请求失败，状态码：" & http.Status & "，ReadyState：" & http.readyState
    End If
    
    Set http = Nothing
End Sub

3. 改用异步请求（多实例场景推荐） #

同步请求（Open第三个参数为False）会阻塞Excel进程，多实例同时请求易加重服务器负担。改用异步请求配合状态回调，避免进程阻塞：

Dim http As Object

Sub AsyncCallLocalServer()
    Dim myurl As String
    myurl = "你的本地服务器地址"
    
    On Error Resume Next
    Set http = CreateObject("MSXML2.ServerXMLHTTP.6.0")
    http.SetTimeouts 1000, 2000, 3000, 5000
    ' 设置异步请求
    http.Open "GET", myurl, True
    ' 指定状态变化时的回调函数
    http.OnReadyStateChange = GetRef("HandleResponse")
    http.send
    
    If Err.Number <> 0 Then
        Debug.Print "异步请求启动失败：" & Err.Description
        Err.Clear
        Set http = Nothing
    End If
End Sub

Sub HandleResponse()
    If http.readyState = 4 Then
        On Error Resume Next
        If http.Status = 200 Then
            Dim JSON As Object
            Set JSON = ParseJson(http.responseText)
            ' 响应处理逻辑...
        Else
            Debug.Print "异步请求失败，状态码：" & http.Status
        End If
        Set http = Nothing
        On Error GoTo 0
    End If
End Sub

4. 优化多实例调用策略 #

• 给每个实例添加随机延迟，避免4个实例同时发起请求，分散服务器压力：

' 请求前添加1-5秒随机延迟
Randomize
DelaySeconds = Int((5 * Rnd) + 1)
Application.Wait Now + TimeValue("00:00:" & DelaySeconds)

• 检查本地服务器的并发连接数限制，确保服务器能支撑多实例同时请求。

内容的提问来源于stack exchange，提问作者user2165379