Telefonnummern formatieren

Dieses Beispiel bringt ausgesuchte Telefon- und Faxnummern in ein einheitliches Format: '+Ländercode (Ortsvorwahl) Anschlussnummer'. In der Funktion FormatPhonenumbers_Ex sehen Sie, welche Nummern behandelt werden (BusinessTelephoneNumber, BusinessFaxNumber etc.).

In der Funktion FormatPhonenumbers ganz oben steht m_DebugMode = True. Diese Einstellung bewirkt, dass die Originalnummern und das jeweilige Ergebnis der Formatierung nur ins Debug-Fenster (ctrl+g) ausgegeben werden. So können Sie in einem Testlauf kontrollieren, ob das Resultat korrekt ist. Wenn Sie die Zeile auf m_DebugMode = False ändern und die Funktion erneut ausführen, werden die Änderungen gespeichert.

In der Funktion ParseNumber gibt es die Konstante Def_CountryCode, die mit dem deutschen Ländercode voreingestellt ist. Wenn für eine Nummer der Ländercode fehlt, dann wird dieser Standardwert eingefügt. Tragen Sie hier bei Bedarf Ihren eigenen Ländercode ein.

Fügen Sie dem Outlook VBA-Projekt ein neues Modul hinzu und fügen Sie den ganzen Code ein. Aufrufen können Sie das z.B. über ALT+F8.

  So fügen Sie Makros in Outlook ein

Private m_DebugMode As Boolean

Public Sub FormatPhonenumbers()
  Dim coll As VBA.Collection
  Dim obj As Object
  Dim Contact As Outlook.ContactItem
  Dim IsInspector As Boolean

  'Wenn True, wird die Änderungen nur ins Debug-Fenster geschrieben (ctrl+g)
  'Wenn False, werden die Kontakte geändert und gespeichert
  m_DebugMode = True

  Set coll = GetCurrentItems(IsInspector)
  If coll.Count = 0 Then Exit Sub
  For Each obj In coll
    If TypeOf obj Is Outlook.ContactItem Then
      Set Contact = obj
      If m_DebugMode Then
        Debug.Print "--" & vbCrLf & Contact.FileAs
      End If
      FormatPhonenumbers_Ex Contact
      If m_DebugMode = False And IsInspector = False Then
        If Contact.Saved = False Then Contact.Save
      End If
    End If
  Next
End Sub

Private Sub FormatPhonenumbers_Ex(Contact As Outlook.ContactItem)
  Dim cc$, vw$, no$, OldNo$, NewNo$
  Dim IsFax As Boolean

  OldNo = Contact.BusinessTelephoneNumber
  If Len(OldNo) Then
    ParseNumber OldNo, cc, vw, no, IsFax
    NewNo = JoinNumber(cc, vw, no, IsFax)
    If m_DebugMode Then
      Debug.Print OldNo: Debug.Print NewNo & vbCrLf
    ElseIf OldNo <> NewNo Then
      Contact.BusinessTelephoneNumber = NewNo
    End If
  End If

  OldNo = Contact.BusinessFaxNumber
  If Len(OldNo) Then
    ParseNumber OldNo, cc, vw, no, IsFax
    NewNo = JoinNumber(cc, vw, no, IsFax)
    If m_DebugMode Then
      Debug.Print OldNo: Debug.Print NewNo & vbCrLf
    ElseIf OldNo <> NewNo Then
      Contact.BusinessFaxNumber = NewNo
    End If
  End If

  OldNo = Contact.CompanyMainTelephoneNumber
  If Len(OldNo) Then
    ParseNumber OldNo, cc, vw, no, IsFax
    NewNo = JoinNumber(cc, vw, no, IsFax)
    If m_DebugMode Then
      Debug.Print OldNo: Debug.Print NewNo & vbCrLf
    ElseIf OldNo <> NewNo Then
      Contact.CompanyMainTelephoneNumber = NewNo
    End If
  End If

  OldNo = Contact.HomeTelephoneNumber
  If Len(OldNo) Then
    ParseNumber OldNo, cc, vw, no, IsFax
    NewNo = JoinNumber(cc, vw, no, IsFax)
    If m_DebugMode Then
      Debug.Print OldNo: Debug.Print NewNo & vbCrLf
    ElseIf OldNo <> NewNo Then
      Contact.HomeTelephoneNumber = NewNo
    End If
  End If

  OldNo = Contact.MobileTelephoneNumber
  If Len(OldNo) Then
    ParseNumber OldNo, cc, vw, no, IsFax
    NewNo = JoinNumber(cc, vw, no, IsFax)
    If m_DebugMode Then
      Debug.Print OldNo: Debug.Print NewNo & vbCrLf
    ElseIf OldNo <> NewNo Then
      Contact.MobileTelephoneNumber = NewNo
    End If
  End If
End Sub

Private Function JoinNumber(cc$, vw$, no$, IsFax As Boolean) As String
  Dim n$
  If IsFax Then n = "Fax: "
  If Len(cc) Then n = n & cc
  If Len(vw) Then vw = " (" & vw & ") "
  n = n & vw
  n = n & no
  JoinNumber = n
End Function

Private Sub ParseNumber(ByVal Number$, cc$, vw$, no$, IsFax As Boolean)
  Dim p1&, p2&
  Dim i&
  Const Def_CountryCode As String = "+49"

  cc = "": vw = "": no = ""
  Number = Trim$(Number)

  If LCase$(Left$(Number, 4)) = "fax:" Then
    IsFax = True
    Number = Trim$(Mid$(Number, 5))
  Else
    IsFax = False
  End If

  If Left$(Number, 2) = "00" Then Number = "+" & Mid$(Number, 3)
  If Left$(Number, 1) = "0" Then Number = Mid$(Number, 2)
  If Left$(Number, 1) <> "+" Then
    'Assuming the country code is missing, insert the own country code.
    Number = Def_CountryCode & " " & Number
  End If
  Number = Replace(Number, "/", " ")
  Number = Replace(Number, "-", " ")
  Number = Replace(Number, "(0", "(")
  Number = Replace(Number, "(", " ")
  Number = Replace(Number, ")", " ")
  While InStr(Number, "  ") > 0
    Number = Replace(Number, "  ", " ")
  Wend

  If Left$(Number, 1) = "+" Then
    For i = 2 To Len(Number)
      If IsNumeric(Mid$(Number, i, 1)) = False Then
        If p1 = 0 Then
          p1 = i
        ElseIf p2 = 0 Then
          p2 = i
        Else
          Exit For
        End If
      End If
    Next
    If p1 = 0 Then
      no = Number
    Else
      cc = Mid$(Number, 1, p1 - 1)
      If p2 Then
        vw = Mid$(Number, p1 + 1, p2 - p1 - 1)
        no = Mid$(Number, p2 + 1)
      Else
        no = Mid$(Number, p1)
      End If
    End If
  End If
End Sub

Private Function GetCurrentItems(Optional IsInspector As Boolean) As VBA.Collection
  Dim coll As VBA.Collection
  Dim Win As Object
  Dim Sel As Outlook.Selection
  Dim obj As Object
  Dim i&

  Set coll = New VBA.Collection
  Set Win = Application.ActiveWindow

  If TypeOf Win Is Outlook.Inspector Then
    IsInspector = True
    coll.add Win.CurrentItem
  Else
    IsInspector = False
    Set Sel = Win.Selection
    If Not Sel Is Nothing Then
      For i = 1 To Sel.Count
        coll.add Sel(i)
      Next
    End If
  End If
  Set GetCurrentItems = coll
End Function