NetworkObject.MapNetworkDriveのTimeOutを設定する

Question

複数のServerShareを検索するときに「NetworkObject.MapNetworkDrive」を実行する際に問題があります。 ServerShare PCがオンラインの場合、コードは正常に動作し、5秒未満で応答しますが、ServerShare PCがオフラインの場合、コードはタイムアウト（デフォルトTimeOut）に30秒かかります。私はすでにランタイムエラーのエラー処理を設定しました。

"NetworkObject.MapNetworkDrive"で5秒間のタイムアウトを設定するコードはありますか？

私はドメイン上に300を超えるServerShare PCを持っています。 PCがオフラインの場合

Private Sub pbCheck_Click() 

i = 12 
Do 
    If Sheets("Update Checker").Cells(2, 8) <> "" And Sheets("Update Checker").Cells(i, 10) <> "" Then 
     ServerShare = "\\" & Sheets("Update Checker").Cells(i, 10) & "\c$\Windows\servicing\Packages" 
     UserName = Sheets("Update Checker").Cells(i, 10) & "\Administrator" 
     Password = "P@ssw0rd245" 

    Set NetworkObject = CreateObject("WScript.Network") 
    Set FSO = CreateObject("Scripting.FileSystemObject") 

    On Error GoTo ErrCol 
    NetworkObject.MapNetworkDrive "", ServerShare, False, UserName, Password 

    Test = "\\" & Sheets("Update Checker").Cells(i, 10) & "\c$\Windows\servicing\Packages\" & "*" & Sheets("Update Checker").Cells(2, 8) & "*" & ".cat" 

    If Dir(Test) <> "" Then 
     Sheets("Update Checker").Cells(i, 11) = "OK" 
    Else 
     Sheets("Update Checker").Cells(i, 11) = "X" 
    End If 

    Set Filename = Nothing 
    Set Directory = Nothing 
    Set FSO = Nothing 

    NetworkObject.RemoveNetworkDrive ServerShare, True, False 

    Set ShellObject = Nothing 
    Set NetworkObject = Nothing 

End If 
NextCol: 
    i = i + 1 
    Loop Until Sheets("Update Checker").Cells(i, 10) = "" 

ErrCol: 
Resume NextCol 

End Sub 

私のコードは、30秒間NetworkObject.MapNetworkDrive "", ServerShare, False, UserName, Passwordで立ち往生：

は、ここに私のコードです。

ありがとうございます。

Answer 1

私は既に問題を解決しています。私はPCのオンラインまたはオフラインを確認するためにPINGコマンドを実行しています。それぞれのPCを確認するのに4秒かかり、オンラインとオフラインPC用にはSelect Caseを作成します。ここに私のコード。

Private Sub pbCheck_Click() 

i = 12 
Do 
    If Sheets("Update Checker").Cells(2, 8) <> "" And Sheets("Update Checker").Cells(i, 10) <> "" Then 
     ServerShare = "\\" & Sheets("Update Checker").Cells(i, 10) & "\c$\Windows\servicing\Packages" 
     UserName = Sheets("Update Checker").Cells(i, 10) & "\Administrator" 
     Password = "P@ssw0rd245" 

     Set NetworkObject = CreateObject("WScript.Network") 
     Set FSO = CreateObject("Scripting.FileSystemObject") 

     Test = "\\" & Sheets("Update Checker").Cells(i, 10) & "\c$\Windows\servicing\Packages\" & "*" & Sheets("Update Checker").Cells(2, 8) & "*" & ".cat" 

     hostname = Sheets("Update Checker").Cells(i, 10) 
     Set WshShell = CreateObject("WScript.Shell") 
     Ping = WshShell.Run("ping -n 1 " & hostname, 0, True) 
     Select Case Ping 
     Case 0 

      On Error GoTo ErrCol 
      NetworkObject.MapNetworkDrive "", ServerShare, False, UserName, Password 

      If Dir(Test) <> "" Then 
       Sheets("Update Checker").Cells(i, 11) = "OK" 
      Else 
       Sheets("Update Checker").Cells(i, 11) = "X" 
      End If 

      Set Filename = Nothing 
      Set Directory = Nothing 
      Set FSO = Nothing 

      NetworkObject.RemoveNetworkDrive ServerShare, True, False 

      Set ShellObject = Nothing 
      Set NetworkObject = Nothing 

     Case 1 
      GoTo NextCol 
     End Select 
    End If 
NextCol: 
    i = i + 1 
Loop Until Sheets("Update Checker").Cells(i, 10) = "" 

Exit Sub 

ErrCol: 
Resume NextCol 

End Sub