Re : Feuille avec Maitre/Détails
Bonjour à tous et toutes,
Je voulais partager avec vous un bout de code qui sert à savoir si la connexion réseau est présente ou non. Après quelques recherches, j'ai mixé le tout dans ce qui suit. En espérant que cela vous aidera.
Désoler pour le formattage, je ne sais pas faire pour inserer un code
Cordialement
' Attention API Externes et types pour les API ===========================================
' a mettre dans un module
' ============================================================================
Private Declare PtrSafe Function WSAStartup Lib "WSOCK32.DLL" (ByVal wVersionRequired As Long, lpWSADATA As WSADATA) As Long
Private Declare PtrSafe Function WSACleanup Lib "WSOCK32.DLL" () As Long
Public Declare PtrSafe Function inet_addr Lib "WSOCK32.DLL" (ByVal cp As String) As Long
Public Declare PtrSafe Function IcmpCreateFile Lib "icmp.dll" () As Long
Public Declare PtrSafe Function IcmpCloseHandle Lib "icmp.dll" (ByVal IcmpHandle As Long) As Long
Private Declare PtrSafe Function IcmpSendEcho Lib "icmp.dll" (ByVal IcmpHandle As Long, _
ByVal DestinationAddress As Long, _
ByVal RequestData As String, _
ByVal RequestSize As Long, _
ByVal RequestOptions As Long, _
ReplyBuffer As ICMP_ECHO_REPLY, _
ByVal ReplySize As Long, _
ByVal Timeout As Long) As Long
Private Const MAX_WSADescription As Long = 256
Private Const MAX_WSASYSStatus As Long = 128
Private Const WS_VERSION_REQD As Long = &H101
Private Const ICMP_SUCCESS As Long = 0
Private Type WSADATA
wVersion As Integer
wHighVersion As Integer
szDescription(0 To MAX_WSADescription) As Byte
szSystemStatus(0 To MAX_WSASYSStatus) As Byte
wMaxSockets As Long
wMaxUDPDG As Long
dwVendorInfo As Long
End Type
Private Type IP_OPTION_INFORMATION
Ttl As Byte
Tos As Byte
Flags As Byte
OptionsSize As Byte
OptionsData As Long
End Type
Public Type ICMP_ECHO_REPLY
Address As Long
Status As Long
RoundTripTime As Long
DataSize As Long
Reserved As Integer
ptrData As Long
Options As IP_OPTION_INFORMATION
data As String * 250
End Type
' ==================================================================================
' Déclaration des variables globales
' ==================================================================================
' -> Remplacez par vos valeurs
Public Const gDirRes = "\\Serveur'\Repertroire\" 'Repertoire réseau ('\' obligatoire)
private Const gIpaSrv = "xx.xxx.x.xxx" 'Adresse IP du serveur
' ==============================================================================
' Exemple d'utilisation
' ==============================================================================
If Not CtrlReseau(gDirRes, gIpaSrv) Then
wMesErr = "Vous n'êtes pas connecté au réseau ou la connexion n'est pas disponible. "
MsgBox wMesErr, vbCritical + vbOKOnly, "Erreur Application"
Exit Sub
End If
'+--------------------------------------------------------------------------+
'! Controle la connexion réseau !
'! sNetDir : Un répertoire sur le serveur !
'! sNetAip : Adresse Ip du serveur !
'+--------------------------------------------------------------------------+
Private Function CtrlReseau(sNetDir As String, sNetAip As String) As Boolean
Dim bFlgRes As Boolean
Dim InitSocket As Boolean
Dim StsSuccess As Long
'Variables pour le control du serveur
Dim Reply As ICMP_ECHO_REPLY
Dim sServer As String
Dim WSAD As WSADATA
If sNetDir = "" Or sNetAip = "" Then
MsgBox "CtrlReseau : Erreur Arguments" & Chr(10) & "Contacter le 'xxx' ", vbCritical + vbOKOnly, "Erreur Application"
CtrlReseau = False
Exit Function
End If
bFlgRes = False
'Récupération du nom du serveur à partir du nom du repertoire des données
gNomSrv = Mid$(sNetDir, 3, InStr(3, sNetDir, "\", vbTextCompare) - 3)
'Préparation configuration (Sockets) pour le contrôle réseau
InitSocket = WSAStartup(WS_VERSION_REQD, WSAD) = ICMP_SUCCESS
If InitSocket Then
StsSuccess = PingAdrIp(sNetAip, Reply) 'Ping de l'adresse IP avec retour du status
Call WSACleanup 'Clear des sockets.
If StsSuccess = 0 Then
bFlgRes = True 'Si retour d'un ping, c'est OK
End If
End If
CtrlReseau = bFlgRes
End Function
'+--------------------------------------------------------------------------+
'! Controle la connection réseau via l'envoi d'un ping !
'! sAdrIp : Adresse Ip du serveur !
'! Reply : Structure du retour du ping !
'+--------------------------------------------------------------------------+
Private Function PingAdrIp(sAdrIp As String, Reply As ICMP_ECHO_REPLY) As Long
'Function to ping an address and see if a response is obtained
Dim hIcmp As Long
Dim lAddress As Long
Dim lTimeOut As Long
Dim StringToSend As String
'Chaine de donnée courte à transmettre
StringToSend = "test"
'Timeout en ms
lTimeOut = 1000 'ICMP (ping)
'Convertir la chaine adresse en représentation long
lAddress = inet_addr(sAdrIp)
'Si nou avons une réponse valide
If (lAddress <> -1) And (lAddress <> 0) Then
'Créer le Handle pour les demandes ICMP.
hIcmp = IcmpCreateFile()
If hIcmp Then
'Ping l'adresse IP destination.
Call IcmpSendEcho(hIcmp, lAddress, StringToSend, Len(StringToSend), 0, Reply, Len(Reply), lTimeOut)
'Statut de retour
PingAdrIp = Reply.Status
'Fermer la handle de ICMP.
IcmpCloseHandle hIcmp
Else
MsgBox "Ping : Erreur ouverture du Handle ICPM" & Chr(10) & "Contacter le 'xxx'", vbCritical + vbOKOnly, "Erreur Application"
PingAdrIp = -1
End If
Else
PingAdrIp = -1
End If
End Function