XL 2019 Tester l'existence d'un répertoire avant exécution macro

[hctad1]

Bonjour à tous,

je suis en train de faire un petit machin avec
Application.GetOpenFilename() et Worksheet_BeforeDoubleClick

comme je suis fainéant, je veux ouvrir dans le bon répertoire direct.
ça c'est facile.

là ou ça se complique, c'est que c'est un lecteur réseau que j'appelle par son IP locale:
\\192.168.1.105\mon_repertoire

Or comme je suis souvent en vpn, il peut arriver que je ne sois pas connecté et donc que 192.168.1.105 ne réponde pas.

Pour éviter que la macro se retrouve bloquée à attendre une réponse, je voudrais pouvoir tester (faire un ping en somme) sur le répertoire avant d'ouvrir la boite de dialogue.

Avez-vous une idée à me donner ?

Merci d'avance pour vos pistes.
Nicolas

 

[kiki29]

Salut, de la lecture : Manipulation des fichiers en VBA

 

[hctad1]

Merci.
honte sur moi, j'ai vous posé la question avant d'interroger l'oracle google.

Public Function DossierExiste(MonDossier As String)


If Len(Dir(MonDossier, vbDirectory)) > 0 Then
DossierExiste = True
Else
DossierExiste = False
End If
End Function

 

[hctad1]

Morale de l'histoire.
la solution au dessus laisse la macro en attente trop longtemps.
Je passe par un ping, ça m'a l'air plus rapide.


'https://stackoverflow.com/questions...ess-with-vba-code-and-return-results-in-excel
Public Function GetPingResult(Host) As String
Dim objPing As Object, objStatus As Object
Dim strResult As String
Set objPing = GetObject("winmgmts:{impersonationLevel=impersonate}"). _
ExecQuery("Select * from Win32_PingStatus Where Address = '" & Host & "'")

avec un ajout de timeout dans la query, c'est tout bon.
ExecQuery("Select * from Win32_PingStatus Where Timeout = 100 and Address = '" & Host & "'")


For Each objStatus In objPing
Select Case objStatus.StatusCode
Case 0: strResult = "Connected " & objStatus.ProtocolAddress
Case 11001: strResult = "Buffer too small"
Case 11002: strResult = "Destination net unreachable"
Case 11003: strResult = "Destination host unreachable"
Case 11004: strResult = "Destination protocol unreachable"
Case 11005: strResult = "Destination port unreachable"
Case 11006: strResult = "No resources"
Case 11007: strResult = "Bad option"
Case 11008: strResult = "Hardware error"
Case 11009: strResult = "Packet too big"
Case 11010: strResult = "Request timed out"
Case 11011: strResult = "Bad request"
Case 11012: strResult = "Bad route"
Case 11013: strResult = "Time-To-Live (TTL) expired transit"
Case 11014: strResult = "Time-To-Live (TTL) expired reassembly"
Case 11015: strResult = "Parameter problem"
Case 11016: strResult = "Source quench"
Case 11017: strResult = "Option too big"
Case 11018: strResult = "Bad destination"
Case 11032: strResult = "Negotiating IPSEC"
Case 11050: strResult = "General failure"
Case Else: strResult = "Unknown host"
End Select
GetPingResult = strResult
Next
Set objPing = Nothing
End Function



'Exemple d'appel :
Sub EssaiPing()
Dim S As String
S = GetPingResult("192.168.1.104")
If Left(S, 10) = "Connected " Then
MsgBox "Lecteur connecté"
Else
MsgBox "Lecteur non connecté"
End If
End Sub