Ping函数使整个exceltableslow/unresponsive
Ping function makes the whole excel table slow/unresponsive
我有一个功能，可以从 excel 列表中 ping 计算机并获取它们的 ping 值。
虽然脚本是 运行，但 excel 完全没有响应。我可以用 DoEvents 来解决这个问题，这让它的响应速度更快了。
但是，当函数到达脱机计算机时，问题就开始了。在等待离线 PC 的响应时，Excel 再次冻结并且脚本不会跳转到下一台 PC，直到它从实际的 PC 获得 "timeout"。
由于默认的 ping 超时值为 4000 毫秒，如果我的列表中有 100 台计算机，其中 50 台已关闭，这意味着我必须额外等待 3.3 分钟才能完成脚本，并且还会阻止整个 Excel，使其在持续时间内无法使用。
我的问题是，是否有任何方法可以使它更快、响应更快或更智能？
实际代码：
函数：
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
主要：
Sub pingall_Click()
Dim c As Range
Dim p As String
Dim actives As String
actives = ActiveSheet.Name
StopCode = False
Application.EnableCancelKey = xlErrorHandler
On Error GoTo ErrH:
DoEvents
For Each c In Sheets(actives).UsedRange.Cells
If StopCode = True Then
Exit For
End If
DoEvents
If Left(c, 7) = "172.21." Then
p = sPing(c)
[...]
End If
Next c
End Sub
正如评论中已经指出的那样，为了防止在每次调用后阻塞，您需要从您的函数异步调用您的 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 标志。它应该给出它的基本要点。另请注意，如果您需要允许用户取消它，您将无法删除临时目录，因为它仍在使用中。如果是这种情况，只有在它不存在时才创建它，并且在完成后不要删除它。
您也许可以实现类似的功能，但我还没有在多个服务器上尝试过
- 如果您的网络速度很快，您可以将超时减少到 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 的 Link 到 "Run Method (Windows Script Host)"：
https://msdn.microsoft.com/en-us/library/d5fk67ky(VS.85).aspx
此命令的第三个参数可以忽略："bWaitOnReturn" - 允许您从 VBA
异步执行它
我有一个功能，可以从 excel 列表中 ping 计算机并获取它们的 ping 值。
虽然脚本是 运行，但 excel 完全没有响应。我可以用 DoEvents 来解决这个问题，这让它的响应速度更快了。
但是，当函数到达脱机计算机时，问题就开始了。在等待离线 PC 的响应时，Excel 再次冻结并且脚本不会跳转到下一台 PC，直到它从实际的 PC 获得 "timeout"。
由于默认的 ping 超时值为 4000 毫秒，如果我的列表中有 100 台计算机，其中 50 台已关闭，这意味着我必须额外等待 3.3 分钟才能完成脚本，并且还会阻止整个 Excel，使其在持续时间内无法使用。
我的问题是，是否有任何方法可以使它更快、响应更快或更智能？
实际代码：
函数：
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
主要：
Sub pingall_Click()
Dim c As Range
Dim p As String
Dim actives As String
actives = ActiveSheet.Name
StopCode = False
Application.EnableCancelKey = xlErrorHandler
On Error GoTo ErrH:
DoEvents
For Each c In Sheets(actives).UsedRange.Cells
If StopCode = True Then
Exit For
End If
DoEvents
If Left(c, 7) = "172.21." Then
p = sPing(c)
[...]
End If
Next c
End Sub
正如评论中已经指出的那样，为了防止在每次调用后阻塞，您需要从您的函数异步调用您的 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 标志。它应该给出它的基本要点。另请注意，如果您需要允许用户取消它，您将无法删除临时目录，因为它仍在使用中。如果是这种情况，只有在它不存在时才创建它，并且在完成后不要删除它。
您也许可以实现类似的功能，但我还没有在多个服务器上尝试过
- 如果您的网络速度很快，您可以将超时减少到 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 的Link 到 "Run Method (Windows Script Host)"：
https://msdn.microsoft.com/en-us/library/d5fk67ky(VS.85).aspx
此命令的第三个参数可以忽略："bWaitOnReturn" - 允许您从 VBA
异步执行它