Discussion :

[Tyloo2015]

Bonjour
je tente de récupérer mon adresse MAC par le code suivant:

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
Public Function GetMACAddress() As String
Dim tmp As String
Dim pASTAT As Long
Dim NCB As NET_CONTROL_BLOCK
Dim AST As ASTAT
 
NCB.ncb_command = NCBRESET
Call Netbios(NCB)
 
NCB.ncb_callname = "* "
NCB.ncb_command = NCBASTAT
 
NCB.ncb_lana_num = 0
NCB.ncb_length = Len(AST)
pASTAT = HeapAlloc(GetProcessHeap(), _
HEAP_GENERATE_EXCEPTIONS Or _
HEAP_ZERO_MEMORY, _
NCB.ncb_length)
If pASTAT = 0 Then
Debug.Print "memory allocation failed!"
Exit Function
End If
NCB.ncb_buffer = pASTAT
Call Netbios(NCB)
CopyMemory AST, NCB.ncb_buffer, Len(AST)
tmp = Right$("00" & Hex(AST.adapt.adapter_address(0)), 2) & "." & _
Right$("00" & Hex(AST.adapt.adapter_address(1)), 2) & "." & _
Right$("00" & Hex(AST.adapt.adapter_address(2)), 2) & "." & _
Right$("00" & Hex(AST.adapt.adapter_address(3)), 2) & "." & _
Right$("00" & Hex(AST.adapt.adapter_address(4)), 2) & "." & _
Right$("00" & Hex(AST.adapt.adapter_address(5)), 2)
HeapFree GetProcessHeap(), 0, pASTAT
GetMACAddress = tmp
End Function

... le probleme est que la variable tmp ne renvoie que des "0" et la fonction AST.adapt.adapter_address() aussi .... qqun peut il m'aider à résoudre le pb SVP ?

[kiki29]

Salut, à tester ?

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
Option Explicit
 
Private Const MIB_IF_TYPE_OTHER As Long = 1
Private Const MIB_IF_TYPE_ETHERNET As Long = 6
Private Const MIB_IF_TYPE_TOKENRING As Long = 9
Private Const MIB_IF_TYPE_FDDI As Long = 15
Private Const MIB_IF_TYPE_PPP As Long = 23
Private Const MIB_IF_TYPE_LOOPBACK As Long = 24
Private Const MIB_IF_TYPE_SLIP As Long = 28
 
Private Const MIB_IF_ADMIN_STATUS_UP As Long = 1
Private Const MIB_IF_ADMIN_STATUS_DOWN As Long = 2
Private Const MIB_IF_ADMIN_STATUS_TESTING As Long = 3
 
Private Const MIB_IF_OPER_STATUS_NON_OPERATIONAL As Long = 0
Private Const MIB_IF_OPER_STATUS_UNREACHABLE As Long = 1
Private Const MIB_IF_OPER_STATUS_DISCONNECTED As Long = 2
Private Const MIB_IF_OPER_STATUS_CONNECTING As Long = 3
Private Const MIB_IF_OPER_STATUS_CONNECTED As Long = 4
Private Const MIB_IF_OPER_STATUS_OPERATIONAL As Long = 5
 
Private Const MAX_ADAPTER_DESCRIPTION_LENGTH As Long = 128
Private Const MAX_ADAPTER_DESCRIPTION_LENGTH_p As Long = MAX_ADAPTER_DESCRIPTION_LENGTH + 4
Private Const MAX_ADAPTER_NAME_LENGTH As Long = 256
Private Const MAX_ADAPTER_NAME_LENGTH_p As Long = MAX_ADAPTER_NAME_LENGTH + 4
Private Const MAX_ADAPTER_ADDRESS_LENGTH As Long = 8
Private Const DEFAULT_MINIMUM_ENTITIES As Long = 32
Private Const MAX_HOSTNAME_LEN As Long = 128
Private Const MAX_DOMAIN_NAME_LEN As Long = 128
Private Const MAX_SCOPE_ID_LEN As Long = 256
 
Private Const MAXLEN_IFDESCR As Long = 256
Private Const MAX_INTERFACE_NAME_LEN As Long = MAXLEN_IFDESCR * 2
Private Const MAXLEN_PHYSADDR As Long = 8
 
Private Type MIB_IFROW
    wszName(0 To MAX_INTERFACE_NAME_LEN - 1) As Byte
    dwIndex As Long
    dwType As Long
    dwMtu As Long
    dwSpeed As Long
    dwPhysAddrLen As Long
    bPhysAddr(MAXLEN_PHYSADDR - 1) As Byte
    dwAdminStatus As Long
    dwOperStatus As Long
    dwLastChange As Long
    dwInOctets As Long
    dwInUcastPkts As Long
    dwInNUcastPkts As Long
    dwInDiscards As Long
    dwInErrors As Long
    dwInUnknownProtos As Long
    dwOutOctets As Long
    dwOutUcastPkts As Long
    dwOutNUcastPkts As Long
    dwOutDiscards As Long
    dwOutErrors As Long
    dwOutQLen As Long
    dwDescrLen As Long
    bDescr As String * MAXLEN_IFDESCR
End Type
 
Private Type TIME_t
    aTime As Long
End Type
 
Private Type IP_ADDRESS_STRING
    IPadrString As String * 16
End Type
 
Private Type IP_ADDR_STRING
    AdrNext As Long
    IpAddress As IP_ADDRESS_STRING
    IpMask As IP_ADDRESS_STRING
    NTEcontext As Long
End Type
 
Private Type IP_ADAPTER_INFO
    Next As Long
    ComboIndex As Long
    AdapterName As String * MAX_ADAPTER_NAME_LENGTH_p
    Description As String * MAX_ADAPTER_DESCRIPTION_LENGTH_p
    MACadrLength As Long
    MACaddress(0 To MAX_ADAPTER_ADDRESS_LENGTH - 1) As Byte
    AdapterIndex As Long
    AdapterType As Long
    DhcpEnabled As Long
    CurrentIpAddress As Long
    IpAddressList As IP_ADDR_STRING
    GatewayList As IP_ADDR_STRING
    DhcpServer As IP_ADDR_STRING
    HaveWins As Long
    PrimaryWinsServer As IP_ADDR_STRING
    SecondaryWinsServer As IP_ADDR_STRING
    LeaseObtained As TIME_t
    LeaseExpires As TIME_t
End Type
 
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
                               ByRef Destination As Any, ByRef Source As Any, ByVal numbytes As Long)
 
Public Declare Function GetAdaptersInfo Lib "iphlpapi.dll" (ByRef pAdapterInfo As Any, ByRef pOutBufLen As Long) As Long
Public Declare Function GetNumberOfInterfaces Lib "iphlpapi.dll" (ByRef pdwNumIf As Long) As Long
Public Declare Function GetIfEntry Lib "iphlpapi.dll" (ByRef pIfRow As Any) As Long
Private Declare Function GetIfTable Lib "iphlpapi.dll" _
                                    (ByRef pIfTable As Any, ByRef pdwSize As Long, ByVal bOrder As Long) As Long
 
Public Function GetMACs_AdaptInfo() As String
Dim AdapInfo As IP_ADAPTER_INFO, bufLen As Long, sts As Long
Dim retStr As String, numStructs%, i%, IPinfoBuf() As Byte, srcPtr As Long
 
    sts = GetAdaptersInfo(AdapInfo, bufLen)
    If (bufLen = 0) Then Exit Function
    numStructs = bufLen / Len(AdapInfo)
    retStr = numStructs & " Adapter(s):" & vbCrLf
 
    ReDim IPinfoBuf(0 To bufLen - 1) As Byte
    sts = GetAdaptersInfo(IPinfoBuf(0), bufLen)
    If (sts <> 0) Then Exit Function
 
    srcPtr = VarPtr(IPinfoBuf(0))
    For i = 0 To numStructs - 1
        If (srcPtr = 0) Then Exit For
        CopyMemory AdapInfo, ByVal srcPtr, Len(AdapInfo)
 
        With AdapInfo
            If (.AdapterType = MIB_IF_TYPE_ETHERNET) Then
                retStr = retStr & vbCrLf & "[" & i & "] " & sz2string(.Description) _
                         & vbCrLf & vbTab & MAC2String(.MACaddress) & vbCrLf
            End If
        End With
        srcPtr = AdapInfo.Next
    Next i
    GetMACs_AdaptInfo = retStr
End Function
 
Public Function GetMACs_IfTable() As String
Dim NumAdapts As Long, nRowSize As Long, i%, retStr As String
Dim IfInfo As MIB_IFROW, IPinfoBuf() As Byte, bufLen As Long, sts As Long
 
    sts = GetNumberOfInterfaces(NumAdapts)
 
    sts = GetIfTable(ByVal 0&, bufLen, 1)
    If (bufLen = 0) Then Exit Function
 
    ReDim IPinfoBuf(0 To bufLen - 1) As Byte
    sts = GetIfTable(IPinfoBuf(0), bufLen, 1)
    If (sts <> 0) Then Exit Function
 
    NumAdapts = IPinfoBuf(0)
    nRowSize = Len(IfInfo)
    retStr = NumAdapts & " Interface(s):" & vbCrLf
 
    For i = 1 To NumAdapts
        Call CopyMemory(IfInfo, IPinfoBuf(4 + (i - 1) * nRowSize), nRowSize)
 
        With IfInfo
            retStr = retStr & vbCrLf & "[" & i & "] " & Left$(.bDescr, .dwDescrLen - 1) & vbCrLf
            If (.dwType = MIB_IF_TYPE_ETHERNET) Then
                retStr = retStr & vbTab & MAC2String(.bPhysAddr) & vbCrLf
            End If
        End With
    Next i
 
    GetMACs_IfTable = retStr
 
End Function
 
Private Function MAC2String(AdrArray() As Byte) As String
Dim aStr As String, hexStr As String, i%
 
    For i = 0 To 5
        If (i > UBound(AdrArray)) Then
            hexStr = "00"
        Else
            hexStr = Hex$(AdrArray(i))
        End If
 
        If (Len(hexStr) < 2) Then hexStr = "0" & hexStr
        aStr = aStr & hexStr
        If (i < 5) Then aStr = aStr & "-"
    Next i
 
    MAC2String = aStr
End Function
 
Private Function sz2string(ByVal szStr As String) As String
    sz2string = Left$(szStr, InStr(1, szStr, Chr$(0)) - 1)
End Function

Code :

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

1
2
3
Sub Tst()
    MsgBox GetMACs_AdaptInfo()
End Sub

Une autre possibilité

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
Option Explicit
 
Sub MacAdressVBS()
Dim objNetwork, objWMIService, strComputer, wshShell
Dim strUser, colGroups, colItems, objItem, FindInfo, L2Chr, sMss
    Set objNetwork = CreateObject("Wscript.Network")
    strComputer = objNetwork.ComputerName
    Set wshShell = CreateObject("WScript.Shell")
    Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\cimv2")
    strUser = wshShell.ExpandEnvironmentStrings("%USERNAME%")
    Set colItems = objWMIService.ExecQuery("Select * From Win32_NetworkAdapterConfiguration Where IPEnabled = True")
 
    For Each objItem In colItems
        FindInfo = objItem.MACaddress
    Next
 
    L2Chr = Split(FindInfo, ":")(5)
    sMss = sMss & "NOM ORDINATEUR :" & Space(7) & strComputer & vbLf
    sMss = sMss & "NOM UTILISATEUR :" & Space(8) & strUser & vbLf
    sMss = "Nic MAC Adress : " & FindInfo & vbLf
 
    MsgBox sMss, vbInformation + vbOKOnly, "INFORMATIONS"
 
    Set objNetwork = Nothing
    Set objWMIService = Nothing
    Set wshShell = Nothing
End Sub

P.-S. : Balise ton code

[Tyloo2015]

Salut, voir ici ?

un autre pb : en copitan-collant ton code dans VB la partie du code ci-dessous apparait en rouge dans VB

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
Private Declare Function Netbios Lib "netapi32" (pncb As NET_CONTROL_BLOCK) As Byte
 
Private Declare Sub CopyMemory Lib "kernel32" _
     Alias "RtlMoveMemory" (hpvDest As Any, ByVal hpvSource As Long, ByVal cbCopy As Long)
 
Private Declare Function GetProcessHeap Lib "kernel32" () As Long
 
Private Declare Function HeapAlloc Lib "kernel32" _
    (ByVal hHeap As Long, ByVal dwFlags As Long, ByVal dwBytes As Long) As Long
 
Private Declare Function HeapFree Lib "kernel32" _
    (ByVal hHeap As Long, ByVal dwFlags As Long, lpMem As Any) As Long

... avec le message d'erreur suivant quand je lance :" erreur de compilation ... le code doit etre mis à jour pour etre utilisé en 64 bits. vérifier et corriger les instructions Declare et marquez les avec l'attribut PtrSafe" .... ce que je fais mais mon pb persiste

[kiki29]

Salut, à toi de voir et appliquer : Développer avec Office 64 bits

Même si Microsoft déconseille l'installation d'une version 64 bits d'Office.

Office 32 bits est recommandé pour la plupart des utilisateurs
Nous recommandons la version 32 bits d’Office pour la plupart des utilisateurs, car elle offre une plus grande compatibilité avec la plupart des autres applications, en particulier les compléments tiers. C’est la raison pour laquelle la version 32 bits d’Office 2013 est installée par défaut, même sur les systèmes d’exploitation Windows 64 bits. Sur ces systèmes, le client Office 32 bits est pris en charge en tant qu’installation Windows-32-on-Windows-64 (WOW64). WOW64 est l’émulateur x86 qui permet l’exécution de façon transparente des applications Windows 32 bits sur les systèmes Windows 64 bits. Cela permet aux utilisateurs de continuer à utiliser les contrôles ActiveX et les compléments COM Microsoft avec la version 32 bits d’Office.

P.-S. : Balise ton code

En plus ici ce n'est pas un forum VBA !

[Tyloo2015]

bon ok merci :-) ... je suis un peu de la baise quoi ! :-)

[kiki29]

Salut, installer la version 32 bits ? car sinon : pas de bras pas de chocolat .....

P.-S. : Balise ton code