[VBnet Network] GetTcpStatistics: Get Local Machine TCP Statistics

	Visual Basic Network Services GetTcpStatistics: Get Local Machine TCP Statistics

Posted:	Sunday February 11, 2001
Updated:	Monday December 26, 2011

Applies to:	VB4-32, VB5, VB6
Developed with:	VB6, Windows 2000
OS restrictions:	Windows 98, NT4 SP4+, Windows 2000, Windows XP or later
Author:	VBnet - Randy Birch

Related:	gethostbyname: Determine Network Host Name and IP Address gethostbyname: Resolve Host Name to IP Address gethostbyaddr: Obtain Host Name from IP Address IcmpSendEcho: Ping a Machine by Host Name

Prerequisites

One of the operating systems listed under OS Restrictions above.

The GetTcpStatistics function retrieves the TCP statistics for the local computer.

BAS Module Code

None.

Form Code

To a form add a command button (Command1), and a listview (Listview1). The code creates the required columns. Add the following to the form:

Option Explicit

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Copyright ©1996-2011 VBnet/Randy Birch, All Rights Reserved.
' Some pages may also contain other copyrights by the author.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Distribution: You can freely use this code in your own
'               applications, but you may not reproduce 
'               or publish this code on any web site,
'               online service, or distribute as source 
'               on any media without express permission.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Private Const ERROR_SUCCESS        As Long = 0
Private Const MIB_TCP_RTO_OTHER    As Long = 1
Private Const MIB_TCP_RTO_CONSTANT As Long = 2
Private Const MIB_TCP_RTO_RSRE     As Long = 3
Private Const MIB_TCP_RTO_VANJ     As Long = 4

Private Type MIB_TCPSTATS
   dwRtoAlgorithm   As Long  'time-out algorithm
   dwRtoMin         As Long  'minimum time-out
   dwRtoMax         As Long  'maximum time-out
   dwMaxConn        As Long  'maximum connections
   dwActiveOpens    As Long  'active opens
   dwPassiveOpens   As Long  'passive opens
   dwAttemptFails   As Long  'failed attempts
   dwEstabResets    As Long  'established connections reset
   dwCurrEstab      As Long  'established connections
   dwInSegs         As Long  'segments received
   dwOutSegs        As Long  'segment sent
   dwRetransSegs    As Long  'segments retransmitted
   dwInErrs         As Long  'incoming errors
   dwOutRsts        As Long  'outgoing resets
   dwNumConns       As Long  'cumulative connections
End Type

Private Declare Function GetTcpStatistics Lib "iphlpapi.dll" _
   (ByRef pTcpStats As MIB_TCPSTATS) As Long
   
   
Private Sub Form_Load()
   
   Dim itmx As ListItem

   ListView1.ColumnHeaders.Add , , "Information"
   ListView1.ColumnHeaders.Add , , "TCP Statistics"

   With ListView1.ListItems
      Set itmx = .Add(, , "time-out algorithm")
      Set itmx = .Add(, , "minimum time-out")
      Set itmx = .Add(, , "maximum time-out")
      Set itmx = .Add(, , "maximum connections")
      
      Set itmx = .Add(, , "active opens")
      Set itmx = .Add(, , "passive opens")
      
      Set itmx = .Add(, , "failed attempts")
      Set itmx = .Add(, , "established connections reset")
      Set itmx = .Add(, , "established connections")
      
      Set itmx = .Add(, , "segments received")
      Set itmx = .Add(, , "segment sent")
      Set itmx = .Add(, , "segments retransmitted")
      
      Set itmx = .Add(, , "incoming errors")
      Set itmx = .Add(, , "outgoing resets")
      Set itmx = .Add(, , "cumulative connections")

   End With
   
   ListView1.View = lvwReport
   
End Sub


Private Sub ListView1_ColumnClick(ByVal ColumnHeader As MSComctlLib.ColumnHeader)

  ListView1.SortKey = ColumnHeader.Index - 1
  ListView1.SortOrder = Abs(Not ListView1.SortOrder = 1)
  ListView1.Sorted = True
  
End Sub


Private Sub Command1_Click()

   Dim TcpStat As MIB_TCPSTATS
   Dim buff() As Byte
   Dim cbRequired As Long
   Dim nStructSize As Long
   Dim nRows As Long
   Dim tmp As String
   Dim itmx As ListItem
   
   If GetTcpStatistics(TcpStat) = ERROR_SUCCESS Then
                 
      With ListView1
            
         Select Case TcpStat.dwRtoAlgorithm
            Case MIB_TCP_RTO_CONSTANT: tmp = "Constant Time-out"
            Case MIB_TCP_RTO_RSRE:     tmp = "MIL-STD-1778 Appendix B"
            Case MIB_TCP_RTO_VANJ:     tmp = "Van Jacobson's Algorithm"
            Case MIB_TCP_RTO_OTHER:    tmp = "Other"
         End Select


         Set itmx = .ListItems(1)
         itmx.SubItems(1) = TcpStat.dwRtoAlgorithm & " - " & tmp

         Set itmx = .ListItems(2)
         itmx.SubItems(1) = TcpStat.dwRtoMin
         
         Set itmx = .ListItems(3)
         itmx.SubItems(1) = TcpStat.dwRtoMax
         
         Set itmx = .ListItems(4)
         itmx.SubItems(1) = TcpStat.dwMaxConn
         
         Set itmx = .ListItems(5)
         itmx.SubItems(1) = TcpStat.dwActiveOpens
         
         Set itmx = .ListItems(6)
         itmx.SubItems(1) = TcpStat.dwPassiveOpens
         
         Set itmx = .ListItems(7)
         itmx.SubItems(1) = TcpStat.dwAttemptFails
         
         Set itmx = .ListItems(8)
         itmx.SubItems(1) = TcpStat.dwEstabResets
                  
         Set itmx = .ListItems(9)
         itmx.SubItems(1) = TcpStat.dwCurrEstab
         
         Set itmx = .ListItems(10)
         itmx.SubItems(1) = TcpStat.dwInSegs
                  
         Set itmx = .ListItems(11)
         itmx.SubItems(1) = TcpStat.dwOutSegs
         
         Set itmx = .ListItems(12)
         itmx.SubItems(1) = TcpStat.dwRetransSegs
         
         Set itmx = .ListItems(13)
         itmx.SubItems(1) = TcpStat.dwInErrs
         
         Set itmx = .ListItems(14)
         itmx.SubItems(1) = TcpStat.dwOutRsts
                  
         Set itmx = .ListItems(15)
         itmx.SubItems(1) = TcpStat.dwNumConns

      End With
            
   End If

End Sub

Comments

PayPal Link