ipStats.cls
上传用户:gzgold
上传日期:2013-02-21
资源大小:36k
文件大小:4k
源码类别:

多显示器编程

开发平台:

Visual Basic

  1. VERSION 1.0 CLASS
  2. BEGIN
  3.   MultiUse = -1  'True
  4.   Persistable = 0  'NotPersistable
  5.   DataBindingBehavior = 0  'vbNone
  6.   DataSourceBehavior  = 0  'vbNone
  7.   MTSTransactionMode  = 0  'NotAnMTSObject
  8. END
  9. Attribute VB_Name = "ipStats"
  10. Attribute VB_GlobalNameSpace = False
  11. Attribute VB_Creatable = True
  12. Attribute VB_PredeclaredId = False
  13. Attribute VB_Exposed = False
  14. Attribute VB_Ext_KEY = "SavedWithClassBuilder6" ,"Yes"
  15. Attribute VB_Ext_KEY = "Top_Level" ,"Yes"
  16. Option Explicit
  17. 'Gives stats on IP connections - TCP, UDP and ICMP.
  18. 'This code is copyright 2000 Nick Johnson.
  19. 'This code may be reused and modified for non-commercial
  20. 'purposes only as long as credit is given to the author
  21. 'in the programmes about box and it's documentation.
  22. 'If you use this code, please email me at:
  23. 'arachnid@mad.scientist.com and let me know what you think
  24. 'and what you are doing with it.
  25. 'Winapi calls
  26. Private Declare Function GetTcpTable Lib "IPhlpAPI" (pTcpTable As MIB_TCPTABLE, pdwSize As Long, bOrder As Long) As Long
  27. Private Declare Function FormatMessage Lib "kernel32" Alias "FormatMessageA" (ByVal dwFlags As Long, lpSource As Any, ByVal dwMessageId As Long, ByVal dwLanguageId As Long, ByVal lpBuffer As String, ByVal nSize As Long, Arguments As Long) As Long
  28. 'Winapi structures
  29. Private Type MIB_TCPROW
  30.   dwState As tcpStates
  31.   dwLocalAddr(0 To 3) As Byte
  32.   dwLocalPort As String * 4
  33.   dwRemoteAddr(0 To 3) As Byte
  34.   dwRemotePort As String * 4
  35. End Type
  36. Private Type MIB_TCPTABLE
  37.   dwNumEntries As Long    'number of entries in the table
  38.   table(100) As MIB_TCPROW   'array of TCP connections
  39. End Type
  40. 'Property variables
  41. Private trRows() As tcpRow
  42. 'Function to get active & listening TCP connections
  43. Public Function getTCPConnections() As Boolean
  44.     Dim lngSize As Long
  45.     Dim lngReturn As Long
  46.     Dim tcpTable As MIB_TCPTABLE
  47.     Dim intCount As Integer
  48.     
  49.     'The size of the tcpTable structure
  50.     lngSize = 20 * 100 + 4
  51.     lngReturn = GetTcpTable(tcpTable, lngSize, True)
  52.     Select Case lngReturn
  53.     Case 0
  54.         'Success - copy structure to the array of ipStats
  55.         ReDim trRows(0 To tcpTable.dwNumEntries - 1)
  56.         For intCount = 0 To tcpTable.dwNumEntries - 1
  57.             Set trRows(intCount) = New tcpRow
  58.             trRows(intCount).LocalIP = tcpTable.table(intCount).dwLocalAddr
  59.             trRows(intCount).RemoteIP = tcpTable.table(intCount).dwRemoteAddr
  60.             trRows(intCount).LocalPort = c_port(tcpTable.table(intCount).dwLocalPort)
  61.             If tcpTable.table(intCount).dwState = TCP_STATE_ESTAB Then
  62.                 trRows(intCount).RemotePort = c_port(tcpTable.table(intCount).dwRemotePort)
  63.             Else
  64.                 trRows(intCount).RemotePort = 0
  65.             End If
  66.             trRows(intCount).State = tcpTable.table(intCount).dwState
  67.         Next intCount
  68.         getTCPConnections = True
  69.     Case 122
  70.         'Structure too small - can't gather. Solution on the way?
  71.         getTCPConnections = False
  72.     Case 232
  73.         'Not connected to a network. Return an empty array and set connected to false.
  74.         ReDim trRows(0 To 0)
  75.         getTCPConnections = True
  76.     Case Else
  77.         'Unknown error. Get the message and report it
  78.         Err.Raise 1 + vbObjectError, "ipStats", "Error getting connections:" & vbCrLf & "Number: " & Str(lngReturn) & vbCrLf & "Description: " & getErrorMessage(lngReturn)
  79.         getTCPConnections = False
  80.     End Select
  81. End Function
  82. Public Property Get RowData(index As Integer) As tcpRow
  83.     Set RowData = trRows(index)
  84. End Property
  85. Public Property Get RowCount() As Integer
  86.     RowCount = UBound(trRows) - LBound(trRows) + 1
  87. End Property
  88. 'Retrieves the windows error message for a specific code
  89. Private Function getErrorMessage(lngError As Long)
  90.     Dim lngLen As Long
  91.     Dim strOut As String
  92.     
  93.     strOut = Space(256)
  94.     lngLen = FormatMessage(&H1000, 0, lngError, 0, strOut, 255, 0)
  95.     getErrorMessage = Left(strOut, lngLen - 1)
  96. End Function
  97. 'Extracts the port number
  98. Private Function c_port(s) As Long
  99.     c_port = Asc(Mid(s, 1, 1))
  100.     c_port = c_port * 256
  101.     c_port = c_port + Asc(Mid(s, 2, 1))
  102.     'c_port = Asc(Mid(s, 1, 1)) * 256 + Asc(Mid(s, 2, 1))
  103. End Function