Ping功能使整个excel表缓慢/无响应 [英] Ping function makes the whole excel table slow/unresponsive

问题描述

我有一个从excel列表中ping计算机并获取它们的ping值的功能。

当脚本运行时，excel完全无响应。我可以用 DoEvents 来解决这个问题，这样做有点更加敏感。

但是，当函数到达离线计算机时，问题开始。当它等待离线PC的响应时，Excel再次冻结，脚本不会跳到下一个PC，直到它从实际的超时为止。由于默认ping超时值为4000ms，如果我的列表中有100台计算机，其中50个被关闭，那意味着我必须等待一个额外的3 ，脚本完成3分钟，也可以阻止整个Excel，使其持续不能使用。

我的问题是，如果有什么办法让这个更快或更灵敏或更智能？

实际代码：

功能：

 函数sPing（sHost）As String 
 
 Dim oPing As Object，oRetStatus As Object 
 
设置oPing = GetObject（winmgmts：{impersonationLevel = impersonate}）。ExecQuery _ 
（select * from Win32_PingStatus where address ='& sHost&'）
 DoEvents 
每个oRetStatus在oPing 
 DoEvents 
如果IsNull（oRetStatus.StatusCode）或oRetStatus.StatusCode<> 0然后
 sPing =timeout'oRetStatus.StatusCode<  - 错误代码
 Else 
 sPing = sPing& vbTab& oRetStatus.ResponseTime 
结束如果
下一个
结束函数
  

主：

  Sub pingall_Click（）
 Dim c As Range 
 Dim p As String 
 Dim活动As String 
 
 actives = ActiveSheet.Name 
 
 StopCode = False 
 
 Application.EnableCancelKey = xlErrorHandler 
错误GoTo ErrH：
 DoEvents 
对于每个c In Sheets（活动）.UsedRange.Cells 
如果StopCode = True然后
退出
结束如果
 DoEvents 
如果左（c，7）=172.21。然后
p = sPing（c）
 [...] 
结束如果
下一步c 
结束Sub 
  pre> 
 
解决方案
如注释所述，为防止在每次调用后阻塞，您需要异步调用ping你的功能我将这样做的方式是将您的 sPing（sHost）函数委托给您在临时文件夹中即时创建的VBScript。该脚本看起来像这样，它将IP地址作为命令行参数，并将结果输出到一个文件：
  Dim args，ping，status 
设置ping = GetObject（winmgmts：{impersonationLevel = impersonate}）ExecQuery _ 
（select * from Win32_PingStatus where address ='& Wscript.Arguments 0）&'）
 Dim result 
对于每个状态在ping 
如果IsNull（status.StatusCode）或status.StatusCode<> 0然后
 result =timeout
 Else 
 result = result& vbTab& status.ResponseTime 
 End If 
 Next 
 Dim fso，file 
设置fso = CreateObject（Scripting.FileSystemObject）
设置文件= fso.CreateTextFile（Wscript。参数（0），True）
 file.Write result 
 file.Close 
  
您可以创建一个Sub将其写入如下路径：
  Private Sub WriteScript（路径As String）
 Dim handle As Integer 
 handle = FreeFile 
打开路径& ScriptName输出为#handle 
打印#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& _ 
每个状态在ping& vbCrLf& _ 
If IsNull（status.StatusCode）or status.StatusCode<> 0然后& vbCrLf& _ 
result =timeout& vbCrLf& _ 
其他& vbCrLf& _ 
result = result& vbTab& status.ResponseTime& vbCrLf& _ 
End If& vbCrLf& _ 
下一个& vbCrLf& _ 
Dim fso，file& vbCrLf& _ 
Set fso = CreateObject（Scripting.FileSystemObject）& vbCrLf& _ 
设置文件= fso.CreateTextFile（Wscript.Arguments（0），True）& vbCrLf& _ 
file.Write result& vbCrLf& _ 
file.Close
关闭#handle 
 End Sub 
  
之后，它非常简单 - 在用户的临时目录中创建一个新的目录，然后在其中打开脚本，然后使用Shell命令在其自己的进程中运行每个ping。等待你的超时时间，然后从文件中读取结果：
  Private Const TempDir =\PingResults\ 
 Private Const ScriptName As String =ping.vbs
'重要 - 将其设置为ping超时的秒数。 
 Private Const Timeout = 4 
 
 Sub pingall_Click（）
 Dim sheet As Worksheet 
 Set sheet = ActiveSheet 
 
 Dim path As String 
'创建要使用的临时文件夹。 
 path = Environ（Temp）& TempDir 
 MkDir路径
'将脚本写入临时文件夹。 
 WriteScript路径
 
 Dim results As Dictionary 
设置结果=新字典
 
 Dim index As Long 
 Dim ip As Variant 
 Dim命令As String 
对于index = 1 To sheet.UsedRange.Rows.Count 
 ip = sheet.Cells（index，1）
如果Len（ip）> = 7 Then 
如果左$（ip，1）=172.21。然后
'缓存它所在的行
 results.Add ip，index 
'Shell脚本。 
 command =wscript&路径& ping.vbs& ip 
 Shell命令，vbNormalFocus 
如果
结束If 
下一个索引
 
 Dim completed As Double 
 completed = Timer + Timeout 
'等待超时
做定时器&完成
 DoEvents 
循环
 
 Dim handle As String，ping As String，result As String 
'循环生成文件并更新工作表。 
对于每个ip在results.Keys 
 result = Dir $（path& ip）
如果Len（result）<> 0然后
 handle = FreeFile 
打开路径& ip For Input As #handle 
 ping = Input $（LOF（handle），handle）
关闭#handle 
杀死路径& ip 
 Else 
 ping =timeout
 End If 
 sheet.Cells（results（ip），2）= ping 
下一个ip 
 
'清理
杀死路径& *
 RmDir路径
 End Sub 
  
请注意，这完全为零错误处理文件操作，并且不响应您的 StopCode 标志。它应该给它的基本要点。另请注意，如果您需要允许用户取消它，您将无法删除临时目录，因为它仍将被使用。如果是这种情况，只有在没有的情况下才能创建它，而在完成后不会删除它。
 
I have a function that pings computers from an excel list and gets the ping value of them. 

While the script was running, the excel was completely unresponsive. I could fix this with DoEvents, this made it a bit more responsive. 

However, the problem starts when the function gets to an offline computer. While it waits for the response of the offline PC, Excel freezes again and the script does not jump to the next PC until it gets the "timeout" from the actual one. 

As the default ping timeout value is 4000ms, if I have 100 computers in my list, and 50 of them are turned off, that means I have to wait an extra 3,3 minutes for the script to finish, and also blocks the entire Excel, making it unusable for the duration.

My question is, if is there any way to make this faster or more responsive or smarter?

The actual code:

Function:
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
Main:
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

解决方案
As already noted in the comments, to prevent this from blocking after each call, you need to invoke your pings asynchronously from your function. The way I would approach this would be to delegate your sPing(sHost) function to a VBScript that you create on the fly in a temp folder.  The script would look something like this, and it takes the IP address as a command line argument and outputs the result to a file:
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
You can create a Sub to write this to a path something like this:
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
After that, it's pretty straightforward - create a new directory in the user's temp directory, plop the script in there, and then use the Shell command to run each ping in its own process.  Wait for the length of your timeout, then read the results from the files:
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
Note that this has exactly zero error handling for the file operations, and doesn't respond to your StopCode flag.  It should give the basic gist of it though.  Also note that if you need to allow the user to cancel it, you won't be able to remove the temp directory because it will still be in use.  If that is the case, only create it if it isn't already there and don't remove it when you're done.

                        
这篇关于Ping功能使整个excel表缓慢/无响应的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！