Visual Basic Network Services
WSAEnumProtocols: Additional Data from Enumerated Windows Socket Protocols
     
Posted:   Friday January 02, 2009
Updated:   Monday December 26, 2011
     
Applies to:   VB4-32, VB5, VB6
Developed with:   VB6, Windows XP
OS restrictions:   Windows 2000 or later
Author:   VBnet - Randy Birch
   
Related:   WSAEnumProtocols: Enumerating Installed Windows Socket Protocols
     
 Prerequisites
None. 

The WSAEnumProtocols function is used to discover information about the collection of transport protocols and protocol chains installed on the local computer. Since layered protocols are only usable by applications when installed in protocol chains, information on layered protocols is not included in lpProtocolBuffer. The lpiProtocols parameter can be used as a filter to constrain the amount of information provided. Often, lpiProtocols will be specified as a NULL pointer that will cause the function to return information on all available transport protocols and protocol chains.

A WSAPROTOCOL_INFO structure is provided in the buffer pointed to by lpProtocolBuffer for each requested protocol. If the specified buffer is not large enough (as indicated by the input value of lpdwBufferLength ), the value pointed to by lpdwBufferLength will be updated to indicate the required buffer size. The application should then obtain a large enough buffer and call WSAEnumProtocols again.

The order in which the WSAPROTOCOL_INFO structures appear in the buffer coincides with the order in which the protocol entries were registered by the service provider using the WS2_32.DLL, or with any subsequent reordering that occurred through the Windows Sockets application or DLL supplied for establishing default TCP/IP providers.

This demo returns the names of the installed protocols into List1, and other WSAPROTOCOL_INFO in List2 and List3.

 BAS Module Code
None.

 Form Code
To a form add a command button (Command1), list box (List1). 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_PROTOCOL_CHAIN As Long = 7
Private Const IP_SUCCESS As Long = 0
Private Const MAX_WSADescription As Long = 256
Private Const MAX_WSASYSStatus As Long = 128
Private Const WSAPROTOCOL_LEN As Long = 255
Private Const WS_VERSION_REQD As Long = &H101

Private Const XP1_CONNECTIONLESS As Long = &H1
Private Const XP1_GUARANTEED_DELIVERY As Long = &H2
Private Const XP1_GUARANTEED_ORDER As Long = &H4
Private Const XP1_MESSAGE_ORIENTED As Long = &H8
Private Const XP1_PSEUDO_STREAM As Long = &H10
Private Const XP1_GRACEFUL_CLOSE As Long = &H20
Private Const XP1_EXPEDITED_DATA As Long = &H40
Private Const XP1_CONNECT_DATA As Long = &H80
Private Const XP1_DISCONNECT_DATA As Long = &H100
Private Const XP1_SUPPORT_BROADCAST As Long = &H200
Private Const XP1_SUPPORT_MULTIPOINT As Long = &H400
Private Const XP1_MULTIPOINT_CONTROL_PLANE As Long = &H800
Private Const XP1_MULTIPOINT_DATA_PLANE As Long = &H1000
Private Const XP1_QOS_SUPPORTED As Long = &H2000
Private Const XP1_INTERRUPT As Long = &H4000
Private Const XP1_UNI_SEND As Long = &H8000
Private Const XP1_UNI_RECV As Long = &H10000
Private Const XP1_IFS_HANDLES As Long = &H20000
Private Const XP1_PARTIAL_MESSAGE As Long = &H40000

Private Type WSAPROTOCOLCHAIN
   ChainLen As Long '/* the length of the chain, */
                    '/* length = 0 means layered protocol, */
                    '/* length = 1 means base protocol, */
                    '/* length > 1 means protocol chain */
   ChainEntries(0 To MAX_PROTOCOL_CHAIN - 1) As Long '/* a list ofdwCatalogEntryIds */
 End Type

Private Type GUID
   Data1 As Long
   Data2 As Integer
   Data3 As Integer
   Data4(0 To 7) As Byte
End Type

Private Type WSAPROTOCOL_INFO
   dwServiceFlags1 As Long
   dwServiceFlags2 As Long
   dwServiceFlags3 As Long
   dwServiceFlags4 As Long
   dwProviderFlags As Long
   ProviderId As GUID
   dwCatalogEntryId As Long
   ProtocolChain As WSAPROTOCOLCHAIN
   iVersion As Integer
   iAddressFamily As Long
   iMaxSockAddr As Long
   iMinSockAddr As Long
   iSocketType As Long
   iProtocol As Long
   iProtocolMaxOffset As Long
   iNetworkByteOrder As Long
   iSecurityScheme As Long
   dwMessageSize As Long
   dwProviderReserved As Long
   szProtocol(0 To WSAPROTOCOL_LEN) As Byte
End Type

Private Type WSADATA
   wVersion As Integer
   wHighVersion As Integer
   szDescription(0 To MAX_WSADescription) As Byte
   szSystemStatus(0 To MAX_WSASYSStatus) As Byte
   wMaxSockets As Integer
   wMaxUDPDG As Integer
   dwVendorInfo As Long
End Type

Private Declare Function WSAStartup Lib "WSOCK32" _
  (ByVal wVersionRequired As Long, _
   lpWSADATA As WSADATA) As Long

Private Declare Function WSACleanup Lib "WSOCK32" () As Long

Private Declare Function WSAEnumProtocols Lib "ws2_32.dll" _
  Alias "WSAEnumProtocolsA" _
 (ByVal lpiProtocols As Long, _
  lpProtocolBuffer As Any, _
  lpdwBufferLength As Long) As Long

Private Declare Function StringFromGUID2 Lib "ole32.dll" _
  (lpGuid As GUID, _
   ByVal lpszOut As String, _
   ByVal cchMax As Long) As Long



Private Sub Form_Load()

   Command1.Caption = "WSAEnumProtocols"
   
End Sub


Private Sub Command1_Click()

   Dim cbBuff As Long
   Dim numEntries As Long
   Dim lpBuff() As WSAPROTOCOL_INFO
   Dim ret As Long
   Dim n As Long
   
   Const WSABASEERR = 10000
   Const WSAENOBUFS = WSABASEERR + 55

  'initialize Ws2_32.dll
   If SocketsInitialize() Then
   
      List1.Clear
   
     'create a buffer too small for the call
      ReDim lpBuff(0) As WSAPROTOCOL_INFO
   
      ret = WSAEnumProtocols(0&, lpBuff(0), cbBuff)
   
     'the error indicates the buffer passed
     'was insufficient, and cbBuffs specifies
     'the size of the buffer required to retrieve
     'all data
      If ret = -1 And Err.LastDllError = WSAENOBUFS Then
      
        'number of entries is buffer divided
        'by size of one WSAPROTOCOL_INFO type
         numEntries = (cbBuff) \ LenB(lpBuff(0))
      
        'dimension to 0-base
         ReDim lpBuff(0 To numEntries - 1) As WSAPROTOCOL_INFO
         
        'and call again
         If WSAEnumProtocols(0&, lpBuff(0), cbBuff) > 0 Then
         
           'add the retrieved items to a listbox
            For n = 0 To numEntries - 1
            
               List1.AddItem StrConv(lpBuff(n).szProtocol, vbUnicode)
               List1.ItemData(List1.NewIndex) = lpBuff(n).dwServiceFlags1
               
               List2.AddItem lpBuff(n).iAddressFamily & vbTab & _
                             lpBuff(n).iMinSockAddr & vbTab & _
                             lpBuff(n).iMaxSockAddr & vbTab & _
                             lpBuff(n).iNetworkByteOrder & vbTab & _
                             lpBuff(n).iProtocol & vbTab & _
                             lpBuff(n).iProtocolMaxOffset & vbTab & _
                             lpBuff(n).iSecurityScheme & vbTab & _
                             lpBuff(n).iSocketType & vbTab & _
                             lpBuff(n).iVersion & vbTab & _
                             "&H" & Hex(lpBuff(n).dwMessageSize)

                  List3.AddItem ConvertGuidToString(lpBuff(n).ProviderId)

            Next
         End If  'WSAEnumProtocols
      
      End If  'ret = -1
   
   End If  'SocketsInitialize

   SocketsCleanup

End Sub


Private Sub List1_Click()

   Text1.Text = GetServiceFlagsDesc(List1.ItemData(List1.ListIndex))
   
   List2.TopIndex = List1.TopIndex
   List3.TopIndex = List1.TopIndex
   
   List2.Selected(List1.ListIndex) = True
   List3.Selected(List1.ListIndex) = True

End Sub


Private Function ConvertGuidToString(lpGuid As GUID) As String

    Dim nChars As Long
    Dim ret As Long
    Dim sBuff As String

    sBuff = Space$(80)
    nChars = Len(sBuff)

    ret = StringFromGUID2(lpGuid, sBuff, nChars)
    
    If ret > 0 Then
        ConvertGuidToString = Left$(StrConv(sBuff, vbFromUnicode), ret - 1)
    End If

End Function


Private Function GetServiceFlagsDesc(ByVal flag As Long) As String

   Dim s As String
   Dim nl As String
   
   nl = vbCrLf
   
          If flag And XP1_CONNECTIONLESS Then s = "Provides connectionless (datagram) service" & nl
     If flag And XP1_GUARANTEED_DELIVERY Then s = s & "Guarantees all data sent will reach intended destination" & nl
        If flag And XP1_GUARANTEED_ORDER Then s = s & "Guarantees data only arrives in order sent" & nl
        If flag And XP1_MESSAGE_ORIENTED Then s = s & "Honors message boundaries" & nl
           If flag And XP1_PSEUDO_STREAM Then s = s & "Message-oriented; boundaries ignored for receipts" & nl
          If flag And XP1_GRACEFUL_CLOSE Then s = s & "Supports two-phase (graceful) close" & nl
          If flag And XP1_EXPEDITED_DATA Then s = s & "Supports expedited (urgent) data" & nl
            If flag And XP1_CONNECT_DATA Then s = s & "Supports connect data" & nl
         If flag And XP1_DISCONNECT_DATA Then s = s & "Supports disconnect data" & nl
       If flag And XP1_SUPPORT_BROADCAST Then s = s & "Supports broadcast mechanism" & nl
      If flag And XP1_SUPPORT_MULTIPOINT Then s = s & "Supports multipoint or multicast" & nl
If flag And XP1_MULTIPOINT_CONTROL_PLANE Then s = s & "Control plane rooted (= 1) or nonrooted (= 0)" & nl
   If flag And XP1_MULTIPOINT_DATA_PLANE Then s = s & "Data plane is rooted (= 1) or nonrooted (= 0). " & nl
           If flag And XP1_QOS_SUPPORTED Then s = s & "Supports quality of service requests" & nl
               If flag And XP1_INTERRUPT Then s = s & "Bit is reserved" & nl
                If flag And XP1_UNI_SEND Then s = s & "Unidirectional in send direction" & nl
                If flag And XP1_UNI_RECV Then s = s & "Unidirectional in recv direction" & nl
             If flag And XP1_IFS_HANDLES Then s = s & "Socket descriptors returned are OS Installable File System (IFS) handles" & nl
         If flag And XP1_PARTIAL_MESSAGE Then s = s & "supported in WSASend and WSASendTo" & nl
         
   GetServiceFlagsDesc = s

End Function


Public Function SocketsInitialize() As Boolean

   Dim WSAD As WSADATA
   SocketsInitialize = WSAStartup(WS_VERSION_REQD, WSAD) = IP_SUCCESS
    
End Function


Public Sub SocketsCleanup()
   
   If WSACleanup() <> 0 Then
       MsgBox "Windows Sockets error occurred in Cleanup.", vbExclamation
   End If
    
End Sub
 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