Option Explicit
 
Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As _
  Range, Cancel As Boolean)
Dim CellTarget As String
 
    'Aktuelle Zelle
    CellTarget = ActiveCell.Value
    ActiveCell.Copy
    callT3 ("")
 
 
End Sub
 
Function callT3(CellTarget As String)
Dim RWert As Variant
Dim clipboard
 
On Error GoTo checkError
 
 
'Pfad muß in Windows hinterlegt sein
'Windows muß neu gestartet worden sein
RWert = Shell("c:\programme\windows nt\Dialer.exe", 1)   'Programmaufruf
 
    warten
Application.SendKeys keys:="%{T}"   'ALT + T = Menüleiste - Telefon
    warten
Application.SendKeys keys:="{W}"    'Wähldialog
    warten
Application.SendKeys keys:="^{v}"   'einfügen der Zwischdenablage
Application.SendKeys keys:="%{T}"   'Umschalten auf Telefonwahl
    warten
Application.SendKeys keys:="{W}"    'Wählen
    warten
 
    Exit Function
 
checkError:
Select Case Err
    Case 5
    MsgBox "Es wurde keine gültige Zelle(Tel.-Nummer) gewählt!" + Chr$(13) + _
      "Beispiele 0123 4567, 0123/4567, 0123-4567 usw."
    Case Else
    MsgBox "Das Programm Dialer ist nicht vorhanden!", vbCritical, "FEHLER"
End Select
End Function
 
Sub warten()
Dim wTime As String
    wTime = TimeSerial(Hour(Now()), Minute(Now()), Second(Now()) + 1)
    Application.Wait wTime
End Sub