Visual Basic Network Services

GetIfTable: Local Machine Network Interface Table
     
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
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 GetIfTable function returns a table of MIB_IFROW entries, one for each interface on the computer.

Note: The demo uses the VB6 FormatNumber function, which is not available in VB4-32 or VB5. Users of these versions should use Format$() instead, i.e. Format$(value, "###,###,###).

 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 MAX_INTERFACE_NAME_LEN  As Long = 256
Private Const ERROR_SUCCESS   As Long = 0
Private Const MAXLEN_IFDESCR    As Long = 256
Private Const MAXLEN_PHYSADDR   As Long = 8

Private Const MIB_IF_OPER_STATUS_NON_OPERATIONAL As Long = 0
Private Const MIB_IF_OPER_STATUS_UNREACHABLE     As Long = 1
Private Const MIB_IF_OPER_STATUS_DISCONNECTED    As Long = 2
Private Const MIB_IF_OPER_STATUS_CONNECTING      As Long = 3
Private Const MIB_IF_OPER_STATUS_CONNECTED       As Long = 4
Private Const MIB_IF_OPER_STATUS_OPERATIONAL     As Long = 5

Private Const MIB_IF_TYPE_OTHER       As Long = 1
Private Const MIB_IF_TYPE_ETHERNET    As Long = 6
Private Const MIB_IF_TYPE_TOKENRING   As Long = 9
Private Const MIB_IF_TYPE_FDDI        As Long = 15
Private Const MIB_IF_TYPE_PPP         As Long = 23
Private Const MIB_IF_TYPE_LOOPBACK    As Long = 24
Private Const MIB_IF_TYPE_SLIP        As Long = 28

Private Const MIB_IF_ADMIN_STATUS_UP        As Long = 1
Private Const MIB_IF_ADMIN_STATUS_DOWN      As Long = 2
Private Const MIB_IF_ADMIN_STATUS_TESTING   As Long = 3
   
Private Type MIB_IFROW
   wszName(0 To (MAX_INTERFACE_NAME_LEN - 1) * 2) As Byte
   dwIndex              As Long
   dwType               As Long
   dwMtu                As Long
   dwSpeed              As Long
   dwPhysAddrLen        As Long
   bPhysAddr(0 To MAXLEN_PHYSADDR - 1) As Byte
   dwAdminStatus        As Long
   dwOperStatus         As Long
   dwLastChange         As Long
   dwInOctets           As Long
   dwInUcastPkts        As Long
   dwInNUcastPkts       As Long
   dwInDiscards         As Long
   dwInErrors           As Long
   dwInUnknownProtos    As Long
   dwOutOctets          As Long
   dwOutUcastPkts       As Long
   dwOutNUcastPkts      As Long
   dwOutDiscards        As Long
   dwOutErrors          As Long
   dwOutQLen            As Long
   dwDescrLen           As Long
   bDescr(0 To MAXLEN_IFDESCR - 1) As Byte

End Type
   
Private Declare Function GetIfTable Lib "iphlpapi.dll" _
  (ByRef pIfTable As Any, _
   ByRef pdwSize As Long, _
   ByVal bOrder As Long) As Long

Private Declare Sub CopyMemory Lib "kernel32" _
  Alias "RtlMoveMemory" _
  (pDst As Any, _
   pSrc As Any, _
   ByVal ByteLen As Long)
  
Private Declare Function inet_ntoa Lib "wsock32" _
   (ByVal addr As Long) As Long

Private Declare Function lstrcpyA Lib "kernel32" _
  (ByVal RetVal As String, _
   ByVal Ptr As Long) As Long
                        
Private Declare Function lstrlenA Lib "kernel32" _
  (ByVal Ptr As Any) As Long
  
Private Declare Function GetFriendlyIfIndex Lib "iphlpapi" _
   (ByVal IfIndex As Long) As Long  



Private Sub Form_Load()

   Dim itmx As ListItem

   ListView1.View = lvwReport
   Listview1.ColumnHeaders.Add , , "Information"

   With Listview1.ListItems
   
      Set itmx = .Add(, "bDescr", "description of interface")

      Set itmx = .Add(, , "interface index")
      Set itmx = .Add(, , "interface type")
      Set itmx = .Add(, , "Maximum Transmission Unit")
      Set itmx = .Add(, , "interface speed (bps)")
      Set itmx = .Add(, , "physical address (decimal)")
      Set itmx = .Add(, , "physical address (hex)")
      Set itmx = .Add(, , "admin enabled or disabled")
      Set itmx = .Add(, , "interface operational status")
      Set itmx = .Add(, , "last time op status changed")
      
      Set itmx = .Add(, , "data received (octets)")
      Set itmx = .Add(, , "packets received (unicast)")
      Set itmx = .Add(, , "packets received (non-unicast)")
      Set itmx = .Add(, , "packets discarded")
      Set itmx = .Add(, , "discarded with errors")
      Set itmx = .Add(, , "discarded, unknown protocol")
      
      Set itmx = .Add(, , "data sent (octets)")
      Set itmx = .Add(, , "packets sent (unicast)")
      Set itmx = .Add(, , "packets sent (non-unicast)")
      Set itmx = .Add(, , "packets discarded, no errors")
      Set itmx = .Add(, , "packets discarded with errors")
      Set itmx = .Add(, , "output queue length")
   End With
      
End Sub


Public Function GetInetStrFromPtr(ByVal Address As Long) As String

   GetInetStrFromPtr = GetStrFromPtrA(inet_ntoa(Address))

End Function


Public Function GetStrFromPtrA(ByVal lpszA As Long) As String

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


Private Sub Command1_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
      
        'saves using LenB in the CopyMemory calls below
         nStructSize = LenB(IPInterfaceRow)
   
        'first 4 bytes is a long indicating the
        'number of entries in the table
         CopyMemory nRows, buff(0), 4
      
         For cnt = 1 To nRows
         
           'moving past the four bytes obtained
           'above, get one chunk of data and cast
           'into an IPInterfaceRow type
            CopyMemory IPInterfaceRow, buff(4 + (cnt - 1) * nStructSize), nStructSize
            
            With Listview1
            
               .ColumnHeaders.Add , , "Adapter " & CStr(cnt)
               
               Set itmx = .ListItems(1)
               itmx.SubItems(cnt) = TrimNull(StrConv(IPInterfaceRow.bDescr, vbUnicode))

               Set itmx = .ListItems(2)
               itmx.SubItems(cnt) = GetFriendlyIfIndex(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 = 0 To IPInterfaceRow.dwPhysAddrLen -1
                  tmp = tmp & IPInterfaceRow.bPhysAddr(n) & " "
                  Next
               Print
               Set itmx = .ListItems(6)
               itmx.SubItems(cnt) = tmp
               tmp = ""
               
               For n = 0 To IPInterfaceRow.dwPhysAddrLen -1
                  tmp = tmp & Hex(IPInterfaceRow.bPhysAddr(n)) & " "
                  Next
               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 = "Non-operational"
                  Case MIB_IF_OPER_STATUS_UNREACHABLE:      tmp = "Unreachable"
                  Case MIB_IF_OPER_STATUS_DISCONNECTED:     tmp = "Disconnected"
                  Case MIB_IF_OPER_STATUS_CONNECTING:       tmp = "Connecting"
                  Case MIB_IF_OPER_STATUS_CONNECTED:        tmp = "Connected"
                  Case MIB_IF_OPER_STATUS_OPERATIONAL:      tmp = "Operational"
               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 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
 Comments

 
 

PayPal Link
Make payments with PayPal - it's fast, free and secure!

 
 
 
 

Copyright 1996-2011 VBnet and Randy Birch. All Rights Reserved.
Terms of Use  |  Your Privacy

 

Hit Counter