Option Explicit
Dim ID() As Variant

Private Const GENERIC_READ = &H80000000
Private Const GENERIC_WRITE = &H40000000

Private Const FILE_SHARE_READ = &H1
Private Const FILE_SHARE_WRITE = &H2

Private Const OPEN_EXISTING = 3
Private Const OID_802_3_PERMANENT_ADDRESS = &H1010101
Private Const OID_802_3_CURRENT_ADDRESS = &H1010102
Private Const IOCTL_NDIS_QUERY_GLOBAL_STATS = &H170002

Private Const ERROR_BUFFER_OVERFLOW = 111
Private Const MAX_ADAPTER_NAME_LENGTH As Long = 260
Private Const MAX_ADAPTER_DESCRIPTION_LENGTH As Long = 132
Private Const MAX_ADAPTER_ADDRESS_LENGTH As Long = 8
Private Const MIB_IF_TYPE_ETHERNET = 6

Private Type IP_ADDR_STRING
    Next As Long
    IpAddress As String * 16
    IpMask As String * 16
    Context As Long
End Type

Private Type IP_ADAPTER_INFO
    Next As Long
    ComboIndex As Long
    AdapterName As String * MAX_ADAPTER_NAME_LENGTH
    Description As String * MAX_ADAPTER_DESCRIPTION_LENGTH
    AddressLength As Long
    Address(MAX_ADAPTER_ADDRESS_LENGTH - 1) As Byte
    Index As Long
    Type 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 Boolean
    PrimaryWinsServer As IP_ADDR_STRING
    SecondaryWinsServer As IP_ADDR_STRING
    LeaSEObtained As Long
    LeaseExpires As Long
End Type

Private Declare Function GetAdaptersInfo Lib "iphlpapi.dll" (pTcpTable As Any,pdwSize As Long) As Long

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (dst As Any,src As Any,ByVal bcount As Long)
Private Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" ( _
    ByVal lpFileName As String,ByVal dwDesiredAccess As Long,_
    ByVal dwShareMode As Long,ByVal lpSecurityAttributes As Long,_
    ByVal dwCreationDisposition As Long,ByVal dwFlagsAndAttributes As Long,_
    ByVal hTemplateFile As Long) As Long

Private Declare Function DeviceIoControl Lib "kernel32" ( _
    ByVal hDevice As Long,ByVal dwIoControlCode As Long,_
    lpInBuffer As Any,ByVal nInBufferSize As Long,_
    lpOutBuffer As Any,ByVal nOutBufferSize As Long,_
    lpBytesReturned As Long,Optional ByVal lpOverlapped As Long = 0) As Long

Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long

Function GetTrueMac(ByVal NetId As String,ByRef WorkMac As String,ByRef TrueMac As String) As Long
Dim J As Long
Dim hDev As Long
Dim InBuf As Long
Dim OutBuf(256) As Byte
Dim BytesReturned As Long
Dim s As String
    hDev = CreateFile("\\.\" & NetId,GENERIC_READ Or GENERIC_WRITE,FILE_SHARE_READ Or FILE_SHARE_WRITE,ByVal 0,OPEN_EXISTING,0)
    InBuf = OID_802_3_PERMANENT_ADDRESS
    If (DeviceIoControl(hDev,IOCTL_NDIS_QUERY_GLOBAL_STATS,InBuf,4,ByVal VarPtr(OutBuf(0)),256,BytesReturned,ByVal 0)) Then
        For J = 0 To BytesReturned - 1
            s = Hex(Val(OutBuf(J)))
            If J = 0 Then
                TrueMac = IIf(Len(s) = 1,"0" & s,s)
            Else
                TrueMac = TrueMac & "-" & IIf(Len(s) = 1,s)
            End If
        Next
    End If
'    Debug.Print TrueMac
    InBuf = OID_802_3_CURRENT_ADDRESS
    If (DeviceIoControl(hDev,ByVal 0)) Then
        For J = 0 To BytesReturned - 1
            s = Hex(Val(OutBuf(J)))
            If J = 0 Then
                WorkMac = IIf(Len(s) = 1,s)
            Else
                WorkMac = WorkMac & "-" & IIf(Len(s) = 1,s)
            End If
        Next
    End If
'    Debug.Print WorkMac
Error1:
    CloseHandle hDev
End Function

Function GetNetId(ByRef NetId() As Variant) As Long
Dim AdapterInfo As IP_ADAPTER_INFO
Dim AdapterInfoSize As Long
Dim AdapterInfoBuffer() As Byte
Dim i As Long
Dim J As Long
Dim Error As Long
Dim Padapt As Long
Dim MacAddr2 As IP_ADAPTER_INFO
    AdapterInfoSize = 0
    Error = GetAdaptersInfo(ByVal 0&,AdapterInfoSize)
    If Error <> 0 Then
        If Error <> ERROR_BUFFER_OVERFLOW Then
            Exit Function
        End If
    End If
    ReDim AdapterInfoBuffer(AdapterInfoSize - 1)
    Error = GetAdaptersInfo(AdapterInfoBuffer(0),AdapterInfoSize)
    If Error <> 0 Then
        Exit Function
    End If
    CopyMemory AdapterInfo,AdapterInfoBuffer(0),Len(AdapterInfo)
    Padapt = AdapterInfo.Next
    Do While Padapt <> 0
        CopyMemory MacAddr2,AdapterInfo,Len(MacAddr2)
        Select Case MacAddr2.Type
            Case MIB_IF_TYPE_ETHERNET
                ReDim Preserve NetId(i)
                NetId(i) = MacAddr2.AdapterName
                i = i + 1
        End Select
        Padapt = MacAddr2.Next
        If Padapt <> 0 Then
            CopyMemory AdapterInfo,ByVal Padapt,Len(AdapterInfo)
        End If
    Loop
    GetNetId = i
End Function

Private Sub Form_Click()
ReDim Preserve ID(GetNetId(ID))
Dim Wk As String,TK As String
Dim i As Byte
    Cls
    Print "WorkMAC","TrueMAC"
    For i = 0 To UBound(ID) - 1
        ID(i) = Left(ID(i),InStr(ID(i),Chr(0)) - 1)
        Call GetTrueMac(ID(i),Wk,TK)
        Print Wk,TK
    Next
End Sub