VBA Tipp: MAC-Adresse ermitteln

Aus DBWiki
Wechseln zu: Navigation, Suche

Aufgabenstellung

Es soll die MAC-Adresse des eigenen PCs ermittelt werden.

Lösung

Ohne die Notwendigkeit, eine DOS-Funktion aufrufen zu müssen, mit purem API (W98 bis W2003):

Private Type IP_ADDRESS_STRING
   IpAddr(0 To 15)        As Byte
End Type
 
Private Type IP_MASK_STRING
   IpMask(0 To 15)        As Byte
End Type
 
Private Type IP_ADDR_STRING
   dwNext                 As Long
   IPAddress              As IP_ADDRESS_STRING
   IpMask                 As IP_MASK_STRING
   dwContext              As Long
End Type
 
Private Type IP_ADAPTER_INFO
   dwNext                 As Long
   ComboIndex             As Long
   sAdaptername(0 To 258) As Byte
   sDescription(0 To 131) As Byte
   dwAddressLength        As Long
   sIPAddress(0 To 7)     As Byte
   dwIndex                As Long
   uType                  As Long
   uDhcpEnabled           As Long
   CurrentIpAddress       As Long
   IpAddressList          As IP_ADDR_STRING
   GatewayList            As IP_ADDR_STRING
   DhcpServer             As IP_ADDR_STRING
   bHaveWins              As Long
   PrimaryWinsServer      As IP_ADDR_STRING
   SecondaryWinsServer    As IP_ADDR_STRING
   LeaseObtained          As Long
   LeaseExpires           As Long
End Type
 
Private Declare Function GetAdaptersInfo Lib "IPHlpApi" ( _
   pTcpTable As Any, _
   pdwSize As Long) As Long
 
Private Declare Sub CopyMemory Lib "kernel32" _
   Alias "RtlMoveMemory" ( _
   Destination As Any, _
   Source As Any, _
   ByVal Length As Long)
 
Public Function NetAdapterInfos() As Variant
 
   'Quelle: www.dbwiki.net oder www.dbwiki.de
 
   Dim n As Long
   Dim ix As Long
   Dim i As Integer
   Dim btBuffer() As Byte
   Dim uAdapter   As IP_ADAPTER_INFO
   Dim lPtr       As Long
   Dim AI()       As String
 
   Call GetAdaptersInfo(0, n)
 
   If n > 0 Then
      ReDim btBuffer(n - 1)
      If GetAdaptersInfo(btBuffer(0), n) = 0 Then
         lPtr = VarPtr(btBuffer(0))
         Do While lPtr
            CopyMemory uAdapter, ByVal lPtr, LenB(uAdapter)
            ReDim Preserve AI(2, ix)
            AI(0, ix) = Trim$(TrimNull(StrConv(uAdapter.sAdaptername, vbUnicode)))
            AI(1, ix) = Trim$(TrimNull(Mid$(StrConv(uAdapter.sDescription, vbUnicode), 2)))
            For i = 0 To uAdapter.dwAddressLength - 1
               AI(2, ix) = AI(2, ix) & Format$(Hex$(uAdapter.sIPAddress(i)), "00")
               If i < uAdapter.dwAddressLength - 1 Then
                  AI(2, ix) = AI(2, ix) & "-"
               End If
            Next
            lPtr = uAdapter.dwNext
            ix = ix + 1
         Loop
      End If
   End If
 
   NetAdapterInfos = AI
 
End Function
 
Public Function TrimNull(Item As String)
   Dim pos As Long
 
   pos = InStr(1, Item, vbNullChar)
   If pos Then
      TrimNull = Left$(Item, pos - 1)
   Else
      TrimNull = Item
   End If
End Function

Aufruf

Public Sub TestAdapterInfo()
   Dim vAdapters As Variant
   Dim i As Long
 
   vAdapters = NetAdapterInfos
   For i = 0 To UBound(vAdapters, 2)
      'Name, IP , MAC
      Debug.Print vAdapters(0, i), vAdapters(1, i), , , vAdapters(2, i)
   Next
End Sub