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" (dest As Any, Source As Any, _
        ByVal Length As Long)
 
Public Function NetAdapterInfos() As Variant
Dim n As Long, ix As Long, 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(0 To n - 1)
  If GetAdaptersInfo(btBuffer(0), n) = 0& Then
    lPtr = VarPtr(btBuffer(0))
    Do While (lPtr <> 0)
      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(Item, Chr$(0))
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 i
 
End Sub