VBA : Obtention adresse MAC : Probleme d allocation Memoire

Question

Bonjour a tous,

Je désire creer une macro VBA qui me permettera de recuperer l adresse mac du PC, afin de securiser l utilisation du classeur.

Comme tout un chacun, je commence donc par des petites recherches sur le Net et je tombe sur le meme code (peu ou prou) partout. 

=============
Private Const NCBASTAT As Long = &H33
Private Const NCBNAMSZ As Long = 16
Private Const HEAP_ZERO_MEMORY As Long = &H8
Private Const HEAP_GENERATE_EXCEPTIONS As Long = &H4
Private Const NCBRESET As Long = &H32

Private Type NET_CONTROL_BLOCK
    'definition du type net control Block
    ncb_command    As Byte
    ncb_retcode    As Byte
    ncb_lsn        As Byte
    ncb_num        As Byte
    ncb_buffer     As Long
    ncb_length     As Integer
    ncb_callname   As String * NCBNAMSZ
    ncb_name       As String * NCBNAMSZ
    ncb_rto        As Byte
    ncb_sto        As Byte
    ncb_post       As Long
    ncb_lana_num   As Byte
    ncb_cmd_cplt   As Byte
    ncb_reserve(9) As Byte
    ncb_event      As Long
End Type

Private Type ADAPTER_STATUS
    'definition du type pour definir le statut de l'adaptateur réseau
    adapter_address(5) As Byte
    rev_major         As Byte
    reserved0         As Byte
    adapter_type      As Byte
    rev_minor         As Byte
    duration          As Integer
    frmr_recv         As Integer
    frmr_xmit         As Integer
    iframe_recv_err   As Integer
    xmit_aborts       As Integer
    xmit_success      As Long
    recv_success      As Long
    iframe_xmit_err   As Integer
    recv_buff_unavail As Integer
    t1_timeouts       As Integer
    ti_timeouts       As Integer
    Reserved1         As Long
    free_ncbs         As Integer
    max_cfg_ncbs      As Integer
    max_ncbs          As Integer
    xmit_buf_unavail  As Integer
    max_dgram_size    As Integer
    pending_sess      As Integer
    max_cfg_sess      As Integer
    max_sess          As Integer
    max_sess_pkt_size As Integer
    name_count        As Integer
End Type
   
Private Type NAME_BUFFER
    name        As String * NCBNAMSZ
    name_num    As Integer
    name_flags  As Integer
End Type

Private Type ASTAT
    adapt          As ADAPTER_STATUS
    NameBuff(30)   As NAME_BUFFER
End Type

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

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)
    'allocation de la memoire dans le tas du processus
    pASTAT = HeapAlloc(GetProcessHeap(), HEAP_GENERATE_EXCEPTIONS Or _
                       HEAP_ZERO_MEMORY, NCB.ncb_length)
             
    If pASTAT = 0 Then
        Debug.Print "pas assez de mémoire!" 'bon, y a peu de chance que ca arrive :o)
        Exit Function
    End If
     
    NCB.ncb_buffer = pASTAT
    'appel de la fonction netbios qui va nous donner les stats de la carte
    '(dont l'adresse MAC)
    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)
    'désallocation de la mémoire...
    HeapFree GetProcessHeap(), 0, pASTAT
     
    GetMACAddress = tmp

End Function

Sub MonForm_OnCurrent()

Dim strMacAddr As String

strMacAddr = getMACAdress()

If strMacAddr = "XX-XX-XX-XX-XX-XX" Then
   Exit Sub
Else
   DoCmd.Quit
End If
=============

Premiere tentative, echec. Normal. Comme j ai recupéré d autres codes quasi similaires, je les teste. Toujours rien. Apres une etude de ces codes, je me rends compte que le probleme se situe a ce niveau :

=========================
    pASTAT = HeapAlloc(GetProcessHeap(), HEAP_GENERATE_EXCEPTIONS Or _
                       HEAP_ZERO_MEMORY, NCB.ncb_length)
             
    If pASTAT = 0 Then
        Debug.Print "pas assez de mémoire!" 'bon, y a peu de chance que ca arrive :o)
        Exit Function
    End If
===========================

En effet, je rentre systematiquement dans la condition "0". Pas terrible.

Pour info :
-j ai compilé sur un autre PC : meme resultat
-en enlevant la condition, j obtient comme MAc Adress "00 00 00 00 00"

Alors, "pas assez de mémoire!", c est bien beau, mais ca m aide pas des masses....
Vous noterez de plus le "'bon, y a peu de chance que ca arrive :o)" qui enerve un peu....

Auriez vous un idée, voir une solution pour mon probleme ?

Merci d avance !

BruNews · Answer

Utilise donc UuidCreateSequential(), nettement plus simple.

ciao...
BruNews, MVP VC++

cs_JMO · Answer

Bonjour,

Avec WMI, il y a un peu plus simple.

jean-marc

Dim strComputer   : strComputer = "."
Dim objWMIService : Set objWMIService = GetObject("winmgmts:" & "!\" & strComputer & "\root\cimv2")Dim colAdapters   : Set colAdapters objWMIService.ExecQuery("Select * from Win32_NetworkAdapterConfiguration Where IPEnabled True")
For Each objAdapter in colAdapters
    IPdebut = LBound(objAdapter.IPAddress)
    IPfin = UBound(objAdapter.IPAddress)
    If (objAdapter.IPAddress(IPdebut) <> "") Then
        adaptateur = objAdapter.Description
        MsgBox objAdapter.Description &vbCrLf& objAdapter.MACAddress
        addMAC = objAdapter.MACAddress
        For i = IPdebut To IPfin
            MsgBox objAdapter.IPAddress(i)
        Next
    End If



Next
MsgBox adaptateur &vbCrLf& addMAC,,"Adresse MAC"
Set objWMIService = Nothing
Set colAdapters = Nothing

Dolphin Boy · Answer

Salut, j'ai une autre solution qui fonctionne mais qui retourne toutes les adresses MAC des cartes installées (plusieurs cartes réseau sur un PC c'est possible). Je te laisse donc adapter pour tes besoins (les lignes en rouge) et puis, tu peux transformer la Sub Adresses_Mac() en Function Adresses_Mac() As String.

Private Const ERROR_SUCCESS                       As Long = 0
Private Const MAX_INTERFACE_NAME_LEN              As Long = 256
Private Const MAXLEN_IFDESCR                      As Long = 256
Private Const MAXLEN_PHYSADDR                     As Long = 8


Private Type MIB_IFROW
  wszName(0 To (MAX_INTERFACE_NAME_LEN - 1) * 2) As Byte
  dwIndex               As Long
  dwType                As Long
  dwMtu                 As Long
  dwSpeed               As Long
  dwPhysAddrLen         As Long
  bPhysAddr(0 To 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(0 To MAXLEN_IFDESCR - 1) As Byte
End Type


Private Type Infos_Interface
  Adresse_Mac           As String
  Type_Interface        As String
  Vitesse               As String
  Description           As String
End Type


Private Declare Function GetIfTable _
  Lib "iphlpapi.dll" _
    ( _
      ByRef pIfTable As Any, _
      ByRef pdwSize As Long, _
      ByVal bOrder As Long _
    ) As Long


Declare Sub CopyMemory _
  Lib "kernel32" Alias "RtlMoveMemory" _
    ( _
      pDst As Any, _
      pSrc As Any, _
      ByVal ByteLen As Long _
    )


Public Infos() As Infos_Interface


Public Sub Adresses_Mac()
Dim IPInterfaceRow As MIB_IFROW
Dim buff() As Byte
Dim cbRequired As Long
Dim nStructSize As Long
Dim nRows As Long
Dim cnt As Long
  
  Call GetIfTable(ByVal 0&, cbRequired, 1)
  If cbRequired > 0 Then
    ReDim buff(0 To cbRequired - 1) As Byte
    If GetIfTable(buff(0), cbRequired, 1) = ERROR_SUCCESS Then
      ' Sauvegarde de la longueur en octets de IPInterfaceRow
      nStructSize = LenB(IPInterfaceRow)
      ' Nombre d'entrées de la table (nb d'interfaces réseau détectées)
      CopyMemory nRows, buff(0), 4
      ReDim Infos(nRows) As Infos_Interface
      For cnt = 1 To nRows
        ' Pour chaque entrée de la table
        CopyMemory IPInterfaceRow, buff(4 + (cnt - 1) * nStructSize), nStructSize
        ' Adresse mac
        Infos(cnt).Adresse_Mac = Format$(Hex(IPInterfaceRow.bPhysAddr(0)), "00") & " " & _
                                 Format$(Hex(IPInterfaceRow.bPhysAddr(1)), "00") & " " & _
                                 Format$(Hex(IPInterfaceRow.bPhysAddr(2)), "00") & " " & _
                                 Format$(Hex(IPInterfaceRow.bPhysAddr(3)), "00") & " " & _
                                 Format$(Hex(IPInterfaceRow.bPhysAddr(4)), "00") & " " & _
                                 Format$(Hex(IPInterfaceRow.bPhysAddr(5)), "00")
        If Infos(cnt).Adresse_Mac <> "00 00 00 00 00 00" Then
          MsgBox Infos(cnt).Adresse_Mac
        End If
      Next cnt
    End If
  End If
End Sub


Bonne prog

VBA : Obtention adresse MAC : Probleme d allocation Memoire

3 réponses

Votre réponse

Discussions similaires