Beispiel:

Option Explicit
 
Public Type PortInfo_t
  sPortName           As String
  sMonitorName        As String
  sDescription        As String
  sPortType           As String
End Type
 
Private Type PORT_INFO_2
  pPortName          As Long
  pMonitorName       As Long
  pDescription       As Long
  fPortType          As Long
  Reserved           As Long
End Type
 
Public Declare Function lstrlenA _
    Lib "kernel32" _
    (ByVal Ptr As Any) As Long
 
Public Declare Function lstrcpyA _
    Lib "kernel32" _
    (ByVal RetVal As String, _
    ByVal Ptr As Long) As Long
 
Public Declare Function EnumPorts _
    Lib "winspool.drv" Alias _
    "EnumPortsA" _
    (ByVal pName As String, _
    ByVal nLevel As Long, _
    lpbPorts As Any, _
    ByVal cbBuf As Long, _
    pcbNeeded As Long, _
    pcReturned As Long) As Long
 
Public Function GetPortList( _
                auPorts() As PortInfo_t) As Long
  '// -----------------------------------------------------
  '// Methode:   | Alle verfügbaren Ports ermitteln;
  '//            | benötigt Hilfsfunktion GetStrFromPtrA
  '// -----------------------------------------------------
  '// Parameter: | auPorts - Strukturvariable
  '// -----------------------------------------------------
  '// Rückgabe:  | gefüllte Strukturvariable
  '// -----------------------------------------------------
  '// Autor:     | Stefan Kulpa
  '//            | EDV Innovation & Consulting - Dormagen
  '// -----------------------------------------------------
  '// Beispiel:
  '// -----------------------------------------------------
  '// Dim auPorts()   As PortInfo_t
  '// Dim lResult     As Long
  '// Dim lCount      As Long
  '// lResult = GetPortList(auPorts)
  '// Debug.Print "Port|Typ|Beschreibung|Monitorname"
  '// For lCount = 0 To lResult - 1
  '//     With auPorts(lCount)
  '//         Debug.Print .sPortName; "|"; _
   '//                     .sPortType; "|"; _
   '//                     .sDescription; "|"; _
   '//                     .sMonitorName
  '//     End With
  '// Next
  '// -----------------------------------------------------
  Const PORT_TYPE_WRITE           As Long = &H1
  Const PORT_TYPE_READ            As Long = &H2
  Const PORT_TYPE_REDIRECTED      As Long = &H4
  Const PORT_TYPE_NET_ATTACHED    As Long = &H8
  Const SIZEOFPORT_INFO_2         As Long = 20
 
  Dim auPortInfo2()               As PORT_INFO_2
  Dim lcReturned                  As Long
  Dim lcbNeeded                   As Long
  Dim lCount                      As Long
  Dim sPortType As String
 
  Call EnumPorts(vbNullString, 2, 0, 0, lcbNeeded, _
      lcReturned)
 
  If lcbNeeded Then
    ReDim auPortInfo2((lcbNeeded / SIZEOFPORT_INFO_2))
    If EnumPorts(vbNullString, _
        2, _
        auPortInfo2(0), _
        lcbNeeded, _
        lcbNeeded, _
        lcReturned) Then
      For lCount = 0 To (lcReturned - 1)
        sPortType = vbNullString
        ReDim Preserve auPorts(lCount + 1)
        With auPortInfo2(lCount)
          If (.fPortType And PORT_TYPE_WRITE) Then _
              sPortType = "write"
          If (.fPortType And PORT_TYPE_READ) Then
            If Len(sPortType) > 0 Then _
                sPortType = sPortType & ", "
            sPortType = sPortType & "read"
          End If
          If (.fPortType And PORT_TYPE_REDIRECTED) Then
            If Len(sPortType) > 0 Then _
                sPortType = sPortType & ", "
            sPortType = sPortType & "redirected"
          End If
          If (.fPortType And PORT_TYPE_NET_ATTACHED) Then
            If Len(sPortType) > 0 Then _
                sPortType = sPortType & ", "
            sPortType = sPortType & "network"
          End If
          auPorts(lCount).sPortType = sPortType
          auPorts(lCount).sPortName = _
              GetStrFromPtrA(.pPortName)
          auPorts(lCount).sDescription = _
              GetStrFromPtrA(.pDescription)
          auPorts(lCount).sMonitorName = _
              GetStrFromPtrA(.pMonitorName)
        End With
      Next
    End If
  End If
  GetPortList = lcReturned
 
End Function
 
Public Function GetStrFromPtrA( _
                ByVal lpszA As Long) _
                As String
 
  On Error Resume Next
  GetStrFromPtrA = VBA.String$(lstrlenA(ByVal lpszA), 0)
  Call lstrcpyA(ByVal GetStrFromPtrA, ByVal lpszA)
 
End Function