Option Explicit

Private Declare Function GetForegroundWindow Lib "user32" () As Long

Dim aAvailability, aConfigManagerError
Dim sep$, banner$
'

Sub modems_SpecialForCE()
'http://msdn.microsoft.com/en-us/library/windows/desktop/aa394360%28v=vs.85%29.aspx

    Dim ModemNone As String
    'Отсутствует - None
    ModemNone = ""

    Dim CountModemNone As Long
    'Отсутствует - None
    CountModemNone = 0

    Dim ModemWork As String
    'Работает - Works
    ModemWork = ""

    Dim CountModemWork As Long
    'Работает - Works
    CountModemWork = 0

    Dim ModemDoesNotWork As String
    'Не работает - Does Not Work
    ModemDoesNotWork = ""

    Dim CountModemDoesNotWork As Long
    'Не работает - Does Not Work
    CountModemDoesNotWork = 0

    Const MAX_ConfigManagerErrorCode& = &H1F&
    Const MAX_Availability% = &H11
    Const NA$ = "N/A"

    Dim wmi As Object
    Set wmi = GetObject("winmgmts:\\.\root\cimv2")

    Dim mdms As Object, mdm As Object
    Set mdms = wmi.execquery("select * from Win32_POTSModem")

    If mdms.Count > 0 Then

        'выполнить макрос с именем ...
        Call setpdb

        'Debug.Print banner
        'Debug.Print "modems count: " & mdms.Count

        For Each mdm In mdms

            'Debug.Print sep
            'Debug.Print "DeviceType:             " & mdm.DeviceType

            'Debug.Print "Caption:                " & mdm.Caption
            'Debug.Print "Description:            " & mdm.Description

            'Debug.Print "AttachedTo:             " & mdm.AttachedTo
            'Debug.Print "DeviceLoader:           " & mdm.DeviceLoader

            If mdm.Availability <= MAX_Availability Then
                'Debug.Print "Availability:           (" & tohex(mdm.Availability) & ") " & aAvailability(mdm.Availability)
                'отсутствующие модемы
                CountModemNone = CountModemNone + 1
                ModemNone = Trim$(ModemNone & " " & ModemNone)
            Else
                'Debug.Print "Availability:           " & NA
            End If

            If mdm.ConfigManagerErrorCode <= MAX_ConfigManagerErrorCode Then
                'Debug.Print "ConfigManagerErrorCode: (" & tohex(mdm.ConfigManagerErrorCode) & ") " & aConfigManagerError(mdm.ConfigManagerErrorCode)
                'рабочие модемы
                CountModemWork = CountModemWork + 1
                ModemWork = Trim$(ModemWork & " " & mdm.Caption & " - " & mdm.AttachedTo)
            Else
                'Debug.Print "ConfigManagerErrorCode: " & NA
                'не рабочие модемы
                CountModemDoesNotWork = CountModemDoesNotWork + 1
                ModemDoesNotWork = Trim$(ModemDoesNotWork & " " & ModemDoesNotWork)
            End If

        Next mdm

        Set mdm = Nothing

        'выполнить макрос с именем ...
        Call clearpdb

        MsgBox$ _
                "Общее количество модемов " & mdms.Count & vbCrLf & vbCrLf & _
                                            "Рабочие модемы:" & vbCrLf & _
                                            "Количество: " & CountModemWork & vbCrLf & _
                                            ModemWork & vbCrLf & vbCrLf & _
                                            "Не рабочие модемы:" & vbCrLf & _
                                            "Количество: " & CountModemDoesNotWork & vbCrLf & _
                                            ModemDoesNotWork & vbCrLf & vbCrLf & _
                                            "Отсутствующие модемы:" & vbCrLf & _
                                            "Количество: " & CountModemNone & vbCrLf & _
                                            ModemNone
    Else
        '1
        'control.exe - служит для работы с панелью управления
        'telephon.cpl - оснастка панели управления для телефонии
        '1 - номер вкладки, которую нужно активировать при открытии (отсчет с нуля)
        Shell "control.exe telephon.cpl,,1"

        '2
        'можно и так сразу открывается вторая вкладка
        'Shell "control.exe modem.cpl"

        '3
        'Shell "rundll32.exe shell32.dll, Control_RunDLL modem.cpl, Modems", vbNormalFocus

        'MyID - идентификатор процесса
        'MyID = Shell("rundll32.exe shell32.dll, Control_RunDLL modem.cpl, Modems", vbNormalFocus)

        MsgBox$ "Модемы отсутствуют"

        'закрыть вкладку
        SendMessage GetForegroundWindow, &H10, 0&, 0&
    End If

    Set mdms = Nothing
    Set wmi = Nothing

End Sub

Function tohex(i): tohex = "0x" & Hex(i): End Function

Sub setpdb()
    aAvailability = _
    Array("WTF?..." _
  , "Other", "Unknown" _
                  , "Running or Full Power", "Warning" _
                  , "In Test", "Not Applicable" _
                  , "Power Off", "Off Line" _
                  , "Off Duty", "Degraded" _
                  , "Not Installed", "Install Error" _
                  , "Power Save - Unknown" & vbCrLf & Space(24) & "The device is known to be in a power save mode, but its exact status is unknown." _
                  , "Power Save - Low Power Mode" & vbCrLf & Space(24) & "The device is in a power save state but still functioning, and may exhibit degraded performance." _
                  , "Power Save - Standby" & vbCrLf & Space(24) & "The device is not functioning, but could be brought to full power quickly." _
                  , "Power Cycle" _
                  , "Power Save - Warning" & vbCrLf & Space(24) & "The device is in a warning state, though also in a power save mode.")

    aConfigManagerError = Array( _
                          "Device is working properly.", "Device is not configured correctly." _
                        , "Windows cannot load the driver for this device.", "Driver for this device might be corrupted, or the system may be low on memory or other resources." _
                        , "Device is not working properly." & vbCrLf & Space(24) & "One of its drivers or the registry might be corrupted.", "Driver for the device requires a resource that Windows cannot manage." _
                        , "Boot configuration for the device conflicts with other devices.", "Cannot filter." _
                        , "Driver loader for the device is missing.", "Device is not working properly." & vbCrLf & Space(24) & "The controlling firmware is incorrectly reporting the resources for the device." _
                        , "Device cannot start.", "Device failed." _
                        , "Device cannot find enough free resources to use.", "Windows cannot verify the device's resources." _
                        , "Device cannot work properly until the computer is restarted.", "Device is not working properly due to a possible re-enumeration problem." _
                        , "Windows cannot identify all of the resources that the device uses.", "Device is requesting an unknown resource type." _
                        , "Device drivers must be reinstalled.", "Failure using the VxD loader." _
                        , "Registry might be corrupted." _
                        , "System failure." & vbCrLf & Space(24) & "If changing the device driver is ineffective, see the hardware documentation." & vbCrLf & Space(24) & "Windows is removing the device." _
                        , "Device is disabled." _
                        , "System failure." & vbCrLf & Space(24) & "If changing the device driver is ineffective, see the hardware documentation." _
                        , "Device is not present, not working properly, or does not have all of its drivers installed." _
                        , "Windows is still setting up the device." _
                        , "Windows is still setting up the device." _
                        , "Device does not have valid log configuration." _
                        , "Device drivers are not installed." _
                        , "Device is disabled." & vbCrLf & Space(24) & "The device firmware did not provide the required resources." _
                        , "Device is using an IRQ resource that another device is using." _
                        , "Device is not working properly." & vbCrLf & Space(24) & "Windows cannot load the required device drivers.")

    sep = vbCrLf & String(23, "=") & " " & String(55, "=")
    banner = vbCrLf & "http://msdn.microsoft.com/en-us/library/windows/desktop/aa394360%28v=vs.85%29.aspx" & vbCrLf

End Sub

Sub clearpdb()

'очищаем память, Erase - Стирать
    Erase aAvailability, aConfigManagerError
    sep = ""
    banner = ""

End Sub