Question

我有一个函数可以从excel列表中ping计算机并获取它们的ping值。

当脚本运行时，excel完全没有响应。我可以用<input type="checkbox" checked />解决这个问题，这使得响应更快一些。

但是，当函数进入脱机计算机时，问题就会出现。当它等待离线PC的响应时，Excel再次冻结，脚本不会跳转到下一台PC，直到它超过＆＃34;超时＆＃34;从实际的。

由于默认的ping超时值是4000毫秒，如果我的列表中有100台计算机，其中50台已关闭，这意味着我必须等待额外的3,3分钟才能完成脚本，并且还会阻止整个Excel，使其在一段时间内无法使用。

我的问题是，是否有任何方法可以使这更快或更敏感或更聪明？

实际代码：

功能：

DoEvents

主：

Function sPing(sHost) As String

    Dim oPing As Object, oRetStatus As Object

    Set oPing = GetObject("winmgmts:{impersonationLevel=impersonate}").ExecQuery _
      ("select * from Win32_PingStatus where address = '" & sHost & "'")
 DoEvents
    For Each oRetStatus In oPing
        DoEvents
            If IsNull(oRetStatus.StatusCode) Or oRetStatus.StatusCode <> 0 Then
            sPing = "timeout" 'oRetStatus.StatusCode <- error code
        Else
            sPing = sPing & vbTab & oRetStatus.ResponseTime
        End If
    Next
End Function

Answer 1

正如评论中已经提到的，为了防止在每次调用后阻塞它，你需要从函数中异步调用你的ping。我接近这个的方法是将你的sPing(sHost)函数委托给你在临时文件夹中动态创建的VBScript。该脚本看起来像这样，它将IP地址作为命令行参数并将结果输出到文件：

Dim args, ping, status
Set ping = GetObject("winmgmts:{impersonationLevel=impersonate}").ExecQuery _
      ("select * from Win32_PingStatus where address = '" & Wscript.Arguments(0) & "'")
Dim result
For Each status In ping
    If IsNull(status.StatusCode) Or status.StatusCode <> 0 Then
        result = "timeout"
    Else
        result = result & vbTab & status.ResponseTime
    End If
Next
Dim fso, file
Set fso = CreateObject("Scripting.FileSystemObject")
Set file = fso.CreateTextFile(Wscript.Arguments(0), True)
file.Write result
file.Close

您可以创建一个Sub来将其写入类似这样的路径：

Private Sub WriteScript(path As String)
    Dim handle As Integer
    handle = FreeFile
    Open path & ScriptName For Output As #handle
    Print #handle, _
        "Dim args, ping, status" & vbCrLf & _
        "Set ping = GetObject(""winmgmts:{impersonationLevel=impersonate}"").ExecQuery _" & vbCrLf & _
        "      (""select * from Win32_PingStatus where address = '"" & Wscript.Arguments(0) & ""'"")" & vbCrLf & _
        "Dim result" & vbCrLf & _
        "For Each status In ping" & vbCrLf & _
        "    If IsNull(status.StatusCode) Or status.StatusCode <> 0 Then" & vbCrLf & _
        "        result = ""timeout""" & vbCrLf & _
        "    Else" & vbCrLf & _
        "        result = result & vbTab & status.ResponseTime" & vbCrLf & _
        "    End If" & vbCrLf & _
        "Next" & vbCrLf & _
        "Dim fso, file" & vbCrLf & _
        "Set fso = CreateObject(""Scripting.FileSystemObject"")" & vbCrLf & _
        "Set file = fso.CreateTextFile(Wscript.Arguments(0), True)" & vbCrLf & _
        "file.Write result" & vbCrLf & _
        "file.Close"
    Close #handle
End Sub

之后，它非常简单 - 在用户的临时目录中创建一个新目录，在其中填充脚本，然后使用Shell命令在其自己的进程中运行每个ping。等待超时的长度，然后从文件中读取结果：

Private Const TempDir = "\PingResults\"
Private Const ScriptName As String = "ping.vbs"
'Important - set this to the time in seconds of your ping timeout.
Private Const Timeout = 4

Sub pingall_Click()
    Dim sheet As Worksheet
    Set sheet = ActiveSheet

    Dim path As String
    'Create a temp folder to use.
    path = Environ("Temp") & TempDir
    MkDir path
    'Write your script to the temp folder.
    WriteScript path

    Dim results As Dictionary
    Set results = New Dictionary

    Dim index As Long
    Dim ip As Variant
    Dim command As String
    For index = 1 To sheet.UsedRange.Rows.Count
        ip = sheet.Cells(index, 1)
        If Len(ip) >= 7 Then
            If Left$(ip, 1) = "172.21." Then
                'Cache the row it was in.
                results.Add ip, index
                'Shell the script.
                command = "wscript " & path & "ping.vbs " & ip
                Shell command, vbNormalFocus
            End If
        End If
    Next index

    Dim completed As Double
    completed = Timer + Timeout
    'Wait for the timeout.
    Do While Timer < completed
        DoEvents
    Loop

    Dim handle As String, ping As String, result As String
    'Loop through the resulting files and update the sheet.
    For Each ip In results.Keys
        result = Dir$(path & ip)
        If Len(result) <> 0 Then
            handle = FreeFile
            Open path & ip For Input As #handle
            ping = Input$(LOF(handle), handle)
            Close #handle
            Kill path & ip
        Else
            ping = "timeout"
        End If
        sheet.Cells(results(ip), 2) = ping
    Next ip

    'Clean up.
    Kill path & "*"
    RmDir path
End Sub

请注意，这对文件操作的错误处理完全为零，并且不会响应您的StopCode标记。它应该给出它的基本要点。另请注意，如果您需要允许用户取消它，您将无法删除临时目录，因为它仍将被使用。如果是这种情况，只有在它不存在的情况下才创建它，并且在您完成后不要删除它。

Answer 2

您可能能够实现类似的功能，但我没有尝试过多个服务器

如果您的网络速度很快，您可以将超时时间减少到500毫秒或更短：

Public Function serverOk(ByVal dbSrvrNameStr As String) As Boolean

    Const PINGS         As Byte = 1
    Const PING_TIME_OUT As Byte = 500
    Const PING_LOCATION As String = "C:\Windows\System32\"

    Dim commandResult As Long, serverIsActive As Boolean

    commandResult = 1
    serverIsActive = False

    If Len(dbSrvrNameStr) > 0 Then

        Err.Clear

        With CreateObject("WScript.Shell")
            commandResult = .Run("%comspec% /c " & PING_LOCATION & "ping.exe -n " & PINGS & " -w " & PING_TIME_OUT & " " & dbSrvrNameStr & " | find ""TTL="" > nul 2>&1", 0, True)
            commandResult = .Run("%comspec% " & PING_LOCATION & "/c ping.exe -n " & PINGS & " -w " & PING_TIME_OUT & " " & dbSrvrNameStr, 0, True)
            serverIsActive = (commandResult = 0)
        End With

        If serverIsActive And Err.Number = 0 Then
            '"DB Server - valid, Ping response: " & commandResult
        Else
            '"Cannot connect to DB Server, Error: " & Err.Description & ", Ping response: " & commandResult
        End If
        Err.Clear
    End If

    serverOk = serverIsActive
End Function

链接到Microsoft的“运行方法（Windows脚本宿主）”：

https://msdn.microsoft.com/en-us/library/d5fk67ky(VS.85).aspx

此命令的第3个参数可以忽略：“bWaitOnReturn” - 允许您从VBA异步执行

Ping功能使整个excel表缓慢/无响应

2 个答案: