21/01/08 11:20
albertking82
Codice :
rivate Const ERROR_SUCCESS = 0&
Private Const ERROR_NOT_SUPPORTED = 50&
Private Type MIB_IFROW
wszName(0 To 511) As Byte
dwIndex As Long '// index of the interface
dwType As Long '// type of interface
dwMtu As Long '// max transmission unit
dwSpeed As Long '// speed of the interface
dwPhysAddrLen As Long '// length of physical address
bPhysAddr(0 To 7) As Byte '// physical address of adapter
dwAdminStatus As Long '// administrative status
dwOperStatus As Long '// operational status
dwLastChange As Long '// last time operational status changed
dwInOctets As Long '// octets received
dwInUcastPkts As Long '// unicast packets received
dwInNUcastPkts As Long '// non-unicast packets received
dwInDiscards As Long '// received packets discarded
dwInErrors As Long '// erroneous packets received
dwInUnknownProtos As Long '// unknown protocol packets received
dwOutOctets As Long '// octets sent
dwOutUcastPkts As Long '// unicast packets sent
dwOutNUcastPkts As Long '// non-unicast packets sent
dwOutDiscards As Long '// outgoing packets discarded
dwOutErrors As Long '// erroneous packets sent
dwOutQLen As Long '// output queue length
dwDescrLen As Long '// length of bDescr member
bDescr(0 To 255) As Byte '// interface description
End Type
Private Declare Function GetIfTable Lib "iphlpapi" (ByRef pIfRowTable As Any, ByRef pdwSize As Long, ByVal bOrder As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByRef pDest As Any, ByRef pSource As Any, ByVal Length As Long)
Private Sub MACAddress()
Dim arrBuffer() As Byte
Dim lngSize As Long
Dim lngRetVal As Long
Dim lNetCards As Long
Dim i As Integer
Dim j As Integer
Dim IfRowTable As MIB_IFROW
Dim sAddr As String
Dim sName As String
'
lngSize = 0
'
'Call the GetIfTable just to get the buffer size into the lngSize variable
lngRetVal = GetIfTable(ByVal 0&, lngSize, 0)
'
If lngRetVal = ERROR_NOT_SUPPORTED Then
'
'This API works only on Win 98/2000 and NT4 with SP4
MsgBox "IP Helper is not supported by this system."
Exit Sub
'
End If
'
'Prepare the buffer
ReDim arrBuffer(0 To lngSize - 1) As Byte
'
'And call the function one more time
lngRetVal = GetIfTable(arrBuffer(0), lngSize, 0)
'
If lngRetVal = ERROR_SUCCESS Then
'
'The first 4 bytes contain the quantity of the network cards
'Get that value into the lNetCards variable
CopyMemory lNetCards, arrBuffer(0), 4
'
For i = 1 To lNetCards
'
'Copy the network data to the IfRowTable structure
CopyMemory IfRowTable, arrBuffer(4 + (i - 1) * Len(IfRowTable)), Len(IfRowTable)
'
'Retrieve name of the network card
sName = Replace$(Left(StrConv(IfRowTable.bDescr, vbUnicode), IfRowTable.dwDescrLen), vbNullChar, vbNullString)
'
'Rertieve MAK address
If IfRowTable.dwPhysAddrLen > 0 Then
For j = 0 To IfRowTable.dwPhysAddrLen - 1
sAddr = sAddr & CStr(IIf(IfRowTable.bPhysAddr(j) = 0, "00", Hex(IfRowTable.bPhysAddr(j)))) & "-"
Next
sAddr = Left(sAddr, Len(sAddr) - 1)
End If
'
' MsgBox sName & " - " & sAddr
Next
End If
Txtmac.Text = sAddr
rivate Const ERROR_SUCCESS = 0&
Private Const ERROR_NOT_SUPPORTED = 50&
Private Type MIB_IFROW
wszName(0 To 511) As Byte
dwIndex As Long '// index of the interface
dwType As Long '// type of interface
dwMtu As Long '// max transmission unit
dwSpeed As Long '// speed of the interface
dwPhysAddrLen As Long '// length of physical address
bPhysAddr(0 To 7) As Byte '// physical address of adapter
dwAdminStatus As Long '// administrative status
dwOperStatus As Long '// operational status
dwLastChange As Long '// last time operational status changed
dwInOctets As Long '// octets received
dwInUcastPkts As Long '// unicast packets received
dwInNUcastPkts As Long '// non-unicast packets received
dwInDiscards As Long '// received packets discarded
dwInErrors As Long '// erroneous packets received
dwInUnknownProtos As Long '// unknown protocol packets received
dwOutOctets As Long '// octets sent
dwOutUcastPkts As Long '// unicast packets sent
dwOutNUcastPkts As Long '// non-unicast packets sent
dwOutDiscards As Long '// outgoing packets discarded
dwOutErrors As Long '// erroneous packets sent
dwOutQLen As Long '// output queue length
dwDescrLen As Long '// length of bDescr member
bDescr(0 To 255) As Byte '// interface description
End Type
Private Declare Function GetIfTable Lib "iphlpapi" (ByRef pIfRowTable As Any, ByRef pdwSize As Long, ByVal bOrder As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByRef pDest As Any, ByRef pSource As Any, ByVal Length As Long)
Private Sub MACAddress()
Dim arrBuffer() As Byte
Dim lngSize As Long
Dim lngRetVal As Long
Dim lNetCards As Long
Dim i As Integer
Dim j As Integer
Dim IfRowTable As MIB_IFROW
Dim sAddr As String
Dim sName As String
'
lngSize = 0
'
'Call the GetIfTable just to get the buffer size into the lngSize variable
lngRetVal = GetIfTable(ByVal 0&, lngSize, 0)
'
If lngRetVal = ERROR_NOT_SUPPORTED Then
'
'This API works only on Win 98/2000 and NT4 with SP4
MsgBox "IP Helper is not supported by this system."
Exit Sub
'
End If
'
'Prepare the buffer
ReDim arrBuffer(0 To lngSize - 1) As Byte
'
'And call the function one more time
lngRetVal = GetIfTable(arrBuffer(0), lngSize, 0)
'
If lngRetVal = ERROR_SUCCESS Then
'
'The first 4 bytes contain the quantity of the network cards
'Get that value into the lNetCards variable
CopyMemory lNetCards, arrBuffer(0), 4
'
For i = 1 To lNetCards
'
'Copy the network data to the IfRowTable structure
CopyMemory IfRowTable, arrBuffer(4 + (i - 1) * Len(IfRowTable)), Len(IfRowTable)
'
'Retrieve name of the network card
sName = Replace$(Left(StrConv(IfRowTable.bDescr, vbUnicode), IfRowTable.dwDescrLen), vbNullChar, vbNullString)
'
'Rertieve MAK address
If IfRowTable.dwPhysAddrLen > 0 Then
For j = 0 To IfRowTable.dwPhysAddrLen - 1
sAddr = sAddr & CStr(IIf(IfRowTable.bPhysAddr(j) = 0, "00", Hex(IfRowTable.bPhysAddr(j)))) & "-"
Next
sAddr = Left(sAddr, Len(sAddr) - 1)
End If
'
' MsgBox sName & " - " & sAddr
Next
End If
Txtmac.Text = sAddr
aaa