VBA实现IP Ping及Telegram推送时触发运行时错误91的问题

问题概述 #

• 需求：Ping操作需返回具体状态（如「目标主机不可达」），而非仅简单的在线/离线标识。
• 报错：添加Telegram推送功能后，代码执行到以下语句时触发运行时错误91（对象变量或With块变量未设置）：

  Set objPing = GetObject("WinMgmts:{impersonationLevel=impersonate}").ExecQuery _
    ("SELECT * FROM Win32_PingStatus WHERE Address = '" & Host & "' ")
  

错误原因 #

修改后的GetIPStatus过程中循环逻辑出错：注释掉了For Each Cell In ipRng循环，改用For introw循环后未给Cell变量赋值，直接调用GetPingResult(Cell)时传入的是未初始化的对象，导致WMI查询的Host参数无效，最终查询失败，objPing未被正确赋值。同时原代码未对WMI查询失败的情况做错误处理，进一步触发运行时错误。

修复方案 #

1. 修复循环变量赋值错误，确保GetPingResult接收有效的IP地址。
2. 在GetPingResult中添加参数校验和错误捕获，避免WMI查询失败导致的报错。
3. 保留原有的StatusCode分支逻辑，确保返回具体的Ping状态。

修正后的完整代码 #

1. Ping状态获取函数（增强错误处理） #

Function GetPingResult(Host)
    Dim objPing As Object
    Dim objStatus As Object
    Dim strResult As String
    
    ' 校验Host参数有效性
    If IsEmpty(Host) Or Host = "" Then
        GetPingResult = "Invalid Host"
        Exit Function
    End If
    
    ' 捕获WMI查询可能的错误
    On Error Resume Next
    Set objPing = GetObject("WinMgmts:{impersonationLevel=impersonate}").ExecQuery _
      ("SELECT * FROM Win32_PingStatus WHERE Address = '" & Host & "' ")
    On Error GoTo 0
    
    ' 检查查询是否成功
    If objPing Is Nothing Then
        GetPingResult = "WMI Query Failed"
        Exit Function
    End If
    
    ' 解析Ping状态码
    For Each objStatus In objPing
        Select Case objStatus.StatusCode
            Case 0: strResult = "Connected"
            Case 11001: strResult = "Buffer too small"
            Case 11002: strResult = "Destination net unreachable"
            Case 11003: strResult = "Destination host unreachable"
            Case 11004: strResult = "Destination protocol unreachable"
            Case 11005: strResult = "Destination port unreachable"
            Case 11006: strResult = "No resources"
            Case 11007: strResult = "Bad option"
            Case 11008: strResult = "Hardware error"
            Case 11009: strResult = "Packet too big"
            Case 11010: strResult = "Request timed out"
            Case 11011: strResult = "Bad request"
            Case 11012: strResult = "Bad route"
            Case 11013: strResult = "Time-To-Live (TTL) expired transit"
            Case 11014: strResult = "Time-To-Live (TTL) expired reassembly"
            Case 11015: strResult = "Parameter problem"
            Case 11016: strResult = "Source quench"
            Case 11017: strResult = "Option too big"
            Case 11018: strResult = "Bad destination"
            Case 11032: strResult = "Negotiating IPSEC"
            Case 11050: strResult = "General failure"
            Case Else: strResult = "Unknown host"
        End Select
        GetPingResult = strResult
    Next
    Set objPing = Nothing
End Function

2. 主执行过程（修复循环逻辑） #

Sub GetIPStatus()
    Dim strMessage As String
    Dim Cell As Range
    Dim ipRng As Range
    Dim Result As String
    Dim Wks As Worksheet
    Dim strPostData As String
    Dim strChatID As String
    
    strChatID = ActiveSheet.Range("D2").Value

    Set Wks = Worksheets("Sheet1")

    Set ipRng = Wks.Range("B2")
    Set RngEnd = Wks.Cells(Rows.Count, ipRng.Column).End(xlUp)
    Set ipRng = IIf(RngEnd.Row < ipRng.Row, ipRng, Wks.Range(ipRng, RngEnd))

    Do Until Sheet1.Range("F1").Value = "STOP"
        Sheet1.Range("F1").Value = "TESTING"
        ' 恢复For Each循环，确保Cell变量正确指向IP单元格
        For Each Cell In ipRng
            Result = GetPingResult(Cell.Value)
            Cell.Offset(0, 1) = Result
            ' 组装推送消息（A列为名称，B列为IP）
            strMessage = Cell.Offset(0, -1).Value & " " & Cell.Value & " is " & Result
            strPostData = "chat_id=" & strChatID & "&text=" & strMessage
            SendMessage strPostData
        Next Cell
        ' 可选：添加5秒延迟，避免频繁请求触发限制
        Application.Wait Now + TimeValue("00:00:05")
    Loop
    Sheet1.Range("F1").Value = "IDLE"
End Sub

3. 停止Ping过程 #

Sub stop_ping()
    Sheet1.Range("F1").Value = "STOP"
End Sub

4. Telegram推送函数（增强错误处理） #

Function SendMessage(strPostData)
    Dim objRequest As Object

    Set objRequest = CreateObject("MSXML2.ServerXMLHTTP")

    ' 捕获网络请求错误
    On Error Resume Next
    With objRequest
        .Open "POST", "https://api.telegram.org/bot5773569326:AAFpzQcdjIpsbd-IVCotXMucvpG4DpLfSVE/sendMessage", False
        .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
        .send strPostData
    End With
    On Error GoTo 0
    
    Set objRequest = Nothing
End Function

额外说明 #

• 调用GetPingResult时传入单元格的值（Cell.Value）而非对象，避免因对象传递导致的异常。
• 添加的延迟可根据需求调整，防止短时间内大量Ping请求和Telegram推送触发平台限制。

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