form1.frm

电子书“Visual Basic 6 网络编程实例教程.rar”

VERSION 5.00
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
Begin VB.Form Form1 
   BorderStyle     =   1  'Fixed Single
   Caption         =   "网络接口表"
   ClientHeight    =   5910
   ClientLeft      =   45
   ClientTop       =   330
   ClientWidth     =   8430
   Icon            =   "Form1.frx":0000
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   5910
   ScaleWidth      =   8430
   StartUpPosition =   2  '屏幕中心
   Begin MSComctlLib.ListView LvwInterface 
      Height          =   5175
      Left            =   0
      TabIndex        =   1
      Top             =   120
      Width           =   8415
      _ExtentX        =   14843
      _ExtentY        =   9128
      LabelWrap       =   -1  'True
      HideSelection   =   -1  'True
      _Version        =   393217
      ForeColor       =   -2147483640
      BackColor       =   -2147483643
      BorderStyle     =   1
      Appearance      =   1
      NumItems        =   0
   End
   Begin VB.CommandButton CmdRun 
      Caption         =   "运行(&R)"
      Height          =   495
      Left            =   3360
      TabIndex        =   0
      Top             =   5400
      Width           =   2175
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Private Sub CmdRun_Click()
  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
  Dim n As Long
  Dim itmx As ListItem
  Dim tmp As String
  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
         '用下面的CopyMemory调用中的Lenb来保存数据
        nStructSize = LenB(IPInterfaceRow)
        '前4个字节是一个长整形，指明了表的入口
        CopyMemory nRows, buff(0), 4
         For cnt = 1 To nRows
            '移动到前面的4个字节之后，提取相应数据，
                '并将其转换为IPInterfaceRow类型
            CopyMemory IPInterfaceRow, buff(4 + (cnt - 1) * nStructSize), nStructSize
            With LvwInterface
                .ColumnHeaders.Add , , "Adapter " & CStr(cnt)
                Set itmx = .ListItems(1)
                itmx.SubItems(cnt) = TrimNull(StrConv(IPInterfaceRow.bDescr, vbUnicode))
                Set itmx = .ListItems(2)
                itmx.SubItems(cnt) = GetInetStrFromPtr(IPInterfaceRow.dwIndex)
                Select Case IPInterfaceRow.dwType
                    Case MIB_IF_TYPE_ETHERNET:    tmp = "Ethernet"
                    Case MIB_IF_TYPE_TOKENRING:   tmp = "TokenRing"
                    Case MIB_IF_TYPE_FDDI:        tmp = "FDDI"
                    Case MIB_IF_TYPE_PPP:         tmp = "Point-to-Point"
                    Case MIB_IF_TYPE_LOOPBACK:    tmp = "Loopback"
                    Case MIB_IF_TYPE_SLIP:        tmp = "Slip"
                    Case MIB_IF_TYPE_OTHER:       tmp = "Other"
                End Select
                Set itmx = .ListItems(3)
                itmx.SubItems(cnt) = IPInterfaceRow.dwType & " " & tmp
                tmp = ""
                Set itmx = .ListItems(4)
                itmx.SubItems(cnt) = FormatNumber(IPInterfaceRow.dwMtu, 0)
                Set itmx = .ListItems(5)
                itmx.SubItems(cnt) = FormatNumber(IPInterfaceRow.dwSpeed, 0)
                For n = 1 To IPInterfaceRow.dwPhysAddrLen
                    tmp = tmp & IPInterfaceRow.bPhysAddr(n) & " "
                Next n
                Print
                Set itmx = .ListItems(6)
                itmx.SubItems(cnt) = tmp
                tmp = ""
                For n = 1 To IPInterfaceRow.dwPhysAddrLen
                    tmp = tmp & Hex(IPInterfaceRow.bPhysAddr(n)) & " "
                Next n
                Print
                Set itmx = .ListItems(7)
                itmx.SubItems(cnt) = tmp
                tmp = ""
                Select Case IPInterfaceRow.dwAdminStatus
                    Case MIB_IF_ADMIN_STATUS_UP:      tmp = "Enabled"
                    Case MIB_IF_ADMIN_STATUS_DOWN:    tmp = "Disabled"
                    Case MIB_IF_ADMIN_STATUS_TESTING: tmp = "Testing"
                End Select
                Set itmx = .ListItems(8)
                itmx.SubItems(cnt) = IPInterfaceRow.dwAdminStatus & " " & tmp
                tmp = ""
                Select Case IPInterfaceRow.dwOperStatus
                    Case MIB_IF_OPER_STATUS_NON_OPERATIONAL:  tmp = "无操作"
                    Case MIB_IF_OPER_STATUS_UNREACHABLE:      tmp = "不能抵达"
                    Case MIB_IF_OPER_STATUS_DISCONNECTED:     tmp = "断开连接"
                    Case MIB_IF_OPER_STATUS_CONNECTING:       tmp = "正连接"
                    Case MIB_IF_OPER_STATUS_CONNECTED:        tmp = "已连接"
                    Case MIB_IF_OPER_STATUS_OPERATIONAL:      tmp = "操作的"
                End Select
                Set itmx = .ListItems(9)
                itmx.SubItems(cnt) = IPInterfaceRow.dwOperStatus & " " & tmp
                tmp = ""
                Set itmx = .ListItems(10)
                itmx.SubItems(cnt) = IPInterfaceRow.dwLastChange
                Set itmx = .ListItems(11)
                itmx.SubItems(cnt) = FormatNumber(IPInterfaceRow.dwInOctets, 0)
                Set itmx = .ListItems(12)
                itmx.SubItems(cnt) = FormatNumber(IPInterfaceRow.dwInUcastPkts, 0)
                Set itmx = .ListItems(13)
                itmx.SubItems(cnt) = FormatNumber(IPInterfaceRow.dwInNUcastPkts, 0)
                Set itmx = .ListItems(14)
                itmx.SubItems(cnt) = FormatNumber(IPInterfaceRow.dwInDiscards, 0)
                Set itmx = .ListItems(15)
                itmx.SubItems(cnt) = FormatNumber(IPInterfaceRow.dwInErrors, 0)
                Set itmx = .ListItems(16)
                itmx.SubItems(cnt) = FormatNumber(IPInterfaceRow.dwInUnknownProtos, 0)
                Set itmx = .ListItems(17)
                itmx.SubItems(cnt) = FormatNumber(IPInterfaceRow.dwOutOctets, 0)
                Set itmx = .ListItems(18)
                itmx.SubItems(cnt) = FormatNumber(IPInterfaceRow.dwOutUcastPkts, 0)
                Set itmx = .ListItems(19)
                itmx.SubItems(cnt) = FormatNumber(IPInterfaceRow.dwOutNUcastPkts, 0)
                Set itmx = .ListItems(20)
                itmx.SubItems(cnt) = FormatNumber(IPInterfaceRow.dwOutDiscards, 0)
                Set itmx = .ListItems(21)
                itmx.SubItems(cnt) = FormatNumber(IPInterfaceRow.dwOutErrors, 0)
                Set itmx = .ListItems(22)
                itmx.SubItems(cnt) = FormatNumber(IPInterfaceRow.dwOutQLen, 0)
            End With  'Listview1
        Next cnt
    End If
    'If GetIfTable( ...
  End If
   'If cbRequired > 0
End Sub

Private Sub Form_Load()
    Dim itmx As ListItem
    LvwInterface.View = lvwReport
    LvwInterface.ColumnHeaders.Add , , "信息"
    With LvwInterface.ListItems
        Set itmx = .Add(, "bDescr", "接口描述")
        Set itmx = .Add(, , "接口索引")
        Set itmx = .Add(, , "接口类型")
        Set itmx = .Add(, , "最大传输单位")
        Set itmx = .Add(, , "接口速度bps")
        Set itmx = .Add(, , "物理地址(十进制)")
        Set itmx = .Add(, , "物理地址(十六进制)")
        Set itmx = .Add(, , "是否允许管理")
        Set itmx = .Add(, , "接口操作状态")
        Set itmx = .Add(, , "最近状态变化时间")
        Set itmx = .Add(, , "接收的数据(8个一组)")
        Set itmx = .Add(, , "接收的包(统一格式)")
        Set itmx = .Add(, , "接收的包(未统一格式)")
        Set itmx = .Add(, , "废弃的包")
        Set itmx = .Add(, , "因错误而废弃的包")
        Set itmx = .Add(, , "因未知协议而废弃的包")
        Set itmx = .Add(, , "发送的数据(8个一组)")
        Set itmx = .Add(, , "发送的包(统一格式)")
        Set itmx = .Add(, , "发送的包(未统一格式)")
        Set itmx = .Add(, , "无错误而废弃的包")
        Set itmx = .Add(, , "因错误而废弃的包")
        Set itmx = .Add(, , "输出队列长度")
    End With
End Sub

Private Function GetInetStrFromPtr(ByVal Address As Long) As String
    GetInetStrFromPtr = GetStrFromPtrA(inet_ntoa(Address))
End Function

Private Function GetStrFromPtrA(ByVal lpszA As Long) As String
    GetStrFromPtrA = String$(lstrlenA(ByVal lpszA), 0)
    Call lstrcpyA(ByVal GetStrFromPtrA, ByVal lpszA)
End Function

Private Function TrimNull(item As String)
    Dim pos As Integer
    pos = InStr(item, Chr$(0))
    If pos Then
    TrimNull = Left$(item, pos - 1)
    Else: TrimNull = item
    End If
End Function