'модемы
"Select * From Win32_POTSModem"
oItem.AttachedTo
oItem.Name
oItem.DeviceID

'порты
"Select * from Win32_SerialPort"
oItem.DeviceID т.е. COM1,... COM100, возможны нестандартные имена
oItem.Caption (не обязательно)
oItem.PNPDeviceID (не обязательно, но желательно)

  hKeyDev = SetupDiOpenDevRegKey(hDeviceInfoSet, m_DeviceInfoData, _
   DICS_FLAG_GLOBAL, 0&, DIREG_DRV, KEY_ALL_ACCESS)
  If (hKeyDev = INVALID_HANDLE_VALUE) Then 'This call fails....
    hKeyDev = SetupDiCreateDevRegKey(hDeviceInfoSet, m_DeviceInfoData, DICS_FLAG_GLOBAL, 0, DIREG_DRV, 0, vbNullString)
...
  Debug.Print "hKeyDev=" & hKeyDev
  
  dwRet = RegSetValueEx(hKeyDev, "AttachedTo", 0&, REG_SZ, COM_Port, CLng(Len(COM_Port) + 1))
  RegCloseKey hKeyDev
...

Public Function EnumSerPortsFull(portname As String) As Long
  'если порт существует, то функция возвращает ненулевое значение
  Dim cc As COMMCONFIG, ccsize As Long
  '
  ccsize = LenB(cc) 'получаем размер структуры COMMCONFIG
  '
  EnumSerPortsFull = GetDefaultCommConfig(Trim(portname) + Chr(0), cc, ccsize)
  '
End Function

Public Function GetModemsList() As String
  Dim m_size As Long
  Dim i As Long
  Dim bResult As Boolean
  Dim m_ClassGUID() As GUID
  Dim hDeviceInfoSet As Long
  Dim wIndex As Long
  Dim m_DeviceInfoData As SP_DEVINFO_DATA
  Dim ReqSize As Long
  Dim strPropertyName As String
  Dim strDevInstanceID As String
  Dim strAttachedTo As String
  Dim hKeyDev As Long
  Dim str_modems As String
  
  bResult = SetupDiClassGuidsFromName("Modem", 0&, 0&, m_size)
  If (bResult = False) And (Err.LastDllError = ERROR_INSUFFICIENT_BUFFER) Then
    'Debug.Print "m_size=" & CStr(m_size)
    ReDim m_ClassGUID(0 To m_size - 1)
    bResult = SetupDiClassGuidsFromName("Modem", VarPtr(m_ClassGUID(0).Data1), m_size, 0&)
  Else
    If bResult Then
      'Debug.Print "SetupDiClassGuidsFromName Error. GUID not found."
    Else
      'Debug.Print "SetupDiClassGuidsFromName Error " & RaiseAPIErrorByNumber(Err.LastDllError)
    End If
    Exit Function
  End If
  
  For i = 0 To m_size - 1
    hDeviceInfoSet = SetupDiGetClassDevs(m_ClassGUID(i), vbNullString, 0&, _
     DIGCF_PROFILE) 'DIGCF_PRESENT Or 'Or DIGCF_ALLCLASSES
    If hDeviceInfoSet = INVALID_HANDLE_VALUE Then
      'Debug.Print "SetupDiGetClassDevs Error " & RaiseAPIErrorByNumber(Err.LastDllError)
    Else
      'Debug.Print "hDeviceInfoSet=" & hDeviceInfoSet
    
      wIndex = 0
      m_DeviceInfoData.cbSize = LenB(m_DeviceInfoData)
      Do
        bResult = SetupDiEnumDeviceInfo(hDeviceInfoSet, wIndex, m_DeviceInfoData)
        If (bResult = False) And (Err.LastDllError = ERROR_NO_MORE_ITEMS) Then Exit Do
        
        'Отображаемое имя модема
        strPropertyName = ""
        bResult = SetupDiGetDeviceRegistryProperty(hDeviceInfoSet, m_DeviceInfoData, _
         SPDRP_FRIENDLYNAME, 0, strPropertyName, 0, ReqSize)
        If (bResult = False) And (Err.LastDllError = ERROR_INSUFFICIENT_BUFFER) Then
          strPropertyName = String(ReqSize, Chr(0))
          SetupDiGetDeviceRegistryProperty hDeviceInfoSet, m_DeviceInfoData, SPDRP_FRIENDLYNAME, 0, _
           strPropertyName, ReqSize, 0
          If InStr(strPropertyName, Chr(0)) > 0 Then _
           strPropertyName = Left(strPropertyName, InStr(strPropertyName, Chr(0)) - 1)
        End If
        
        'InstanceID-уникальный идентификатор девайса
        strDevInstanceID = ""
        bResult = SetupDiGetDeviceInstanceId(hDeviceInfoSet, m_DeviceInfoData, strDevInstanceID, 0, ReqSize)
        If (bResult = False) And (Err.LastDllError = ERROR_INSUFFICIENT_BUFFER) Then
          strDevInstanceID = String(ReqSize, Chr(0))
          SetupDiGetDeviceInstanceId hDeviceInfoSet, m_DeviceInfoData, strDevInstanceID, ReqSize
          If InStr(strDevInstanceID, Chr(0)) > 0 Then _
           strDevInstanceID = Left(strDevInstanceID, InStr(strDevInstanceID, Chr(0)) - 1)
        End If
        
        'COM port (AttachedTo)
        strAttachedTo = ""
        hKeyDev = SetupDiOpenDevRegKey(hDeviceInfoSet, m_DeviceInfoData, _
         DICS_FLAG_GLOBAL, 0&, DIREG_DRV, KEY_QUERY_VALUE)
        If (hKeyDev = INVALID_HANDLE_VALUE) Then
          'Debug.Print "SetupDiOpenDevRegKey Error " & RaiseAPIErrorByNumber(Err.LastDllError)
        Else
          'Debug.Print "hKeyDev=" & hKeyDev
          strAttachedTo = GetRegValue(hKeyDev, "", "AttachedTo", "", False)
          RegCloseKey hKeyDev
        End If
        
        str_modems = str_modems & strAttachedTo & ": " & strPropertyName & " " & strDevInstanceID & vbCrLf
        
        wIndex = wIndex + 1
      Loop
    
      SetupDiDestroyDeviceInfoList hDeviceInfoSet
    End If
  Next
  GetModemsList = str_modems
End Function

        hKeyDev = SetupDiOpenDevRegKey(hDeviceInfoSet, m_DeviceInfoData, _
         DICS_FLAG_GLOBAL, 0&, DIREG_DRV, KEY_QUERY_VALUE)
        If (hKeyDev = INVALID_HANDLE_VALUE) Then
          'Debug.Print "SetupDiOpenDevRegKey Error " & RaiseAPIErrorByNumber(Err.LastDllError)
        Else
          'Debug.Print "hKeyDev=" & hKeyDev
          strAttachedTo = GetRegValue(hKeyDev, "", "AttachedTo", "", False)

  hKeyDev = SetupDiOpenDevRegKey(hDeviceInfoSet, m_DeviceInfoData, _
   DICS_FLAG_GLOBAL, 0&, DIREG_DRV, KEY_ALL_ACCESS)
  If (hKeyDev = INVALID_HANDLE_VALUE) Then 'This call fails....
    hKeyDev = SetupDiCreateDevRegKey(hDeviceInfoSet, m_DeviceInfoData, DICS_FLAG_GLOBAL, 0, DIREG_DRV, 0, vbNullString)
    If hKeyDev = INVALID_HANDLE_VALUE Then
      Debug.Print "SetupDiCreateDeviceInfoList Error " & RaiseAPIErrorByNumber(Err.LastDllError)
      bRemove = True
      GoTo Cleanup
    End If
  End If
  Debug.Print "hKeyDev=" & hKeyDev
  
  dwRet = RegSetValueEx(hKeyDev, "AttachedTo", 0&, REG_SZ, COM_Port, CLng(Len(COM_Port) + 1))
  RegCloseKey hKeyDev
  If dwRet <> ERROR_SUCCESS Then
    Debug.Print "RegSetValueEx Error " & RaiseAPIErrorByNumber(dwRet)
    bRemove = True
    GoTo Cleanup
  End If

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

Public Declare Function SetupDiClassGuidsFromName _
 Lib "setupapi.dll" Alias "SetupDiClassGuidsFromNameA" _
 (ByVal ClassName As String, _
 ByVal pClassGuidList As Long, _
 ByVal ClassGuidListSize As Long, _
 ByRef RequiredSize As Long) As Boolean

...
Dim m_ClassGUID() As GUID

  bResult = SetupDiClassGuidsFromName("Modem", 0&, 0&, m_size)
  If (bResult = False) And (Err.LastDllError = ERROR_INSUFFICIENT_BUFFER) Then
    ReDim m_ClassGUID(0 To m_size - 1)
    bResult = SetupDiClassGuidsFromName("Modem", VarPtr(m_ClassGUID(0).Data1), m_size, 0&)

Public Const GUID_DEVINTERFACE_MODEM As String = _
 "{2C7089AA-2E0E-11D1-B114-00C04FC2AAE4}"

Public Declare Function CLSIDFromString Lib "ole32" _
(ByVal lpsz As Long, ByRef pclsid As GUID) As Long 'pclsid As Clsid
Public Declare Function IIDFromString Lib "ole32.dll" _
 (ByVal lpszIID As Long, ByRef IID As GUID) As Long

...
  Dim m_ClassGUID As GUID 'единый GUID, а не массив
  
  'можно CLSIDFromString вместо IIDFromString -пофиг
  dwRes = IIDFromString(StrPtr(GUID_DEVINTERFACE_MODEM), m_ClassGUID)
  If dwRes <> S_OK Then
    Debug.Print "IIDFromString Error " & RaiseAPIErrorByNumber(dwRes)
    Exit Function
  End If

  'DIGCF_DEVICEINTERFACE для этого m_ClassGUID -существенно!!!
  hDeviceInfoSet = SetupDiGetClassDevs(m_ClassGUID, vbNullString, 0&, _
   DIGCF_PROFILE Or DIGCF_DEVICEINTERFACE)
  If hDeviceInfoSet = INVALID_HANDLE_VALUE Then
    'Debug.Print "SetupDiGetClassDevs Error " & RaiseAPIErrorByNumber(Err.LastDllError)
  Else
    'Debug.Print "hDeviceInfoSet=" & hDeviceInfoSet
  
    wIndex = 0
    m_DeviceInfoData.cbSize = LenB(m_DeviceInfoData)
    Do
      bResult = SetupDiEnumDeviceInfo(hDeviceInfoSet, wIndex, m_DeviceInfoData)
...

Public Function CheckCOMPort(ByVal i As Long) As Boolean
  Dim hPort As Long
  Dim m_tSA As SECURITY_ATTRIBUTES
  hPort = CreateFile("\\.\COM" & CStr(i), _
                     0, _
                     0, _
                     m_tSA, _
                     OPEN_EXISTING, _
                     0)
  CheckCOMPort = (hPort <> INVALID_HANDLE_VALUE)
  If hPort <> INVALID_HANDLE_VALUE Then CloseHandle hPort
End Function

Private Sub CommandGetPortsCreate_Click()
  Dim strPorts As String
  Dim i As Integer
  For i = 1 To 100
    If CheckCOMPort(i) Then
      strPorts = strPorts & "COM" & CStr(i) & vbCrLf
    End If
  Next
  MsgBox strPorts
End Sub

'проверяем от COM1 до COM100
Private Sub CommandGetPortsQueryDOS_Click()
  Dim strPorts As String
  Dim i As Long
  For i = 1 To 100
    If CheckCOMPortDOS(i) Then
      strPorts = strPorts & "COM" & CStr(i) & vbCrLf
    End If
  Next
  MsgBox strPorts
End Sub

Public Declare Function QueryDosDevice Lib "kernel32" Alias "QueryDosDeviceA" _
 (ByVal lpDeviceName As String, ByVal lpTargetPath As String, ByVal ucchMax As Long) As Long

Public Function CheckCOMPortDOS(ByVal i As Long) As Boolean
  If QueryDosDevice("COM" & CStr(i), vbNullString, 0) = 0 Then
    If Err.LastDllError = ERROR_INSUFFICIENT_BUFFER Then CheckCOMPortDOS = True
  End If
End Function