Exporter les contacts

Exporter les contacts d'Outlook

Cette méthode tient compte des éventuels champs personnalisés

Sub ExportOutlookContacts(strFile As String, _
                          Optional Delim = """", Optional Separ = ",")
    On Error Resume Next
    Dim txtLine As String
    Dim Fichier As Integer
    Dim Ol_App As New Outlook.Application
    Dim Ol_Mapi As Outlook.NameSpace
    Dim Ol_Folder As Outlook.MAPIFolder
    Dim Ol_Items As Outlook.Items
    Dim Ol_Contact As Outlook.ContactItem
    Dim Ol_Prp As Outlook.ItemProperty

    Set Ol_Mapi = Ol_App.GetNamespace("MAPI")
    Set Ol_Folder = Ol_Mapi.GetDefaultFolder(olFolderContacts)
    Set Ol_Items = Ol_Folder.Items
    Set Ol_Contact = Ol_Items.Item(1)

    Fichier = FreeFile()
    Open strFile For Output As #Fichier
    For Each Ol_Prp In Ol_Contact.ItemProperties
        If Ol_Prp.Type = olDateTime Or Ol_Prp.Type = olText Then
            txtLine = txtLine & Delim & Ol_Prp.Name & Delim & Separ
        End If
    Next Ol_Prp

    txtLine = Left(txtLine, Len(txtLine) - Len(Separ))
    Print #Fichier, txtLine
    txtLine = ""
    For Each Ol_Contact In Ol_Items

        For Each Ol_Prp In Ol_Contact.ItemProperties

            If Ol_Prp.Type = olDateTime Or Ol_Prp.Type = olText Then
                txtLine = txtLine & Delim & Ol_Prp.Value & Delim & Separ
            End If
        Next Ol_Prp
        txtLine = Left(txtLine, Len(txtLine) - Len(Separ))
        Print #Fichier, txtLine
        txtLine = ""

    Next Ol_Contact
    Close #Fichier

    Set Ol_Prp = Nothing
    Set Ol_Contact = Nothing
    Set Ol_Items = Nothing
    Set Ol_Folder = Nothing
    Set Ol_Mapi = Nothing
    Set Ol_App = Nothing
    MsgBox "Fichier " & strFile & " créé.", vbOKOnly, ""

End Sub

Syntaxe:

Sub ExportContactsTXT()
    'Format TXT tabulé
    Call ExportOutlookContacts("F:Mes DocumentsContacts.txt", Null, vbTab)
End Sub

Sub ExportContactsCSV()
    'Format CSV
    Call ExportOutlookContacts("F:Mes DocumentsContacts.csv")
End Sub