Sub mic() 'On Error Resume Next Dim objapp As Outlook.Application Dim objns As NameSpace Dim objContact As MAPIFolder Dim objItem As ContactItem Dim strBody As String Dim bolob As String Dim intLoop As Integer Dim myDestFolder As MAPIFolder Dim Fichierchoisi As Outlook.Application Dim data1 As String Dim data2 As String Dim data3 As String Dim ledebut As String Dim lafin As String Dim leon As VBA.Collection Dim lenom As String Dim lenomcomplet As String Dim finnom As String Dim objPress As MAPIFolder Dim objSelection As Outlook.Selection Dim FileAs As String Dim lastname As String Dim Firstname As String Dim MobileTelephoneNumber As String Dim BusinessAddress As String Dim BusinessTelephoneNumber As String Dim Business2TelephoneNumber As String Dim BusinessFaxNumber As String Dim HomeAddress As String Dim HomeTelephoneNumber As String Dim Home2TelephoneNumber As String Dim HomeFaxNumber As String Dim OtherTelephoneNumber As String Dim OtherFaxNumber As String Dim OtherAddress As String Dim companyname As String Dim body As String Dim middlename As String Set objapp = CreateObject("Outlook.Application") Set objns = objapp.GetNamespace("MAPI") Set objContact = objns.GetDefaultFolder(olFolderContacts) Set objPress = objContact.Folders("presse archives") Open "c:\Update.vcf" For Output As #1 For intLoop = 1 To objPress.Items.Count Set objItem = objPress.Items.Item(intLoop) With objItem FileAs = net(.FileAs) 'MsgBox (FileAs) lastname = net(.lastname) Firstname = net(.Firstname) middlename = net(.middlename) companyname = net(.companyname) Email1Address = net(.Email1Address) MobileTelephoneNumber = net(.MobileTelephoneNumber) BusinessAddress = net(.BusinessAddress) BusinessTelephoneNumber = net(.BusinessTelephoneNumber) Business2TelephoneNumber = net(.Business2TelephoneNumber) BusinessFaxNumber = net(.BusinessFaxNumber) HomeAddress = net(.HomeAddress) HomeTelephoneNumber = net(.HomeTelephoneNumber) Home2TelephoneNumber = net(.Home2TelephoneNumber) HomeFaxNumber = net(.HomeFaxNumber) OtherTelephoneNumber = net(.OtherTelephoneNumber) OtherFaxNumber = net(.OtherFaxNumber) OtherAddress = net(.OtherAddress) body = net(.body) End With If objItem.Class = olContact Then objItem.SaveAs objItem.FullName & ".vcf", olVCard Print #1, "BEGIN:VCARD" Print #1, "VERSION:3.0" Print #1, "N:"; lastname; ";"; Firstname; ";"; middlename; ";;" Print #1, "FN:"; FileAs Print #1, "ORG:"; companyname; ";" Print #1, "EMAIL;type=INTERNET;type=WORK;type=pref:"; Email1Address Print #1, "TEL;type=CELL;type=pref:"; MobileTelephoneNumber Print #1, "TEL;type=WORK:"; BusinessTelephoneNumber Print #1, "item1.TEL:"; Business2TelephoneNumber Print #1, "item1.X-ABLabel: travail 2" Print #1, "TEL;type=WORK;type=FAX:"; BusinessFaxNumber Print #1, "TEL;type=HOME:"; HomeTelephoneNumber Print #1, "item2.TEL:"; Home2TelephoneNumber Print #1, "item2.X-ABLabel: domicile 2" Print #1, "TEL;type=HOME;type=FAX"; HomeFaxNumber; ":" Print #1, "item3.TEL:"; OtherTelephoneNumber Print #1, "item3.X-ABLabel:_$!!$_" Print #1, "item4.TEL:"; OtherFaxNumber Print #1, "item4.X-ABLabel:autre fax" Print #1, "item5.ADR;type=WORK;type=pref:;;" & BusinessAddress & ";;;;" Print #1, "item6.ADR;type=HOME:;;" & HomeAddress & ";;;;" Print #1, "item7.ADR;type=HOME:;;" & OtherAddress & ";;;;" Print #1, "item7.X-ABLabel:_$!!$_" Print #1, "NOTE:"; body Print #1, "End: VCARD" End If Next intLoop Close #1 MsgBox "Contacts successfully exported", , "Contact Export to vCard" End Sub Function net(chicha As String) As String If InStr(chicha, ";") Then chicha = Replace(chicha, ";", "\;", , , vbTextCompare) End If chicha = Replace(chicha, Chr(13) & Chr(10), "\n", , , vbTextCompare) chicha = Replace(chicha, Chr(13), "\n", , , vbTextCompare) chicha = Replace(chicha, Chr(10), "\n", , , vbTextCompare) net = chicha End Function Function netnote(chicha As String) As String If InStr(chicha, Chr(13)) Then chicha = Replace(chicha, Chr(13) & Chr(10), "\n", , , vbTextCompare) End If netnote = chicha End Function