VB调用API的编译问题
在网上下了一个获取本机MAC的代码，IDE环境下没问题，编译成本地代码就会报内存错误，但是编译成P代码就没事。
[解决办法]
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
