Rufnummer vergrößert anzeigen

Nicht alle Anwender haben ein Telefon mit einer Tapi-Schnittstelle, um aus Outlook® heraus wählen zu können. Steht das Telefon nicht nahe am PC, wird es mit dem Lesen von Rufnummern schwierig.

Mit dem hier gezeigten Programmierbeispiel werden die üblichen Rufnummer des aktuellen Kontakts relativ groß in einer HTML-E-Mail angezeigt.

Zur Verwendung dieses Beispiels beachten Sie bitte die wichtigen Hinweise, sowie den Workshop VBA in Outlook® verwenden. Den Code bitte in ein neues Modul kopieren (Einfügen -> Modul im VBA-Editor).

Ab Outlook® 2002

Option Explicit
 
Public Sub ShowPhoneNumber()
 
    '=====================================================================
    ' Zeigt eine Rufnummer groß in einer E-Mail an
    ' (c) Peter Marchert - http://www.outlook-stuff.com
    ' 2008-12-18 - Version 1.0.0
    '=====================================================================
    
    Dim objTrash As Outlook.MAPIFolder
    Dim objContact As Outlook.ContactItem
    Dim objMail As Outlook.MailItem
    Dim strNumber As String
 
    '---------------------------------------------------------------------
    ' Hier wird die E-Mail formatiert
    '---------------------------------------------------------------------
    Const HTMLCODE As String = _
        "<p style=""font-family: Arial Black; font-size: 2cm; " & _
        "text-align: center; color: red; font-weight: bold"">%</p>"
 
    '---------------------------------------------------------------------
    ' Fehlerbehandlung wegen Set-Anweisungen ausschalten
    '---------------------------------------------------------------------
    On Error Resume Next
 
    '---------------------------------------------------------------------
    ' Aktuell geöffnetes Element refernzieren
    '---------------------------------------------------------------------
    Set objContact = Outlook.ActiveInspector.CurrentItem
 
    '---------------------------------------------------------------------
    ' Wenn kein Element geöffnet ist, dann markiertes verwenden
    '---------------------------------------------------------------------
    If objContact Is Nothing Then Set objContact = Outlook.ActiveExplorer.Selection(1)
 
    '---------------------------------------------------------------------
    ' Auch nichts markiert?
    '---------------------------------------------------------------------
    If objContact Is Nothing Then Exit Sub
 
    '---------------------------------------------------------------------
    ' Rufnummer(n) ermitteln
    '---------------------------------------------------------------------
    If Trim(objContact.BusinessTelephoneNumber) <> "" Then
        strNumber = "Ges.: " & Trim(objContact.BusinessTelephoneNumber)
    End If
    If Trim(objContact.HomeTelephoneNumber) <> "" Then
        strNumber = strNumber & "<br />" & "Priv.: " & Trim(objContact.HomeTelephoneNumber)
    End If
    If Trim(objContact.MobileTelephoneNumber) <> "" Then
        strNumber = strNumber & "<br />" & "Mob.: " & Trim(objContact.MobileTelephoneNumber)
    End If
    If Trim(objContact.BusinessFaxNumber) <> "" Then
        strNumber = strNumber & "<br />" & "Fax g.: " & Trim(objContact.BusinessFaxNumber)
    End If
    If Trim(objContact.HomeFaxNumber) <> "" Then
        strNumber = strNumber & "<br />" & "Fax p.: " & Trim(objContact.HomeFaxNumber)
    End If
 
    '---------------------------------------------------------------------
    ' Keine Rufnummer gefunden?
    '---------------------------------------------------------------------
    If strNumber = "" Then
        MsgBox "Im Kontakt """ & objContact.Subject & """ wurden keine" & _
            vbCrLf & "üblichen Rufnummern gefunden." _
            , vbCritical + vbOKOnly, "Rufnummer anzeigen"
        Set objContact = Nothing
        Exit Sub
    End If
 
    '---------------------------------------------------------------------
    ' Ordner "Gelöschte Objekte" referenzieren
    '---------------------------------------------------------------------
    Set objTrash = Outlook.Session.GetDefaultFolder(olFolderDeletedItems)
 
    '---------------------------------------------------------------------
    ' Neue E-Mail im Ordner "Gelöschte Objekte" erstellen
    '---------------------------------------------------------------------
    Set objMail = objTrash.Items.Add(olMailItem)
 
    '---------------------------------------------------------------------
    ' E-Mail formatieren und anzeigen
    '---------------------------------------------------------------------
    With objMail
        .BodyFormat = olFormatHTML
        .HTMLBody = Replace(HTMLCODE, "%", strNumber)
        .Save
        .Display
    End With
 
    '---------------------------------------------------------------------
    ' Clean Up
    '---------------------------------------------------------------------
    Set objMail = Nothing
    Set objContact = Nothing
    Set objTrash = Nothing
 
End Sub