Citation :
Sub ImportTiersOutlook()
Application.ScreenUpdating = False
Sheets(1).Select 'Selectionne la feuille 1
'***** Connexion avec le dossier des contacts d'outlook
Dim myOlApp, myNameSpace, myFolder
Set myOlApp = CreateObject("Outlook.Application" )
Set myNameSpace = myOlApp.GetNamespace("MAPI" )
Set myFolder = myNameSpace.GetDefaultFolder(10) 'olFolderContacts
'/*****
'***** Compte le nombre de contacts
Nb = myFolder.Items.Count
'/*****
'***** Definis la variable L comme le 1er numéro de ligne renseigner _
(l'entete etantsur la ligne 1)
L = 2
'/*****
'***** Boucle qui va mettre dans chaque cellule les informationsb _
L s'increment a la fin pour passer à la ligne d'en dessous
On Error Resume Next
Dim X As Integer
For X = 1 To Nb
With myFolder.Items(X)
a = .FirstName
Cells(L, 1).Value = .Title
Cells(L, 2).Value = .LastName
Cells(L, 3).Value = .FirstName
Cells(L, 4).Value = .CompanyName
Cells(L, 5).Value = .Department
Cells(L, 6).Value = .BusinessAddressStreet
Cells(L, 7).Value = .BusinessAddressCity
Cells(L, 8).Value = .BusinessAddressState
Cells(L, 9).Value = .BusinessAddressPostalCode
Cells(L, 10).Value = .BusinessAddressCountry
Cells(L, 11).Value = .BusinessFaxNumber
Cells(L, 12).Value = .BusinessTelephoneNumber
Cells(L, 13).Value = .MobileTelephoneNumber
Cells(L, 14).Value = .Email1Address
End With
L = L + 1
Next
'/*****
'***** Récupère toutes les propriétés et les mets dans la feuille 2 avec le numéro d'item _
Tu auras peut etre besoin d'autres infos que celles que j'ai sélectionné
Sheets(2).Select
For i = 0 To myFolder.Items(1).ItemProperties.Count - 1
Cells(i + 1, 1) = myFolder.Items(1).ItemProperties.Item(i).Name
Cells(i + 1, 2) = i
Next i
Sheets(1).Select
Cells(1, 1).Select
Columns.AutoFit
Application.ScreenUpdating = True
'/*****
End Sub
|
