frmgetmactest.frm

局域网用户屏幕的控制和查看程序

VERSION 5.00
Begin VB.Form frmGetMacTest 
   Caption         =   "Form1"
   ClientHeight    =   3195
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   4680
   LinkTopic       =   "Form1"
   ScaleHeight     =   3195
   ScaleWidth      =   4680
   StartUpPosition =   3  '窗口缺省
   Begin VB.CommandButton Command2 
      Caption         =   "Command2"
      Height          =   660
      Left            =   1185
      TabIndex        =   1
      Top             =   2085
      Width           =   1335
   End
   Begin VB.CommandButton Command1 
      Caption         =   "Command1"
      Height          =   585
      Left            =   225
      TabIndex        =   0
      Top             =   405
      Width           =   1455
   End
End
Attribute VB_Name = "frmGetMacTest"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False

Option Explicit
  Private Const MAX_ADAPTER_NAME_LENGTH                    As Long = 256
  Private Const MAX_ADAPTER_DESCRIPTION_LENGTH      As Long = 128
  Private Const MAX_ADAPTER_ADDRESS_LENGTH              As Long = 8
  Private Const ERROR_SUCCESS      As Long = 0
    
  Private Type MAC_ADDRESS_STRING
          IpAddr(0 To 15)      As Byte
  End Type
    
  Private Type MAC_MASK_STRING
          IpMask(0 To 15)      As Byte
  End Type
  
  Private Type MAC_ADDR_STRING
          dwNext          As Long
          IpAddress    As MAC_ADDRESS_STRING
          IpMask          As MAC_MASK_STRING
          dwContext    As Long
  End Type
    
  Private Type MAC_ADAPTER_INFO
      dwNext                                As Long
      ComboIndex                        As Long     '保留
      sAdapterName(0 To (MAX_ADAPTER_NAME_LENGTH + 3))                    As Byte
      sDescription(0 To (MAX_ADAPTER_DESCRIPTION_LENGTH + 3))      As Byte
      dwAddressLength              As Long
      sMACAddress(0 To (MAX_ADAPTER_ADDRESS_LENGTH - 1))                  As Byte
      dwIndex                              As Long
      uType                                  As Long
      uDhcpEnabled                    As Long
      CurrentIpAddress            As Long
      IpAddressList                  As MAC_ADDR_STRING
      GatewayList                      As MAC_ADDR_STRING
      DhcpServer                        As MAC_ADDR_STRING
      bHaveWins                          As Long
      PrimaryWinsServer          As MAC_ADDR_STRING
      SecondaryWinsServer      As MAC_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)
    
    Public Function LocalMACAddress() As String
        Dim cbRequired     As Long
        Dim buff()             As Byte
        Dim Adapter           As MAC_ADAPTER_INFO
        Dim AdapterStr     As MAC_ADDR_STRING
        Dim ptr1                 As Long
        Dim sIPAddr           As String
        Dim found               As Boolean
        Dim iFound   As Integer
        iFound = 0
        sIPAddr = ""
        Dim sReturn   As String
        sReturn = ""
        Call GetAdaptersInfo(ByVal 0&, cbRequired)
        If cbRequired = 0 Then Exit Function
        ReDim buff(0 To cbRequired - 1) As Byte
        If GetAdaptersInfo(buff(0), cbRequired) <> ERROR_SUCCESS Then Exit Function
        
        '获取存放在buff()中的数据的指针
          ptr1 = VarPtr(buff(0))
          Do While (ptr1 <> 0)
              '将第一个网卡的数据转换到MAC_ADAPTER_INFO结构中
                CopyMemory Adapter, ByVal ptr1, LenB(Adapter)
                With Adapter
                    'IpAddress.IpAddr成员给出了DHCP的IP地址
                      Dim k As Long
                      For k = 1 To .dwAddressLength
                          sReturn = sReturn & Right("0" & Hex(AscB(MidB(.sMACAddress, k, 1))), 2) & "-"
                      Next k
                      sReturn = Left(sReturn, Len(sReturn) - 1) & vbCrLf
                      ptr1 = .dwNext
                End With     'With  Adapter
        '不再有网卡时，ptr1的值为0
          Loop    'Do  While  (ptr1  <>  0)
      '返回结果字符串
        LocalMACAddress = sReturn
  End Function

Private Sub Command1_Click()
Me.Caption = LocalMACAddress
End Sub

Private Sub Command2_Click()
Dim t1
    Close #1
    Open "d:\test.bat" For Output As #1
    Print #1, "ipconfig.exe /all > d:\test.txt"
    Close #1
    DoEvents
    Shell "d:\test.bat", vbHide
    '延长时间2秒,等待test.bat的结果
    t1 = Int(Timer)
    Do While Int(Timer) < t1 + 2
    DoEvents
    Loop
    Dim x, n
    Dim Gateway
    Open "d:\test.txt" For Input As #1
    Do While Not EOF(1)
        Line Input #1, x
        If InStr(x, "Physical Address") > 0 Then
            n = InStr(x, ": ")
            Gateway = Mid(x, n + 1)
            MsgBox "MAC地址：" & Gateway
        End If
    Loop
    Close #1
End Sub