对象变量或未设置块变量-运行时错误代码91

Question

我使用vba工具ping到我的系统中的一些IP，如果ping结果在实际情况下是" reply from xx.xx.xx.xx destination host unreachable "，结果only/off是不够BCS的;但没有打包丢失，ping工具将返回"在线"。地位。

所以现在，我使用下面的代码来描述ping命令的返回状态，但是我得到了"对象变量或块变量未设置"-运行时错误代码91在行:

Set objPing = GetObject(…)

所以，任何人都可以帮助我，非常感谢

Function GetPingResult(Host)
Dim objPing As Object
Dim objStatus As Object
Dim strResult As String
*Set objPing = GetObject("WinMgmts:{impersonationLevel=impersonate}").ExecQuery _
("SELECT * FROM Win32_PingStatus WHERE Address = '" & Host & "' ")*
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
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

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 In ipRng
For introw = 2 To ActiveSheet.Cells(65536, 2).End(xlUp).Row
Result = GetPingResult(Cell)
Cell.Offset(0, 1) = Result
strMessage = ActiveSheet.Cells(introw, 1).Value & " " & ActiveSheet.Cells(introw, 2).Value & " is " & Result
strPostData = "chat_id=" & strChatID & "&text=" & strMessage
SendMessage (strPostData)
' Next Cell
Next
Loop
Sheet1.Range("F1").Value = "IDLE"
End Sub
Sub stop_ping()
Sheet1.Range("F1").Value = "STOP"
End Sub
Function SendMessage(strPostData)
Dim objRequest As Object
' Dim strChatID As String
' Dim strMessage As String
' Dim strPostData As String
' strChatID = 5779677248#
' strChatId = -834898784
' strMessage = "Hello"
' strPostData = "chat_id=" & strChatID & "&text=" & strMessage
Set objRequest = CreateObject("MSXML2.ServerXMLHTTP")
With objRequest
' .Open "POST", "https://api.telegram.org/bot5733265530:AAE0bZU_mJ8OZpZvEwn-gQExFf6GY-D8XWc/sendMessage?", False
.Open "POST", "https://api.telegram.org/bot5773569326:AAFpzQcdjIpsbd-IVCotXMucvpG4DpLfSVE/sendMessage?", False
.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
.send (strPostData)

End With
End Function

这是我创建的原始代码，它工作得很好，但我想发送消息到电报，我添加了通过电报发送代码的子。然后失败了。

Function GetPingResult(Host)
Dim objPing As Object
Dim objStatus As Object
Dim strResult As String
Set objPing = GetObject("winmgmts:{impersonationLevel=impersonate}"). _
ExecQuery("Select * from Win32_PingStatus Where Address = '" & Host & "'")
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
Sub GetIPStatus()
Dim Cell As Range
Dim ipRng As Range
Dim Result As String
Dim Wks As Worksheet

Set Wks = Worksheets("Sheet1")
Set ipRng = Wks.Range("B3")
Set RngEnd = Wks.Cells(Rows.Count, ipRng.Column).End(xlUp)
Set ipRng = IIf(RngEnd.Row < ipRng.Row, ipRng, Wks.Range(ipRng, RngEnd))
For Each Cell In ipRng
Result = GetPingResult(Cell)
Cell.Offset(0, 1) = Result
Next Cell
End Sub

Answer 1

检查objPing，看GetObject是否先返回一个对象

如果不返回任何值，则根本不能使用ExecQuery。

Dim objPing As Object
Dim objQuery As Object
Dim objStatus as Object
Set objPing = GetObject("WinMgmts:{impersonationLevel=impersonate}")
If Not objPing Is Nothing Then
Set objQuery = objPing.ExecQuery("SELECT * FROM Win32_PingStatus WHERE Address = '" & Host & "' ")
If Not objQuery Is Nothing Then ' not sure this can return nothing, but it doesn't hurt to check
For Each objStatus In objQuery
' [... rest of your code here ...]
Next
Else
Msgbox "Nothing found for : " & Host
End If
Else
Msgbox "Cannot Impersonate"
End If

也:https://learn.microsoft.com/en-us/windows/win32/wmisdk/setting-the-default-process-security-level-using-vbscript