Sub Звонок()
Dim a
a = Selection
Dim stAppName As String
stAppName = "C:\Program Files\Zvonilka\zvonilka.exe " & a
Call Shell(stAppName,  1 )
End Sub

Sub Позвонить()
Dim numbers As String
On Error GoTo  1 

For Each Item In Application.ActiveExplorer.Selection

If TypeName(Item) = "ContactItem" Then numbers = Item.BusinessTelephoneNumber
If TypeName(Item) = "ContactItem" Then numbers = numbers & "^^^" & Item.HomeTelephoneNumber
If TypeName(Item) = "ContactItem" Then numbers = numbers & "^^^" & Item.BusinessFaxNumber
If TypeName(Item) = "ContactItem" Then numbers = numbers & "^^^" & Item.MobileTelephoneNumber
If TypeName(Item) = "ContactItem" Then numbers = numbers & "^^^" & Item.CallbackTelephoneNumber
If TypeName(Item) = "ContactItem" Then numbers = numbers & "^^^" & Item.RadioTelephoneNumber
If TypeName(Item) = "ContactItem" Then numbers = numbers & "^^^" & Item.AssistantTelephoneNumber
If TypeName(Item) = "ContactItem" Then numbers = numbers & "^^^" & Item.Business2TelephoneNumber
If TypeName(Item) = "ContactItem" Then numbers = numbers & "^^^" & Item.CarTelephoneNumber
If TypeName(Item) = "ContactItem" Then numbers = numbers & "^^^" & Item.CompanyMainTelephoneNumber
If TypeName(Item) = "ContactItem" Then numbers = numbers & "^^^" & Item.Home2TelephoneNumber
If TypeName(Item) = "ContactItem" Then numbers = numbers & "^^^" & Item.OtherTelephoneNumber
If TypeName(Item) = "ContactItem" Then numbers = numbers & "^^^" & Item.PagerNumber
If TypeName(Item) = "ContactItem" Then numbers = numbers & "^^^" & Item.PrimaryTelephoneNumber
If TypeName(Item) = "ContactItem" Then numbers = numbers & "^^^" & Item.TTYTDDTelephoneNumber

Next

If numbers = "" Then
MsgBox "Чтобы позвонить, перейдите в раздел [Контакты] и выделите контакт, которому необходимо позвонить!"
Exit Sub
End If

If numbers = "^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^" Then
MsgBox "Данный контакт не содержит телефонных номеров!"
Exit Sub
End If


Dim stAppName As String
stAppName = "C:\Program Files\Zvonilka\zvonilka.exe " & numbers
Call Shell(stAppName,  1 )

Exit Sub
 1 :
MsgBox "Ошибка: " & Err.Description & vbNewLine & vbNewLine & "(Чтобы позвонить, перейдите в раздел [Контакты] и выделите контакт, которому необходимо позвонить!)"
End Sub