Sub Phone()

    On Error Resume Next

    Dim strComputer As String
    strComputer = "."

    Dim objWMIService As Object
    Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\cimv2")

    Dim colItems As Object
    Set colItems = objWMIService.ExecQuery("Select * from Win32_POTSModem")

    Dim MSComm1 As MSComm
    Set MSComm1 = New MSComm

    Dim objItem As Object

    Dim Количество_модемов As Byte
    Dim Количество_доступных_модемов As Byte

    Dim ИмяCOMпорта As String
    Dim MSComm1Input As String
    Dim Результат As String
    Dim Доступные_модемы As String

    For Each objItem In colItems
        Количество_модемов = Количество_модемов + 1
        ИмяCOMпорта = objItem.AttachedTo
        'отнимаем первые три буквы, то есть COM
        MSComm1.CommPort = Right$(ИмяCOMпорта, (Len(ИмяCOMпорта) - 3))
        MSComm1.PortOpen = True
        MSComm1.Output = "ATI" & vbCr
        'If Err.Number <> 0 Then MsgBox$ Err.Number & "-" & Err.Description
        'или Err.Clear, обнуляем ошибку
        Err.Number = 0
        MSComm1Input = MSComm1.Input
        MSComm1.PortOpen = False

        If Len(MSComm1Input) = 0 Then
            Результат = Результат & Количество_модемов & " " & objItem.Model & " - " & objItem.AttachedTo & " - Не доступен для звонка" & Chr$(13)

        Else

            Результат = Результат & Количество_модемов & " " & objItem.Model & " - " & objItem.AttachedTo & " - Доступен для звонка" & Chr$(13)
            Количество_доступных_модемов = Количество_доступных_модемов + 1
            Доступные_модемы = Доступные_модемы & objItem.Model & " - " & objItem.AttachedTo & Chr$(13)
        End If

    Next

    'установка объекта в значение Nothing требуется для освобождения памяти, которая была выделена для создания этого объекта
    Set objWMIService = Nothing
    Set colItems = Nothing
    Set MSComm1 = Nothing

    'отключает действие строки 1) On Error GoTo ... 2) либо действие строки On Error Resume Next
    On Error GoTo 0

    MsgBox$ "Количество установленных модемов в компьютере: " & Количество_модемов & Chr$(13) & Результат & "Количество модемов, доступных для звонка: " & Количество_доступных_модемов

    End Sub

Sub PhoneПозвонить_с_телефона()

    On Error Resume Next

    Dim strComputer As String
    strComputer = "."

    Dim objWMIService As Object
    Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\cimv2")

    Dim colItems As Object
    Set colItems = objWMIService.ExecQuery("Select * from Win32_POTSModem")

    Dim MSComm1 As MSComm
    Set MSComm1 = New MSComm

    Dim objItem As Object

    Dim Количество_модемов As Byte
    Dim Количество_доступных_модемов As Byte

    Dim ИмяCOMпорта As String
    Dim MSComm1Input As String
    Dim Результат As String
    Dim Доступные_модемы As String

    For Each objItem In colItems
        Количество_модемов = Количество_модемов + 1
        ИмяCOMпорта = objItem.AttachedTo
        'отнимаем первые три буквы, то есть COM
        MSComm1.CommPort = Right$(ИмяCOMпорта, (Len(ИмяCOMпорта) - 3))
        MSComm1.PortOpen = True
        'или Err.Clear, обнуляем ошибку
        If Err.Number = 8012 Then
            Err.Number = 0
            MSComm1.PortOpen = False
            MSComm1Input = ""
            GoTo Skip
        End If

        'MsgBox$ Err.Number & "-" & Err.Description
        MSComm1.Output = "ATI" & vbCr
        MSComm1Input = MSComm1.Input
        MSComm1.PortOpen = False

Skip:

        If Len(MSComm1Input) = 0 Then
            Результат = Результат & Количество_модемов & " " & objItem.Model & " - " & objItem.AttachedTo & " - Не доступен для звонка" & Chr$(13)

        Else

            Результат = Результат & Количество_модемов & " " & objItem.Model & " - " & objItem.AttachedTo & " - Доступен для звонка" & Chr$(13)
            Количество_доступных_модемов = Количество_доступных_модемов + 1
            Доступные_модемы = Доступные_модемы & objItem.Model & " - " & objItem.AttachedTo & Chr$(13)
        End If

    Next

    'установка объекта в значение Nothing требуется для освобождения памяти, которая была выделена для создания этого объекта
    Set objWMIService = Nothing
    Set colItems = Nothing
    Set MSComm1 = Nothing

    'отключает действие строки 1) On Error GoTo ... 2) либо действие строки On Error Resume Next
    On Error GoTo 0

    MsgBox$ "Количество установленных модемов в компьютере: " & Количество_модемов & Chr$(13) & Результат & "Количество модемов, доступных для звонка: " & Количество_доступных_модемов

    Exit Sub

Dim a As String
Dim stAppName As String

a = Selection
a = Trim(a)
a = Replace(a, vbCr, "")
a = Replace(a, vbCr, "")
a = Replace(a, vbCr, "")
a = Replace(a, vbCrLf, "")
a = Replace(a, vbCrLf, "")
a = Replace(a, vbCrLf, "")
a = Replace(a, vbBack, "")
a = Replace(a, vbCr, "")
a = Replace(a, vbLf, "")
a = Replace(a, vbNewLine, "")
a = Replace(a, vbNullChar, "")
a = Replace(a, vbNullString, "")
a = Replace(a, vbTab, "")
a = Replace(a, vbVerticalTab, "")
stAppName = "C:\Program Files\Zvonilka\zvonilka.exe " & a
Call Shell(stAppName, 1)
End Sub

a = Replace(a, vbCr, "")
a = Replace(a, vbCr, "")
a = Replace(a, vbCr, "")
a = Replace(a, vbCrLf, "")
a = Replace(a, vbCrLf, "")
a = Replace(a, vbCrLf, "")