1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189
| Application_Startup()
Sub ajout_contacts()
Dim oOL As Outlook.Application
Dim oNS As Outlook.NameSpace
Dim oRestricted As Outlook.Items
Dim oFolder As Outlook.MAPIFolder
Dim oItems As Outlook.Items
Dim oContact As Outlook.ContactItem
Dim nombre As Integer
Dim citem
Dim oemployee As Outlook.ContactItem
Set oOL = New Outlook.Application
Set oemployeefolder = oOL.GetNamespace("MAPI").Folders("Dossiers publics")
Set oemployeefolder = oemployeefolder.Folders("Tous les dossiers publics")
Set oemployeefolder = oemployeefolder.Folders("Contacts Entreprise") <-- Répertoire source
nombre = 0
Set oOL = GetObject(, "Outlook.Application")
If oOL Is Nothing Then
Set oOL = CreateObject("Outlook.Application")
End If
Set oNS = oOL.GetNamespace("MAPI")
Set oContact = oOL.CreateItem(olContactItem)
Set oFolder = oNS.GetDefaultFolder(olFolderContacts)
For Each citem In oemployeefolder.Items
If comparer(citem.FileAs) = False Then
Set oOL = GetObject(, "Outlook.Application")
If oOL Is Nothing Then
Set oOL = CreateObject("Outlook.Application")
End If
Set oNS = oOL.GetNamespace("MAPI")
Set oContact = oOL.CreateItem(olContactItem)
Set oFolder = oNS.GetDefaultFolder(olFolderContacts)
Set oItems = oFolder.Items
'For Each objcontactitem.ContactItem.olContactItem In oContact
With oContact
'.FullName = citem.FullName
'.HomeAddress = "AdresseSamples"
.Account = citem.Account
.Anniversary = citem.Anniversary
.AssistantName = citem.AssistantName
.AssistantTelephoneNumber = citem.AssistantTelephoneNumber
.BillingInformation = citem.BillingInformation
.Birthday = citem.Birthday
.Body = citem.Body
.BusinessTelephoneNumber = citem.BusinessTelephoneNumber
.BusinessFaxNumber = citem.BusinessFaxNumber
.Business2TelephoneNumber = citem.Business2TelephoneNumber
.BusinessAddressPostOfficeBox = citem.BusinessAddressPostOfficeBox
.BusinessAddressState = citem.BusinessAddressState
.BusinessAddressStreet = citem.BusinessAddressStreet
.BusinessHomePage = citem.BusinessHomePage
.CallbackTelephoneNumber = citem.CallbackTelephoneNumber
.CarTelephoneNumber = citem.CarTelephoneNumber
.Categories = citem.Categories
.Children = citem.Children
.Companies = citem.Companies
.CompanyName = citem.CompanyName
.ComputerNetworkName = citem.ComputerNetworkName
.CustomerID = citem.CustomerID
.Department = citem.Department
.Email1Address = citem.Email1Address
.Email1AddressType = citem.Email1AddressType
.Email2Address = citem.Email2Address
.Email2AddressType = citem.Email2AddressType
.Email3Address = citem.Email3Address
.Email3AddressType = citem.Email3AddressType
.FileAs = citem.FileAs
.FirstName = citem.FirstName
.FormDescription = citem.FormDescription
.FTPSite = citem.FTPSite
.FullName = citem.FullName
.Gender = citem.Gender
.GetInspector = citem.GetInspector
.GovernmentIDNumber = citem.GovernmentIDNumber
.Hobby = citem.Hobby
.Home2TelephoneNumber = citem.Home2TelephoneNumber
.HomeAddress = citem.HomeAddress
.HomeAddressCity = citem.HomeAddressCity
.HomeAddressCountry = citem.HomeAddressCountry
.HomeAddressPostalCode = citem.HomeAddressPostalCode
.HomeAddressPostOfficeBox = citem.HomeAddressPostOfficeBox
.HomeAddressState = citem.HomeAddressState
.HomeAddressStreet = citem.HomeAddressStreet
.HomeFaxNumber = citem.HomeFaxNumber
.HomeTelephoneNumber = citem.HomeTelephoneNumber
.Importance = citem.Importance
.Initials = citem.Initials
.InternetFreeBusyAddress = citem.InternetFreeBusyAddress
.ISDNNumber = citem.ISDNNumber
.JobTitle = citem.JobTitle
.Journal = citem.Journal
.Language = citem.Language
.LastName = citem.LastName
.MailingAddress = citem.MailingAddress
.MailingAddressCity = citem.MailingAddressCity
.MailingAddressCountry = citem.MailingAddressCountry
.MailingAddressPostalCode = citem.MailingAddressPostalCode
.MailingAddressPostOfficeBox = citem.MailingAddressPostOfficeBox
.MailingAddressState = citem.MailingAddressState
.MailingAddressStreet = citem.MailingAddressStreet
.ManagerName = citem.ManagerName
.MessageClass = citem.MessageClass
.MiddleName = citem.MiddleName
.Mileage = citem.Mileage
.MobileTelephoneNumber = citem.MobileTelephoneNumber
.NetMeetingAlias = citem.NetMeetingAlias
.NetMeetingServer = citem.NetMeetingServer
.NickName = citem.NickName
.NoAging = citem.NoAging
.OfficeLocation = citem.OfficeLocation
.OrganizationalIDNumber = citem.OrganizationalIDNumber
.OtherAddress = citem.OtherAddress
.OtherAddressCity = citem.OtherAddressCity
.OtherAddressCountry = citem.OtherAddressCountry
.OtherAddressPostalCode = citem.OtherAddressPostalCode
.OtherAddressPostOfficeBox = citem.OtherAddressPostOfficeBox
.OtherAddressState = citem.OtherAddressState
.OtherAddressStreet = citem.OtherAddressStreet
.OtherFaxNumber = citem.OtherFaxNumber
.OtherTelephoneNumber = citem.OtherTelephoneNumber
.PagerNumber = citem.PagerNumber
.PersonalHomePage = citem.PersonalHomePage
.PrimaryTelephoneNumber = citem.PrimaryTelephoneNumber
.Profession = citem.Profession
.RadioTelephoneNumber = citem.RadioTelephoneNumber
.ReferredBy = citem.ReferredBy
.SelectedMailingAddress = citem.SelectedMailingAddress
.Sensitivity = citem.Sensitivity
.Spouse = citem.Spouse
.Subject = citem.Subject
.Suffix = citem.Suffix
.TelexNumber = citem.TelexNumber
.Title = citem.Title
.TTYTDDTelephoneNumber = citem.TTYTDDTelephoneNumber
.UnRead = citem.UnRead
.User1 = citem.User1
.User2 = citem.User2
.User3 = citem.User3
.User4 = citem.User4
.UserCertificate = citem.UserCertificate
.WebPage = citem.WebPage
.YomiCompanyName = citem.YomiCompanyName
.YomiFirstName = citem.YomiFirstName
.YomiLastName = citem.YomiLastName
oContact.Save
Set oContact = Nothing
Set oFolder = Nothing
Set oItems = Nothing
nombre = nombre + 1
End With
End If
Next
afic = MsgBox("Ajout de " & nombre & " contacts", vbCritical, "Contacts manager") <-- Message de confirmation à la fin que j'aimerais bien enlevé.
End Sub
Function comparer(nomcomplet)
Dim str1Input
Dim str2Input
Dim ditem
Dim strOutput
str1Input = nomcomplet
'str2Input = prenomcomplet
Set objOutlook = CreateObject("Outlook.application")
Set objNameSpace = objOutlook.GetNamespace("MAPI")
Set objFolder = objNameSpace.GetDefaultFolder(olFolderContacts)
For Each ditem In objFolder.Items
If (ditem.FileAs = str1Input) Then <-- Pour ma part, le script arrête ici lorsque je l'exécute, la comparaison ne fonctionne pas
'If (ditem.LastName = str2Input) Then
comparer = True
Exit Function
End If
'End If
Next
If strOutput = "" Then
comparer = False
End If
End Function |
Partager