Set TimeOut für NetworkObject.MapNetworkDrive

Question

Ich habe ein Problem beim Ausführen von "NetworkObject.MapNetworkDrive" beim Durchsuchen mehrerer ServerShare. Wenn der ServerShare PC Online ist, funktioniert der Code einwandfrei und es dauert weniger als 5 Sekunden, um zu reagieren. Wenn der ServerShare PC jedoch offline ist, wird der Code 30 Sekunden für das Timeout benötigen (Default TimeOut). Ich habe bereits Fehlerbehandlung für Laufzeitfehler festgelegt.

Gibt es einen Code, um Timeout für 5 Sekunden auf "NetworkObject.MapNetworkDrive" zu setzen?

Ich habe mehr als 300 ServerShare PC auf Domain.

Hier ist mein Code:

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 

Mein Code bei NetworkObject.MapNetworkDrive "", ServerShare, False, UserName, Password für 30 Sekunden stecken, wenn PC-Offline ist.

Vielen Dank.

Answer 1

Ich löse bereits das Problem. Ich führe PING-Befehl, um PC Online oder offline zu überprüfen, es dauert 4 Sekunden, um jeden PC zu überprüfen und Select Case für Online- und Offline-PC zu erstellen. Hier Mein Code.

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