Attribute VB_Name = "E164fix"
Const conIntLength = 3  ' length of internal numbers
Const conCountrycode = "+49"  ' Countrycode
Const conAreaNr = "5251"   ' Areacode bzw Ortznetz
Const conLine = "304"  ' HauptanschlussConst conAreaNr = "5251"
Const conlogfile = "C:\\e164fix.txt"
Const conMode = "read"
'Const conMode = "WRITE!"
Const conTrenner = vbTab

' Globale Objekte
Dim fso As FileSystemObject
Dim ts As TextStream


Sub E164fix()
' script to change the telephone number t oa E.164 conform version.
' Atn: You have to modify the Rules

    ' get source Folder
    MsgBox "Bitte suchen Sie im naechsten Fenster den Kontaktordner"
    Dim ContactFolder As MAPIFolder
    Set ContactFolder = Outlook.GetNamespace("MAPI").PickFolder
    
    'Set objSession = CreateObject("MAPI.Session")
    'objSession.Logon
    'Set objCalendar = objSession.GetDefaultFolder(MAPI.CdoDefaultFolderCalendar)
    
    If ContactFolder.DefaultItemType <> olContactItem Then
        MsgBox "Abbruch: Ausgew&auml;hlter Ordner ist kein Kontaktordner", vbCritical
        Exit Sub
    End If
       
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.CreateTextFile(conlogfile, True)
    ts.WriteLine "# E164Fix Starttime:" & Now()
    ts.WriteLine "# E164Fix Folder: " & ContactFolder.FolderPath
    ts.WriteLine "# E164Fix mode: " & conMode
    ts.WriteLine "SaveAs" & conTrenner & "Old" & conTrenner & "New" & conTrenner & "Rule" & conTrenner & "Update"
             
    Debug.Print "Source Folder: " & ContactFolder.FolderPath
    Dim contact As contactitem
    Dim Updatecount As Integer
    
    Dim totalmodified As Integer: totalmodified = 0
    Dim total As Integer: total = 0
    
    für Each contact In ContactFolder.items.Restrict("[MessageClass]='IPM.Contact'")
        'Filter, da in einem Kontaktordner auch DLs liegen k&ouml;nnen !
        Updatecount = 0
        total = total + 1
        Debug.Print "Contact (" & total & "): " & contact.subject
        Updatecount = Updatecount + FixPhoneNumber(contact.subject, contact.PrimaryTelephoneNumber)
        Updatecount = Updatecount + FixPhoneNumber(contact.subject, contact.Business2TelephoneNumber)
        Updatecount = Updatecount + FixPhoneNumber(contact.subject, contact.AssistantTelephoneNumber)
        Updatecount = Updatecount + FixPhoneNumber(contact.subject, contact.BusinessFaxNumber)
        Updatecount = Updatecount + FixPhoneNumber(contact.subject, contact.BusinessTelephoneNumber)
        Updatecount = Updatecount + FixPhoneNumber(contact.subject, contact.CallbackTelephoneNumber)
        Updatecount = Updatecount + FixPhoneNumber(contact.subject, contact.CarTelephoneNumber)
        Updatecount = Updatecount + FixPhoneNumber(contact.subject, contact.CompanyMainTelephoneNumber)
        Updatecount = Updatecount + FixPhoneNumber(contact.subject, contact.Home2TelephoneNumber)
        Updatecount = Updatecount + FixPhoneNumber(contact.subject, contact.HomeFaxNumber)
        Updatecount = Updatecount + FixPhoneNumber(contact.subject, contact.HomeTelephoneNumber)
        Updatecount = Updatecount + FixPhoneNumber(contact.subject, contact.ISDNNumber)
        Updatecount = Updatecount + FixPhoneNumber(contact.subject, contact.MobileTelephoneNumber)
        Updatecount = Updatecount + FixPhoneNumber(contact.subject, contact.OtherFaxNumber)
        Updatecount = Updatecount + FixPhoneNumber(contact.subject, contact.OtherTelephoneNumber)
        Updatecount = Updatecount + FixPhoneNumber(contact.subject, contact.RadioTelephoneNumber)

        If Updatecount > 0 Then
            Debug.Print "  Modifications: " & Updatecount
            totalmodified = totalmodified + 1
            If conMode = "WRITE!" Then
                contact.Save
            End If
        End If
    Next
    ts.Close
    MsgBox "Ende. " & totalmodified & " Kontakte von " & total & " aktualisiert"
End Sub


Function FixPhoneNumber(subject As String, ByRef strNumber As String)
    '
    Dim strOldNumber As String
    
    If Len(strNumber) = 0 Then
        Debug.Print "  Skip empty field"
    Else
        strOldNumber = strNumber
        ts.Write subject & conTrenner & strOldNumber & conTrenner
        
        ' Leerzeichen entfernen
        strNumber = Trim(strNumber)
        
        ' Entfernen verschiedener "Sonderzeichen"
        strNumber = Replace(strNumber, "++", "+")
        strNumber = Replace(strNumber, " ", "")
        strNumber = Replace(strNumber, "/", "")
        If Left(strNumber, 1) = "-" Then strNumber = "+" & Mid(strNumber, 2)
        
        ' Rufnummer in E14 umsetzen
        If Left(strNumber, 3) = "+10" Then
            Debug.Print "  E164 USA mit 0 ."
            strNumber = Replace(strNumber, "+10", "+1")
            ts.WriteLine strNumber & conTrenner & "E164 USA mit 0" & conTrenner & "1"
        ElseIf (Left(strNumber, 1) = "+") And (Mid(strNumber, 4, 1) = "0") Then
            Debug.Print "  E164 mit 0 ."
            strNumber = Replace(strNumber, "0", "", 1, 1)
            ts.WriteLine strNumber & conTrenner & "E164 mit 0" & conTrenner & "1"
        ElseIf Left(strNumber, 1) = "+" Then
            Debug.Print "  Assume already E164."
            ts.WriteLine strNumber & conTrenner & "Already E164" & conTrenner & "0"
        ElseIf InStr(strNumber, "(0)") = 1 Then
            Debug.Print "  National with leading(0)"
            strNumber = Replace(strNumber, "(0)", strInternalprefix)
            ts.WriteLine strNumber & conTrenner & "National with leading (0)" & conTrenner & "1"
        ElseIf InStr(strNumber, "(0)") > 2 Then
            Debug.Print "  E164 with middle (0)"
            strNumber = Replace(strNumber, "(0)", "")
            If InStr(strNumber, "+") <> 1 Then
                strNumber = strNumber & "+"
            End If
            ts.WriteLine strNumber & conTrenner & "E164 with middle(0)" & conTrenner & "1"
        ElseIf Len(strNumber) <= conIntLength Then
            Debug.Print "  Add intPrefix " & conCountrycode & conAreaNr & conLine
            strNumber = conCountrycode & conAreaNr & conLine & strNumber
            ts.WriteLine strNumber & conTrenner & "Short Number Add internalPrefix" & conTrenner & "1"
        ElseIf Left(strNumber, 2) = "(0" Then
            Debug.Print "  national mit Klammer0 :"
            strNumber = conCountrycode & "(" & Mid(strNumber, 3)
            ts.WriteLine strNumber & conTrenner & "national mit Klammer" & conTrenner & "1"
        ElseIf Left(strNumber, 1) = "(" Then
            Debug.Print "  national mit Klammer:"
            strNumber = conCountrycode & strNumber
            ts.WriteLine strNumber & conTrenner & "national mit Klammer" & conTrenner & "1"
        ElseIf Left(strNumber, 2) = "00" Then
            Debug.Print "  Assume international Number. Replace 00 with +"
            strNumber = "+" & Mid(strNumber, 3)
            ts.WriteLine strNumber & conTrenner & "international" & conTrenner & "1"
        ElseIf Left(strNumber, 1) = "0" Then
            Debug.Print "  Assume national Number. Replace 0 with " & conCountrycode
            strNumber = conCountrycode & Mid(strNumber, 2)
            ts.WriteLine strNumber & conTrenner & "national" & conTrenner & "1"
        Else
            Debug.Print "  Assume local Number. Add " & conCountrycode & conAreaNr
            strNumber = conCountrycode & conAreaNr & strNumber
            ts.WriteLine strNumber & conTrenner & "local" & conTrenner & "1"
        End If
        If strOldNumber <> strNumber Then
            FixPhoneNumber = 1
        Else
            FixPhoneNumber = 0
        End If
    End If
End Function


Sub dumpproperties(obitem As contactitem)
    Dim property As ItemProperty
    für Each property In obitem.ItemProperties
        If VarType(property.Value) = vbString Then
            Debug.Print property.Name & ";" & property.Value
        Else
            Debug.Print property.Name & ";EMPTY"
        End If
    Next
End Sub