[Fait]Récupérer l'adresse MAC d'un PC distant [FAQ]

**cbleas** · 05/03/2007, 22h48

Bonjour,
encore un mouton à cinq pattes mais je souhaite récupérer les données concernant le PC ou se trouve le fichier Backend
Je souhaite connaitre le numéro Mac ou le numéro du microprocesseur du pc ou serveur distant.

J'ai donc créé des fonctions dans le fichier backend mais celle ci ne fonctionne pas par ADO. Est ce normal et comment puis je faire pour récupérer les données dont j'ai besoin?

merci

**Faw** · 06/03/2007, 03h30

Salut,
pour l'adresse MAC il y a ceci

**cbleas** · 06/03/2007, 07h31

Bonjour,
je n'ai aucun problème pour avoir les adresses mac de l'ordinateur ou est mis le programme frontend. Le Problème est que je souhaite avoir les informations sur le PC ou est stocké le Fichier Backend. Cela doit me permettre de de créer un numéro de série unique sur l'ensemble du réseau.

Merci FAW

**Arkham46** · 06/03/2007, 10h25

Voilà un module pour récupérer une addresse MAC distante :
(sûrement à améliorer un peu sur la gestion d'erreurs, mais le principe est là)

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
Option Explicit
 
' Déclarations pour GetRemoteMACAddress
Private Declare Function inet_addr Lib "WSOCK32.DLL" _
  (ByVal s As String) As Long
Private Declare Function SendARP Lib "iphlpapi.dll" _
  (ByVal DestIP As Long, _
   ByVal SrcIP As Long, _
   pMacAddr As Long, _
   PhyAddrLen As Long) As Long
Private Declare Sub CopyMemory Lib "KERNEL32" _
   Alias "RtlMoveMemory" _
  (dst As Any, _
   src As Any, _
   ByVal bcount As Long)
' Déclarations pour LetterToUNC
Private Const RESOURCETYPE_ANY = &H0
Private Const RESOURCE_CONNECTED = &H1
 
Private Type NETRESOURCE
   dwScope As Long
   dwType As Long
   dwDisplayType As Long
   dwUsage As Long
   lpLocalName As Long
   lpRemoteName As Long
   lpComment As Long
   lpProvider As Long
End Type
Private Declare Function WNetOpenEnum Lib "mpr.dll" Alias _
   "WNetOpenEnumA" (ByVal dwScope As Long, ByVal dwType As Long, _
   ByVal dwUsage As Long, lpNetResource As Any, lphEnum As Long) _
   As Long
Private Declare Function WNetEnumResource Lib "mpr.dll" Alias _
   "WNetEnumResourceA" (ByVal hEnum As Long, lpcCount As Long, _
   lpBuffer As Any, lpBufferSize As Long) As Long
Private Declare Function WNetCloseEnum Lib "mpr.dll" ( _
   ByVal hEnum As Long) As Long
Private Declare Function lstrlen Lib "KERNEL32" Alias "lstrlenA" _
   (ByVal lpString As Any) As Long
Private Declare Function lstrcpy Lib "KERNEL32" Alias "lstrcpyA" _
   (ByVal lpString1 As Any, ByVal lpString2 As Any) As Long
 
' Déclarations pour LetterToUNC
Private Const WS_VERSION_REQD = &H101
Private Const WS_VERSION_MAJOR = WS_VERSION_REQD \ &H100 And &HFF&
Private Const WS_VERSION_MINOR = WS_VERSION_REQD And &HFF&
Private Const MIN_SOCKETS_REQD = 1
Private Const SOCKET_ERROR = -1
Private Const WSADescription_Len = 256
Private Const WSASYS_Status_Len = 128
 
Private Type HOSTENT
    hName As Long
    hAliases As Long
    hAddrType As Integer
    hLength As Integer
    hAddrList As Long
End Type
 
Private Type WSADATA
    wversion As Integer
    wHighVersion As Integer
    szDescription(0 To WSADescription_Len) As Byte
    szSystemStatus(0 To WSASYS_Status_Len) As Byte
    iMaxSockets As Integer
    iMaxUdpDg As Integer
    lpszVendorInfo As Long
End Type
 
Private Declare Function WSAGetLastError Lib "WSOCK32.DLL" () As Long
Private Declare Function WSAStartup Lib "WSOCK32.DLL" (ByVal _
wVersionRequired As Integer, lpWSAData As WSADATA) As Long
Private Declare Function WSACleanup Lib "WSOCK32.DLL" () As Long
 
Private Declare Function gethostname Lib "WSOCK32.DLL" (ByVal hostname$, _
ByVal HostLen As Long) As Long
Private Declare Function gethostbyname Lib "WSOCK32.DLL" (ByVal _
hostname$) As Long
Private Declare Sub RtlMoveMemory Lib "KERNEL32" (hpvDest As Any, ByVal _
hpvSource&, ByVal cbCopy&)
 
'------------------------------------------------------------------------------
'------------------------------------------------------------------------------
Public Function GetRemoteMACAddress(ByVal pIPDistante As String) As String
Dim lAddr As Long
Dim lMacAddr As Long
Dim lMacAddrByte() As Byte
Dim lPhyAddrLen As Long
Dim lCpt As Integer
' Transforme l'adresse IP texte en adresse IP numérique
lAddr = inet_addr(pIPDistante)
If lAddr <> -1 Then
    ' Taille d'une adresse MAC = 6
    lPhyAddrLen = 6
    ' Recherche l'adresse MAC distante
    If SendARP(lAddr, 0&, lMacAddr, lPhyAddrLen) = 0 Then
        If (lMacAddr <> 0) And (lPhyAddrLen <> 0) Then
            ' Tableau de byte qui contiendra l'adresse MAC
            ReDim lMacAddrByte(0 To lPhyAddrLen - 1)
            ' Copy l'adresse MAC dans le tableau (lMacAddr est une adresse mémoire)
            CopyMemory lMacAddrByte(0), lMacAddr, ByVal lPhyAddrLen
            ' Converti l'adresse MAC en texte
            GetRemoteMACAddress = ""
            For lCpt = LBound(lMacAddrByte) To UBound(lMacAddrByte)
                GetRemoteMACAddress = GetRemoteMACAddress & Right("00" & Hex(lMacAddrByte(lCpt)), 2) & IIf(lCpt = UBound(lMacAddrByte), "", "-")
            Next
        End If
    End If
End If
End Function
'------------------------------------------------------------------------------
'------------------------------------------------------------------------------
 
'------------------------------------------------------------------------------
'------------------------------------------------------------------------------
' Source KB Microsoft : http://support.microsoft.com/kb/192689/fr
Public Function LetterToUNC(DriveLetter As String) As String
Dim hEnum As Long
Dim NetInfo(1023) As NETRESOURCE
Dim entries As Long
Dim nStatus As Long
Dim LocalName As String
Dim UNCName As String
Dim i As Long
Dim r As Long
 
' Begin the enumeration
nStatus = WNetOpenEnum(RESOURCE_CONNECTED, RESOURCETYPE_ANY, _
   0&, ByVal 0&, hEnum)
 
LetterToUNC = "Drive Letter Not Found"
 
'Check for success from open enum
If ((nStatus = 0) And (hEnum <> 0)) Then
   ' Set number of entries
   entries = 1024
 
   ' Enumerate the resource
   nStatus = WNetEnumResource(hEnum, entries, NetInfo(0), _
      CLng(Len(NetInfo(0))) * 1024)
 
   ' Check for success
   If nStatus = 0 Then
      For i = 0 To entries - 1
         ' Get the local name
         LocalName = ""
         If NetInfo(i).lpLocalName <> 0 Then
            LocalName = Space(lstrlen(NetInfo(i).lpLocalName) + 1)
            r = lstrcpy(LocalName, NetInfo(i).lpLocalName)
         End If
 
         ' Strip null character from end
         If Len(LocalName) <> 0 Then
            LocalName = Left(LocalName, (Len(LocalName) - 1))
         End If
 
         If UCase$(LocalName) = UCase$(DriveLetter) Then
            ' Get the remote name
            UNCName = ""
            If NetInfo(i).lpRemoteName <> 0 Then
               UNCName = Space(lstrlen(NetInfo(i).lpRemoteName) _
                  + 1)
               r = lstrcpy(UNCName, NetInfo(i).lpRemoteName)
            End If
 
            ' Strip null character from end
            If Len(UNCName) <> 0 Then
               UNCName = Left(UNCName, (Len(UNCName) _
                  - 1))
            End If
 
            ' Return the UNC path to drive
            LetterToUNC = UNCName
 
            ' Exit the loop
            Exit For
         End If
      Next i
   End If
End If
 
' End enumeration
nStatus = WNetCloseEnum(hEnum)
End Function
'------------------------------------------------------------------------------
'------------------------------------------------------------------------------
 
'------------------------------------------------------------------------------
'------------------------------------------------------------------------------
' Source KB Microsoft : http://support.microsoft.com/kb/160215/fr
Private Function hibyte(ByVal wParam As Integer)
    hibyte = wParam \ &H100 And &HFF&
End Function
 
Private Function lobyte(ByVal wParam As Integer)
    lobyte = wParam And &HFF&
End Function
 
Private Sub SocketsInitialize()
Dim WSAD As WSADATA
Dim iReturn As Integer
Dim sLowByte As String, sHighByte As String, sMsg As String
    iReturn = WSAStartup(WS_VERSION_REQD, WSAD)
    If iReturn <> 0 Then
        MsgBox "Winsock.dll is not responding."
        End
    End If
    If lobyte(WSAD.wversion) < WS_VERSION_MAJOR Or (lobyte(WSAD.wversion) = _
        WS_VERSION_MAJOR And hibyte(WSAD.wversion) < WS_VERSION_MINOR) Then
        sHighByte = Trim$(Str$(hibyte(WSAD.wversion)))
        sLowByte = Trim$(Str$(lobyte(WSAD.wversion)))
        sMsg = "Windows Sockets version " & sLowByte & "." & sHighByte
        sMsg = sMsg & " is not supported by winsock.dll "
        MsgBox sMsg
        End
    End If
    'iMaxSockets is not used in winsock 2. So the following check is only
    'necessary for winsock 1. If winsock 2 is requested,
    'the following check can be skipped.
    If WSAD.iMaxSockets < MIN_SOCKETS_REQD Then
        sMsg = "This application requires a minimum of "
        sMsg = sMsg & Trim$(Str$(MIN_SOCKETS_REQD)) & " supported sockets."
        MsgBox sMsg
        End
    End If
End Sub
 
Private Sub SocketsCleanup()
Dim lReturn As Long
    lReturn = WSACleanup()
    If lReturn <> 0 Then
        MsgBox "Socket error " & Trim$(Str$(lReturn)) & " occurred in Cleanup "
        End
    End If
End Sub
 
Public Function GetIpFromHost(ByVal pHostName As String) As Variant
Dim hostname As String * 256
Dim hostent_addr As Long
Dim host As HOSTENT
Dim hostip_addr As Long
Dim temp_ip_address() As Byte
Dim i As Integer
Dim ip_address As String
Dim lCpt As Integer
Dim lResult() As String
On Error GoTo Gestion_Erreurs
    SocketsInitialize
    ' Retire le double \
    If Left(pHostName, 2) = "\\" Then
        pHostName = Right(pHostName, Len(pHostName) - 2)
    End If
    ' Retire un éventuel chemin
    If InStr(pHostName, "\") > 0 Then
        pHostName = Left(pHostName, InStr(pHostName, "\") - 1)
    End If
    hostname = Trim$(pHostName & vbNullChar)
    hostent_addr = gethostbyname(hostname)
    If hostent_addr = 0 Then
        MsgBox "Winsock.dll is not responding."
        Exit Function
    End If
    RtlMoveMemory host, hostent_addr, LenB(host)
    RtlMoveMemory hostip_addr, host.hAddrList, 4
    'get all of the IP address if machine is  multi-homed
    lCpt = 0
    Do
        ReDim temp_ip_address(1 To host.hLength)
        RtlMoveMemory temp_ip_address(1), hostip_addr, host.hLength
 
        For i = 1 To host.hLength
            ip_address = ip_address & temp_ip_address(i) & "."
        Next
        ip_address = Mid$(ip_address, 1, Len(ip_address) - 1)
 
        ReDim lResult(lCpt)
        lResult(lCpt) = ip_address
        lCpt = lCpt + 1
        ip_address = ""
        host.hAddrList = host.hAddrList + LenB(host.hAddrList)
        RtlMoveMemory hostip_addr, host.hAddrList, 4
     Loop While (hostip_addr <> 0)
Gestion_Erreurs:
    SocketsCleanup
    GetIpFromHost = lResult
End Function
'------------------------------------------------------------------------------
'------------------------------------------------------------------------------

Il y a trois fonctions :
- LetterToUNC qui transforme une lettre de disque en nom réseau
- GetIpFromHost qui recherche les adresses IP d'un serveur
- GetRemoteMACAddress qui recherche l'addresse MAC à partir d'une IP

A partir de ça on peut faire :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
Function TestMacAddress() As Boolean
Dim lLetter As String
Dim lUNC As String
Dim lIP() As String
Dim lMacAddress As String
Dim lCpt As Integer
On Error GoTo Gestion_Erreurs
lLetter = "Q:"
' Cherche le nom réseau du disque
lUNC = LetterToUNC(lLetter)
' Cherche les addresses IP du serveurs
lIP = GetIpFromHost(lUNC)
' Recherche l'address MAC correspondante à chaque address IP
For lCpt = LBound(lIP) To UBound(lIP)
    lMacAddress = GetRemoteMACAddress(lIP(lCpt))
    ' Test si l'address MAC correspond à celle voulue
    If lMacAddress = "00-54-65-75-5C-4E" Then TestMacAddress = True
Next
Gestion_Erreurs:
If Err.Number <> 0 Then TestMacAddress = False
End Function

Y a juste à rechercher la lettre du disque sur lequel est la base distante (ça doit être plus simple je pense) pour remplacer le "Q:" que j'ai mis en dur dans le code.

Ca marche en windows 2000, mais je n'ai pas fais des tests très poussés.

**cbleas** · 06/03/2007, 11h28

Bonjour,

Merci pour ce code je vais le tester demain

[Fait]Récupérer l'adresse MAC d'un PC distant [FAQ]

Access

Discussions similaires

Partager

Partager