Synchro des contacts publics et privé de outlook 2000

Télécharger le projet
Commenter

Description

Synchronisation du dossier publics "contacts entreprise" avec les contacts personnel dans Outlook 2000

Source / Exemple : 


Attribute VB_Name = "Module11"

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")

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")

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
            'If (ditem.LastName = str2Input) Then
        
        comparer = True
        Exit Function
        
        End If
 'End If
 
    Next

  If strOutput = "" Then
    comparer = False
  
  
  End If

End Function

Conclusion :


la syncronisation des carnet d'adresse chez microsoft est un casse tete, il est possible de forcer outlook express, ainssi que le telecopieur a utiliser le carnet d'adresse de outlook 2000, mais pas les carnet d'adresse de l'entreprise d'ou le devellopement de cette macro.
(HKCU/software/Microsoft/Wab/WAB4/UseOutlook = 1)

Code directement interpreté sous forme de macro sous outlook.
Ouvert à toutes améliorations.
Télécharger le projet

Codes Sources

A voir également

S'inscrire maintenant

Vous n'êtes pas encore membre ?

inscrivez-vous, c'est gratuit et ça prend moins d'une minute !

Les membres obtiennent plus de réponses que les utilisateurs anonymes.

Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.

Le fait d'être membre vous permet d'avoir des options supplémentaires.