[VBA Outlook] Importation de contact - avancé

Réponse acceptée !
Bonjour Je me suis attaqué à ton problème à la pause de midi. 2 heures de programmation et de test et voilà ! Il faut ouvrir un dossier contact existant ou le créer si il n'existe pas. Ensuite il faut créer un contact dans ce dossier Sub main() GetOutlookContacts ("Dossiers personnels\Contacts") End Sub Public Function GetOutlookContacts(sLocation As String) On Error GoTo Hell Dim objOutlook As Outlook.Application Dim objFolder As Outlook.MAPIFolder Dim objAllContacts As Outlook.Items Dim Contact As Outlook.ContactItem 'For look through the folders 'Dim colFolders As Outlook.Folders ' Set the application object Set objOutlook = New Outlook.Application ' Set the default Contacts folder Dim objNamespace As Outlook.NameSpace Set objNamespace = objOutlook.GetNamespace("MAPI") 'Set objFolder = objNamespace.GetDefaultFolder(olFolderContacts) 'default Contact Folder 'Set objFolder = GetFolder("Personal Folders\Contacts") 'special client Set objFolder = GetFolder(sLocation) 'special client 'folder (alternate method) 'Make sure the folder was found If objFolder Is Nothing Then GoTo EXIT_FOR 'Enumerate All contacts in the main MAPI folder lNumContacts = EnumerateContacts(objFolder) Set Contact = objOutlook.CreateItem(olContactItem) Call SetContactInfo(sLocation, Contact, "Toto", "toto@free.fr", "Paris", "Fb St-honore") Contact.Move objFolder Contact.Display 'Loop through all of the sub folders of the contacts 'Dim Folder As Outlook.MAPIFolder 'Set colFolders = objFolder.Folders 'Check for valid sub folders 'If colFolders Is Nothing Then GoTo EXIT_FOR 'For Each Folder In colFolders 'Debug.Print Folder.Name 'Get all contacts from this folder 'EnumerateContacts Folder 'Check for child folders 'EnumerateFolders Folder 'Next EXIT_FOR: 'Cleanup Set objOutlook = Nothing Set objFolder = Nothing Set colFolders = Nothing Exit Function Hell: MsgBox Err.Description & Err.Number GoTo EXIT_FOR End Function Private Function EnumerateFolders(objParentFolder As Object) As Integer Dim colchildFolders As Outlook.Folders Dim ChildFolder As Outlook.MAPIFolder Set colchildFolders = objParentFolder.Folders If colchildFolders.Count <> 0 Then For Each ChildFolder In colchildFolders 'Debug.Print ChildFolder.Name 'Attemp to get contacts from folder EnumerateContacts ChildFolder 'Check for child folders EnumerateFolders ChildFolder Next End If 'Cleanup Set colchildFolders = Nothing End Function Private Function EnumerateContacts(objFolder As Outlook.MAPIFolder) As Long 'Get all contacts for a passed MAPI folder Dim CountContacts As Long On Error GoTo Hell Dim objAllContacts As Outlook.Items Dim Contact As Outlook.ContactItem CountContacts = 0 ' Set objAllContacts = the collection of all contacts Set objAllContacts = objFolder.Items ' Loop through each contact For Each Contact In objAllContacts Debug.Print objFolder & ": " & Contact.FullName CountContacts = CountContacts + 1 Next 'Cleanup Set objAllContacts = Nothing EnumerateContacts = CountContacts Exit Function Hell: End Function Private Function GetFolder(strFolderPath As String) As MAPIFolder ' folder path needs to be something like ' "Public Folders\All Public Folders\Company\Sales" Dim objApp As Outlook.Application Dim objNS As Outlook.NameSpace Dim colFolders As Outlook.Folders Dim objFolder As Outlook.MAPIFolder Dim objFolder2 As Outlook.MAPIFolder Dim arrFolders() As String Dim i As Long On Error Resume Next strFolderPath = Replace(strFolderPath, "/", "\") arrFolders() = Split(strFolderPath, "\") Set objApp = CreateObject("Outlook.Application") Set objNS = objApp.GetNamespace("MAPI") Set objFolder = objNS.Folders.Item(arrFolders(0)) If Not objFolder Is Nothing Then For i = 1 To UBound(arrFolders) Set colFolders = objFolder.Folders Set objFolder = Nothing Set objFolder = colFolders.Item(arrFolders(i)) If objFolder Is Nothing Then colFolders.Add arrFolders(i), 10 'olFolderContacts ' Set objFolder = colFolders.GetLast Exit For End If Next End If Set GetFolder = objFolder Set colFolders = Nothing Set objNS = Nothing Set objApp = Nothing End Function Sub SetContactInfo(sLocalize As String, oItemContact As Outlook.ContactItem, Optional sName As String, Optional sEmail As String, Optional sAddress As String, Optional sPhone As String) With oItemContact .FullName = sName If Not IsNothing(sCompany) Then .CompanyName = sCompany If Not IsNothing(sPhone) Then .HomeTelephoneNumber = sPhone If Not IsNothing(sEmail) Then .Email1Address = sEmail If Not IsNothing(sJob) Then .JobTitle = sJob If Not IsNothing(sAddress) Then .HomeAddress = sAddress End With ' oItemContact.SaveAs sLocalize & "\" & sName, 2 'olContactItem oItemContact.Save 'As sLocalize, 2 'olContactItem End Sub Public Function IsNothing(oParam) As Boolean On Error Resume Next Dim lResult As Boolean lResult = False If IsNull(oParam) Then lResult = True If IsEmpty(oParam) Then lResult = True If oParam = "" Then lResult = True IsNothing = lResult End Function

Réponse acceptée !
Je reviens sur ce que j'ai dit, il me sort l'erreur uniquement quand je laisse "Dossiers personnels\Contacts" comme sLocation, si je met la location d'un dossier secondaire ("Dossiers personnels\Contacts\test" par exemple), no soucis, comme une lettre a la poste. et comme c'est ce cas là qui m'interesse...

merci, code nikel