VB调用API的编译问题

[redshiliu]

在网上下了一个获取本机MAC的代码，IDE环境下没问题，编译成本地代码就会报内存错误，但是编译成P代码就没事。

[嗷嗷叫的老马]

代码都不上,神仙也不知道问题会在哪儿.

[贝隆]

http://download.csdn.net/detail/veron_04/1894321

[redshiliu]

代码来了

Option Explicit

Private Const NCBASTAT = &H33
Private Const NCBNAMSZ = 16
Private Const HEAP_ZERO_MEMORY = &H8
Private Const HEAP_GENERATE_EXCEPTIONS = &H4
Private Const NCBRESET = &H32

Private Type NCB
    ncb_command As Byte 'Integer
    ncb_retcode As Byte 'Integer
    ncb_lsn As Byte 'Integer
    ncb_num As Byte ' Integer
    ncb_buffer As Long 'String
    ncb_length As Integer
    ncb_callname As String * NCBNAMSZ
    ncb_name As String * NCBNAMSZ
    ncb_rto As Byte 'Integer
    ncb_sto As Byte ' Integer
    ncb_post As Long
    ncb_lana_num As Byte 'Integer
    ncb_cmd_cplt As Byte 'Integer
    ncb_reserve(9) As Byte ' Reserved, must be 0
    ncb_event As Long
End Type

Private Type ADAPTER_STATUS
    adapter_address(5) As Byte 'As String * 6
    rev_major As Byte 'Integer
    reserved0 As Byte 'Integer
    adapter_type As Byte 'Integer
    rev_minor As Byte 'Integer
    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 GetCurrentProcessId Lib "kernel32" () As Long
Private Declare Function Netbios Lib "netapi32.dll" (pncb As NCB) 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
Private Declare Function GetComputerName Lib "kernel32" Alias "GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) As Long


Public Function API_GetMac(Optional ByVal bSplitChar As Boolean = True) As String
    Dim bRet As Byte
    Dim pASTAT As Long
    Dim myNcb As NCB
    Dim myASTAT As ASTAT, tempASTAT As ASTAT
    
    myNcb.ncb_command = NCBRESET
    bRet = Netbios(myNcb)
    myNcb.ncb_command = NCBASTAT
    myNcb.ncb_lana_num = 0
    myNcb.ncb_callname = "*　　　　　　 "
    myNcb.ncb_length = Len(myASTAT)
    pASTAT = HeapAlloc(GetProcessHeap(), HEAP_GENERATE_EXCEPTIONS Or HEAP_ZERO_MEMORY, myNcb.ncb_length)
    If pASTAT = 0 Then Exit Function
    
    myNcb.ncb_buffer = pASTAT
    bRet = Netbios(myNcb)
    CopyMemory myASTAT, myNcb.ncb_buffer, Len(myASTAT)
    
    Dim cnt, tmp
    Dim strSplitChar As String
    If bSplitChar Then strSplitChar = "-"
    For cnt = 0 To UBound(myASTAT.adapt.adapter_address) - 1
        If Len(Hex(myASTAT.adapt.adapter_address(cnt))) = 1 Then
            tmp = tmp & "0" & Hex(myASTAT.adapt.adapter_address(cnt)) & strSplitChar
        Else
            tmp = tmp & Hex(myASTAT.adapt.adapter_address(cnt)) & strSplitChar
        End If
    Next
    HeapFree GetProcessHeap(), 0, pASTAT
    API_GetMac = Left$(tmp, Len(tmp) - 1)
End Function

[嗷嗷叫的老马]

Option Explicit
'*************************************************************************
'**模 块 名：ModGetPhysicalAddress
'**说    明：取得本机所有网卡的MAC地址
'**创 建 人：嗷嗷叫的老马
'**日    期：2010年09月28日
'**备    注: 紫水晶工作室 版权所有
'**          更多模块/类模块请访问我站:  http://www.m5home.com
'**版    本：V2.0
'**修    正: 发现获取的MAC地址后面多了两位00-00,感谢Wise朋友!
'*************************************************************************

Private Const HEAP_ZERO_MEMORY  As Long = &H8&
Private Const ERROR_BUFFER_OVERFLOW As Long = &H6F&
Private Const GAA_FLAG_INCLUDE_PREFIX As Long = &H10&
Private Const MAX_ADAPTER_ADDRESS_LENGTH As Long = &H8&
Private Const MAX_ADAPTER_NAME_LENGTH As Long = &H100&
Private Const AF_UNSPEC As Long = &H0&
Private Const NO_ERROR As Long = &H0&

Private Enum IF_TYPE
    IF_TYPE_OTHER = 1
    IF_TYPE_ETHERNET_CSMACD = 6
    IF_TYPE_ISO88025_TOKENRING = 9
    IF_TYPE_PPP = 23
    IF_TYPE_SOFTWARE_LOOPBACK = 24
    IF_TYPE_ATM = 37
    IF_TYPE_IEEE80211 = 71
    IF_TYPE_TUNNEL = 131
    IF_TYPE_IEEE1394 = 144
End Enum

Private Enum IF_OPER_STATUS
    IfOperStatusUp = 1
    IfOperStatusDown = 2
    IfOperStatusTesting = 3
    IfOperStatusUnknown = 4
    IfOperStatusDormant = 5
    IfOperStatusNotPresent = 6
    IfOperStatusLowerLayerDown = 7
End Enum

Private Type IP_ADAPTER_ADDRESSES
    Length As Long                      '原型里的联合体,直接拆开
    IfIndex As Long
    pNext As Long                       '指向下一个IP_ADAPTER_ADDRESSES结构的指针,类似单向链表了
    AdapterName As Long                 'PCHAR
    FirstUnicastAddress As Long         'IP_ADAPTER_UNICAST_ADDRESS
    FirstAnycastAddress As Long         'IP_ADAPTER_ANYCAST_ADDRESS
    FirstMulticastAddress As Long       'IP_ADAPTER_MULTICAST_ADDRESS
    FirstDnsServerAddress As Long       'IP_ADAPTER_DNS_SERVER_ADDRESS
    lpDnsSuffix As Long                 'PWCHAR
    lpDescription As Long               'PWCHAR
    lpFriendlyName As Long              'PWCHAR
    PhysicalAddress(MAX_ADAPTER_ADDRESS_LENGTH - 1) As Byte
    PhysicalAddressLength As Long
    Flags As Long
    MTU As Long
    IfType As IF_TYPE
    OperStatus As IF_OPER_STATUS
End Type

Private Declare Function GetAdaptersAddresses Lib "iphlpapi" ( _
        ByVal Family As Long, _
        ByVal Flags As Long, _
        ByVal Reserved As Long, _
        ByVal AdapterAddresses As Long, _
        ByRef SizePointer As Long) 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 HeapReAlloc Lib "Kernel32" ( _
        ByVal hHeap As Long, _
        ByVal dwFlags As Long, _
        ByVal lpMem As Long, _
        ByVal dwBytes As Long) As Long

Private Declare Function HeapFree Lib "Kernel32" ( _
        ByVal hHeap As Long, _
        ByVal dwFlags As Long, _
        ByVal lpMem As Long) As Long
    
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" ( _
     ByVal Destination As Long, _
     ByVal Source As Long, _
     ByVal Length As Long)

Private Declare Function lstrlenW Lib "Kernel32" ( _
                        ByVal ptr As Long) As Long

Private Function GetStrFromPtr(ByVal ptr As Long) As String
    '从指针得到字符串
    Dim Buffer() As Byte
    Dim lpSize As Long
    
    lpSize = lstrlenW(ptr) * 2
    If lpSize <> 0 Then
        ReDim Buffer(lpSize)
        CopyMemory VarPtr(Buffer(0)), ptr, lpSize
        GetStrFromPtr = Buffer
    End If
End Function

Private Function GetHex(ByRef inByte() As Byte) As String
    '将字节数据以十六进制字符串输出
    Dim I As Long, J() As String, K As Long
    
    ReDim J(UBound(inByte))
    
    For I = 0 To UBound(J)
        J(I) = "00"
        RSet J(I) = CStr(Hex(inByte(I)))
    Next
    
    ReDim Preserve J(UBound(J) - 2)
    
    GetHex = Replace(Join(J(), "-"), " ", "0")
End Function

Public Function GetPhysicalAddress() As String()
    '取网卡MAC地址
    '
    '无输入参数.
    '返回值:
    '       字符串数组,包含本机所有网络连接的MAC地址.
    '备注:
    '       每个网络连接并不一定对应一个物理网卡,但仍然可以拥有MAC地址
    Dim IPAA As IP_ADAPTER_ADDRESSES, pAdapterAddresses As Long
    Dim outBufLen As Long, Flags As Long, Family As Long
    Dim lRet As Long, dwIndex As Long, I As Long
    Dim outBuff() As String
    
    Flags = GAA_FLAG_INCLUDE_PREFIX
    Family = AF_UNSPEC
    outBufLen = 0
    
    pAdapterAddresses = HeapAlloc(GetProcessHeap, HEAP_ZERO_MEMORY, 32)
    
    lRet = GetAdaptersAddresses(Family, Flags, 0, pAdapterAddresses, outBufLen)       '第一次调用,如果缓冲区不够,会在outBufLen里返回所需要的缓冲区大小
                        '原示例中使用一次性分配大量空间的做法,觉得不太爽:)
                        
    If lRet = ERROR_BUFFER_OVERFLOW Then      '如果返回溢出,则重分配足够的内存
        pAdapterAddresses = HeapReAlloc(GetProcessHeap, HEAP_ZERO_MEMORY, pAdapterAddresses, outBufLen)
    End If
    
    lRet = GetAdaptersAddresses(Family, Flags, 0, pAdapterAddresses, outBufLen)     '这次是正式取了
    
    If lRet = NO_ERROR Then
        I = 0
        ReDim outBuff(I)
        
        Call CopyMemory(VarPtr(IPAA.Length), pAdapterAddresses, LenB(IPAA))         '复制第一个结构
        outBuff(I) = GetHex(IPAA.PhysicalAddress())
        
        Debug.Print GetStrFromPtr(IPAA.lpFriendlyName); IPAA.OperStatus; IPAA.IfType
        Debug.Print outBuff(I)
        Debug.Print
        
        Do While IPAA.pNext <> 0
            I = I + 1
            ReDim Preserve outBuff(I)
            
            Call CopyMemory(VarPtr(IPAA.Length), ByVal IPAA.pNext, Len(IPAA))       '复制下一个结构,pNext中保存的是指向下一个结构的指针
            outBuff(I) = GetHex(IPAA.PhysicalAddress())
            
            Debug.Print GetStrFromPtr(IPAA.lpFriendlyName); IPAA.OperStatus; IPAA.IfType
            Debug.Print outBuff(I)
            Debug.Print
        Loop
    End If
    HeapFree GetProcessHeap, 0, pAdapterAddresses
    GetPhysicalAddress = outBuff
End Function

[嗷嗷叫的老马]

你把代码中间多插几个MSGBOX,然后编译后执行看看,先把产生非法操作的语句定位出来. 然后才好分析原因. 别人的环境不一定与你相同的.

[redshiliu]

老马给分析解释下为啥我的代码会报错，而你的就没事？

[redshiliu]

另外环境是Win2003