Un grand nombre de fichiers CSV qui contiennent des exportations de
contacts (venus d'ailleurs) sont rangés de façon logique dans des
répertoires.
J'arrive à reproduire par macro l'arborescence
dans les contacts d'outlook
et à chaque csv je fais correspondre un dossier
dans les dossiers crées dans les contacts ;o)
Il me reste à automatiser l'importation du contenu des CSV...
Et là je sèche ... et comme l'enregistrement de macros n'existe pas je
n'arrive pas à savoir si c'est possible ou pas ...
J'aimerais bien un truc du style
set MACHIN = Outlook.ImportationDeContacts
MACHIN.Source.Shemin = "C:\Bidule\Truc\chouette.csv"
MACHIN.Source.Type = "CSV"
MACHIN.Sible = UndossierDansLesContacts
MACHIN.Champs.NomComplet = "Nom à afficher"
DerLig = Sheets("Feuil1").Cells(Rows.Count, "A").End(xlUp).Row
Set applOutlook = New Outlook.Application
Set nsOutlook = applOutlook.GetNamespace("MAPI")
For i = 2 To DerLig 'Mon fichier commence en ligne 2
Set ciOutlook = applOutlook.CreateItem(olContactItem)
ciOutlook.Display
With ciOutlook
.FirstName = Sheets("Feuil1").Cells(i, 1)
.LastName = Sheets("Feuil1").Cells(i, 2)
.Email1Address = Sheets("Feuil1").Cells(i, 3)
.CompanyName = Sheets("Feuil1").Cells(i, 4) ' Tu peux ajouter aut ant d'infos que tu veux
End With
ciOutlook.Close olSave
Next i
applOutlook.Quit
Set applOutlook = Nothing
Set nsOutlook = Nothing
Set ciOutlook = Nothing
Set delFolder = Nothing
Set delItems = Nothing
End Sub
'---------------------------------------
DerLig = Sheets("Feuil1").Cells(Rows.Count, "A").End(xlUp).Row
Set applOutlook = New Outlook.Application
Set nsOutlook = applOutlook.GetNamespace("MAPI")
For i = 2 To DerLig 'Mon fichier commence en ligne 2
Set ciOutlook = applOutlook.CreateItem(olContactItem)
ciOutlook.Display
With ciOutlook
.FirstName = Sheets("Feuil1").Cells(i, 1)
.LastName = Sheets("Feuil1").Cells(i, 2)
.Email1Address = Sheets("Feuil1").Cells(i, 3)
.CompanyName = Sheets("Feuil1").Cells(i, 4) ' Tu peux ajouter a utant d'infos que tu veux
End With
ciOutlook.Close olSave
Next i
applOutlook.Quit
Set applOutlook = Nothing
Set nsOutlook = Nothing
Set ciOutlook = Nothing
Set delFolder = Nothing
Set delItems = Nothing
End Sub
'---------------------------------------