iphlpapi.cls

支持监控包括传输控制协议和 UDP 的所有的互联网传输协议。同时程序具有实时文件防修改监控功能

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "CIpHelper"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Attribute VB_Ext_KEY = "SavedWithClassBuilder6" ,"Yes"
Attribute VB_Ext_KEY = "Top_Level" ,"Yes"
'****************************************************************************
'人人为我，我为人人
'枕善居汉化收藏整理
'发布日期：2007/09/20
'描    述：界面清爽VB版高级专业防火墙 Ver 2.0.3
'网    站：http://www.Mndsoft.com/  (VB6源码博客)
'网    站：http://www.VbDnet.com/   (VB.NET源码博客,主要基于.NET2005)
'e-mail  ：[e-mail]
'e-mail  ：[e-mail]
'OICQ    ：88382850
'          如果您有新的好的代码别忘记给枕善居哦!
'****************************************************************************

Option Explicit
Public Enum OperationalStates
    MIB_IF_OPER_STATUS_NON_OPERATIONAL = 0
    MIB_IF_OPER_STATUS_UNREACHABLE = 1
    MIB_IF_OPER_STATUS_DISCONNECTED = 2
    MIB_IF_OPER_STATUS_CONNECTING = 3
    MIB_IF_OPER_STATUS_CONNECTED = 4
    MIB_IF_OPER_STATUS_OPERATIONAL = 5
End Enum
#If False Then 'Trick preserves Case of Enums when typing in IDE
Private MIB_IF_OPER_STATUS_NON_OPERATIONAL, MIB_IF_OPER_STATUS_UNREACHABLE, MIB_IF_OPER_STATUS_DISCONNECTED, MIB_IF_OPER_STATUS_CONNECTING
Private MIB_IF_OPER_STATUS_CONNECTED, MIB_IF_OPER_STATUS_OPERATIONAL
#End If
Public Enum InterfaceTypes
    MIB_IF_TYPE_OTHER = 1
    MIB_IF_TYPE_ETHERNET = 6
    MIB_IF_TYPE_TOKENRING = 9
    MIB_IF_TYPE_FDDI = 15
    MIB_IF_TYPE_PPP = 23
    MIB_IF_TYPE_LOOPBACK = 24
    MIB_IF_TYPE_SLIP = 28
End Enum
#If False Then 'Trick preserves Case of Enums when typing in IDE
Private MIB_IF_TYPE_OTHER, MIB_IF_TYPE_ETHERNET, MIB_IF_TYPE_TOKENRING, MIB_IF_TYPE_FDDI, MIB_IF_TYPE_PPP, MIB_IF_TYPE_LOOPBACK
Private MIB_IF_TYPE_SLIP
#End If
Public Enum AdminStatuses
    MIB_IF_ADMIN_STATUS_UP = 1
    MIB_IF_ADMIN_STATUS_DOWN = 2
    MIB_IF_ADMIN_STATUS_TESTING = 3
End Enum
#If False Then 'Trick preserves Case of Enums when typing in IDE
Private MIB_IF_ADMIN_STATUS_UP, MIB_IF_ADMIN_STATUS_DOWN, MIB_IF_ADMIN_STATUS_TESTING
#End If
''Private Const MAXLEN_IFDESCR             As Integer = 256
''Private Const MAXLEN_PHYSADDR            As Integer = 8
''Private Const MAX_INTERFACE_NAME_LEN     As Integer = 256
Private Const ERROR_NOT_SUPPORTED    As Long = 50
Private Const ERROR_SUCCESS          As Long = 0
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 mvarInterfaces               As CInterfaces
Private m_lngBytesReceived           As Long
Private m_lngBytesSent               As Long
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)
Public Property Get BytesReceived() As Long
    BytesReceived = m_lngBytesReceived
End Property
Public Property Get BytesSent() As Long
    BytesSent = m_lngBytesSent
End Property
Private Function InitInterfaces(objInterfaces As CInterfaces) As Boolean
'
Dim arrBuffer()  As Byte
Dim lngSize      As Long
Dim lngRetVal    As Long
Dim lngRows      As Long
Dim i            As Long
Dim j            As Long
Dim IfRowTable   As MIB_IFROW
Dim objInterface As New CInterfaces
    lngSize = 0
    m_lngBytesReceived = 0
    m_lngBytesSent = 0
    lngRetVal = GetIfTable(ByVal 0&, lngSize, 0)
    If lngRetVal = ERROR_NOT_SUPPORTED Then
        MsgBox "IP HlpAPI is not supported by your system."
        Exit Function
    End If
    ReDim arrBuffer(0 To lngSize - 1) As Byte
    lngRetVal = GetIfTable(arrBuffer(0), lngSize, 0)
    If lngRetVal = ERROR_SUCCESS Then
        CopyMemory lngRows, arrBuffer(0), 4
        For i = 1 To lngRows
            CopyMemory IfRowTable, arrBuffer(4 + (i - 1) * Len(IfRowTable)), Len(IfRowTable)
            With IfRowTable
                objInterface.InterfaceDescription = Left$(StrConv(.bDescr, vbUnicode), .dwDescrLen)
                If .dwPhysAddrLen > 0 Then
                    For j = 0 To .dwPhysAddrLen - 1
                        objInterface.AdapterAddress = objInterface.AdapterAddress & CStr(IIf(.bPhysAddr(j) = 0, "00", Hex$(.bPhysAddr(j)))) & "-"
                    Next j
                    objInterface.AdapterAddress = Left$(objInterface.AdapterAddress, Len(objInterface.AdapterAddress) - 1)
                    objInterface.AdminStatus = .dwAdminStatus
                    objInterface.InterfaceIndex = .dwIndex
                    objInterface.DiscardedIncomingPackets = .dwInDiscards
                    objInterface.IncomingErrors = .dwInErrors
                    objInterface.NonunicastPacketsReceived = .dwInNUcastPkts
                    objInterface.OctetsReceived = .dwInOctets
                    objInterface.UnicastPacketsReceived = .dwInUcastPkts
                    objInterface.UnknownProtocolPackets = .dwInUnknownProtos
'objInterface.LastChange = .dwLastChange
                    objInterface.MaximumTransmissionUnit = .dwMtu
                    objInterface.OperationalStatus = .dwOperStatus
                    objInterface.DiscardedOutgoingPackets = .dwOutDiscards
                    objInterface.OutgoingErrors = .dwOutErrors
                    objInterface.NonunicastPacketsSent = .dwOutNUcastPkts
                    objInterface.OctetsSent = .dwOutOctets
                    objInterface.OutputQueueLength = .dwOutQLen
                    objInterface.UnicastPacketsSent = .dwOutUcastPkts
                    objInterface.Speed = .dwSpeed
                    objInterface.InterfaceType = .dwType
                    objInterface.InterfaceName = StrConv(.wszName, vbUnicode)
                    m_lngBytesReceived = .dwInOctets
                    m_lngBytesSent = .dwOutOctets
                End If
            End With
            mvarInterfaces.Add objInterface
        Next i
    End If
End Function
Public Property Get Interfaces() As CInterfaces
    Set mvarInterfaces = Nothing
    Set mvarInterfaces = New CInterfaces
    Call InitInterfaces(mvarInterfaces)
    Set Interfaces = mvarInterfaces
End Property
Public Property Set Interfaces(ByVal vData As CInterfaces)
    Set mvarInterfaces = vData
End Property