CRÉER DES CONTACTS AVEC LES MESSAGES DE OUTLOOK

---

Commentaire sur cette source (5)
Ajouter un commentaire et/ou une note

La base de donnée est la pour qu'il n'y ait pas de doublons parce que les méthode GetNext du folder de contact n'ont pas l'air de fonctionner vraiment bien. Si quelqu'un sait comment ca marche je suis ouvert aux suggestions.

Option Explicit
Dim objApp As Outlook.Application
Dim Contact As ContactItem
Dim rsTmp As Recordset

Private Sub AjoutContact(Sender As String, Adresse As String)

'Créer une instance de Outlook
Set objApp = CreateObject("Outlook.Application")

Dim ContactItem As Outlook.ContactItem
'Crée une nouvelle instance de contact
Set Contact = objApp.CreateItem(olContactItem)
'Copie le nom de la personne qui à envoyer le email dans le contact
Contact.FullName = Sender
Contact.Email1Address = Adresse
'Sauvegarde le contact
Contact.Save

'Ajoute le contact dans la base de données
rsTmp.AddNew
rsTmp!Nom = Sender
rsTmp!email = Adresse
rsTmp.Update
rsTmp.Requery
Set Contact = Nothing

End Sub

Private Sub Command1_Click()
Dim objApp As Outlook.Application
Dim objConn As Connection
'Dim objNS As NameSpace
Dim Contact As ContactItem
Dim ContactFolder As MAPIFolder
Dim Boite As MAPIFolder
Dim Sent As MAPIFolder
Dim Item As Outlook.MailItem
Dim Msg As Outlook.MailItem
Dim Recipent As Outlook.Recipient
Dim ctr As Single
Dim str As String

'Ouverture d'un recordset pour qu'il n'y ait pas de doublons
Set objConn = New Connection
objConn.Open ("Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & App.Path & "\tmp.mdb;Persist Security Info=False")
Set rsTmp = New ADODB.Recordset
rsTmp.Open "Select * from table1", objConn.ConnectionString, adOpenKeyset, adLockOptimistic

'Supprime ce qu'il y a dans la table
If rsTmp.RecordCount > 0 Then
    rsTmp.MoveFirst
    While rsTmp.RecordCount > 0
        rsTmp.Delete adAffectCurrent
        rsTmp.Requery
    Wend
End If

'Label pour me dire quand l'opération est terminée
Label1.Visible = False

'Créer une instance de Outlook
Set objApp = CreateObject("Outlook.Application")

'Crée un NameSpace (je sais pas à quoi ça sert, donc je l'ai remplacé!)
'Set objNS = objApp.GetNamespace("MAPI")

'Associe la boîte de réception avec la variable boite
Set Boite = objApp.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)


'Associe le dossier "Éléments envoyés" avec la variable Sent
Set Sent = objApp.GetNamespace("MAPI").GetDefaultFolder(olFolderSentMail)

'Associe le dossier de contact avec la varible ContactFolder
Set ContactFolder = objApp.GetNamespace("MAPI").GetDefaultFolder(olFolderContacts)

'Calcul le nombre d'item dans la boîte de réception et éléments envoyés
ctr = Boite.Items.Count + Sent.Items.Count

'Calcul de combien doit avancer la progress bar chaque fois qu'elle a terminé avec un enregistrement
ctr = Round(100 / ctr, 1)
Progress.Value = 0


'PROCÉDURE POUR LA BOÎTE DE RÉCEPTION

For Each Item In Boite.Items
    Progress.Value = Progress.Value + ctr
    
    'Crée une réponse au message dans la boîte de réception pour avoir l'adresse de la personne
    Set Msg = Item.Reply
    
    For Each Recipent In Msg.Recipients
        If rsTmp.RecordCount > 0 Then
            rsTmp.MoveFirst
            'Vérifie si ce contact à déjà été ajouté existe déjà
            rsTmp.Find ("Nom = '" & Item.SenderName & "'")
            If rsTmp.EOF Then
            
                Call AjoutContact(Item.SenderName, Recipent.Address)
                
            End If
        Else
        
            Call AjoutContact(Item.SenderName, Recipent.Address)
            
        End If
    Next Recipent
Next Item


'PROCÉDURE POUR LES "ÉLÉMENTS ENVOYÉS

For Each Item In Sent.Items
    If Progress.Value + ctr > 100 Then
        Progress.Value = 100
    Else
        Progress.Value = Progress.Value + ctr
    End If
    
    
'    For Each Recipent In msg.Recipients
        If rsTmp.RecordCount > 0 Then
        
            rsTmp.MoveFirst
                           
            'Traitement sur l'addresse de la personne parce que quelle que fois, elle vient avec de "
            'au bout et d'autre fois elle vien sous la forme de 'Nom (email)'
            If InStr(1, Item.To, "(") Then
                str = Mid(Trim(Item.To), InStr(1, Item.To, "(") + 1, Len(Item.To))
                str = Left(str, Len(str) - 1)
            Else
                str = Left(Item.To, Len(Item.To) - 1)
                str = Mid(str, 2, Len(str))
            End If
            
            'Recherche cette adresse dans la base de données
            rsTmp.Find ("email = '" & str & "'")
            If rsTmp.EOF Then
        
                Call AjoutContact(Item.SenderName, str)
                
            End If
        Else
            Call AjoutContact(Item.SenderName, str)

        End If
Next Item

Label1.Visible = True
Progress.Value = 0

rsTmp.Close

Set rsTmp = Nothing
Set Boite = Nothing
Set Sent = Nothing
Set ContactFolder = Nothing
Set Item = Nothing
Set Recipent = Nothing

End Sub

Petite appli plutot inutile.
J'avais perdu mes contact dans Outlook et je n'avais pas vraiment le gout de les retapper. Donc, cette appli crée un contact avec l'adresse de chaque message de la boite de réception et dans les éléments envoyé.
J'ai cru que ca pouvais p-e aidé qqun qui a besoin de se promener un peu dans Outlook.
Seul problème: Avec Office Xp il faut autorisé l'accès à Outlook avant que le prog puisse s'exécuter

Soyez indulgent, c'est ma première source que je poste

Pour les "Membres Club", vous pouvez télécharger directement un fichier contenu dans le zip sans télécharger le zip en entier !

Télécharger le zip

• WORKTRACKER
• ETEINDRE L'ORDINATEUR DE DIFFERENTES MANIÈRES
• TABLEAU PERIDOQUES
• BUDGET MENSUEL
• VOCAL CITATION