Discussion :

[nogood1]

bjr a tous
ds dossier personnel --> boite de reception, j'ai créer un dossier "mailok"
je mets tous les mails interessant que je recois ds ce dossier.
Question:
Peux t on recuperer toutes les adresses emails de ces message recu dans le carnet de contact en automatique???

merci de me dire s'il faut ecrire du vba
Merci

[Dolphy35]

Bonjour,

je viens de mettre ton message dans ce sous-forum car pour moi il faut passer par du VBA.

quelles sont tes connaissance en VBA ?

http://dolphy35.developpez.com/article/outlook/vba/

Dolphy

[sanfric]

je farfouille sur divers sites pour trouver une méthode pour récupérer directement, à réception les adresses des expéditeurs. J'ai compris que ces adresses seraient en " lecture seule". La façon détournée de récupérer automatiquement ces adresses est de passer par un add-on qui enregistre des adresses dans Outlook automatiquement aux contacts après réponse à un email: Public Contact After Reply for Outlook chez http://www.publicshareware.fr/outlook-freeware.php. C'est un freeware que j'ai testé. L'idéal serait pour qu'il fonctionne automatiquement sur la boite de réception de créer une règle basé sur un script qui crée une réponse et la place dans la boîte d'envoi . Le Public Contact after Reply fera le reste. Cet add-on n'a pas l'air de fonctionner quand on crée une règle " répondre en utilisant un modèle spécifique" ( je pense que l'expédition est directe et n'est pas vue par Public Contact


J'ai bien trouvé un code d'Arno 2004 sur ce forum pour répondre aux mails reçus

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
Sub expéditeurs(item As MailItem)
 
     Dim m As MailItem
    Set m = Outlook.ActiveExplorer.CurrentFolder.Items.GetFirst
    Dim ObjMailitem2 As MailItem
    Set ObjMailitem2 = m.Reply
    Dim Nom_Expediteur As String
 
    Nom_Expediteur = ObjMailitem2.Recipients(1).Address
    Set ObjMailitem2 = Nothing
 
End Sub

http://www.developpez.net/forums/d15...il/#post105959

Mais il ne fonctionne pas avec Outlook 2007 ( message d'erreur sur la L.4.) Y a t-il une piste.

Autre adresse où il y a des scripts utilisant la références Redemption que j'ai réussi à intégrer. http://www.outlookcode.com/d/code/autoaddrecip.htm. Le Problème demeure entier car ce code ne peut fonctionner directement sur les adresses expéditeurs de la boîte de réception.
A moins qu'un "outlookiste" averti arrive à modifier le code...

Sinon, même constat que plus haut : il faudrait faire semblant de répondre pour que les adresses des expéditeurs soient récupérées.
Merci pour toutes les aides à venir

[Oliv-]

Salut,
Si je comprends bien tu veux récupérer et enregistrer en tant que contact l'adresse de l'expéditeur des mails se trouvant dans ton mailOK ?

Le code #1 de Sue Mosher est effectivement fait pour les mails envoyés.
voici une modification qui focntionne sur une selection d email.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
' This procedure can go in any module
Sub AddSenderSelection()
'by oliv 12/11/2008 
Dim MonOutlook As Outlook.Application
Dim Mail As Object
Dim LeMail As Outlook.MailItem
Dim LesMails As Object
Set MonOutlook = Outlook.Application
Set LesMails = MonOutlook.ActiveExplorer.Selection
 
For Each LeMail In LesMails
If LeMail.Class = olMail Then
        Call AddRecipToContacts(LeMail)
    End If
Next LeMail
Set LesMails = Nothing
End Sub
 
Sub AddRecipToContacts(objMail As Outlook.MailItem)
'by oliv 12/11/2008 
'Adapté de Sue Mosher
    Dim strFind As String
    Dim strAddress As String
    Dim objNS As Outlook.NameSpace
    Dim colContacts As Outlook.Items
    Dim objContact As Outlook.ContactItem
    Dim objRecip 'As Outlook.Recipient
    Dim i As Integer
    On Error Resume Next
 
    ' get Contacts folder and its Items collection
    Set objNS = Application.GetNamespace("MAPI")
    Set colContacts = _
      objNS.GetDefaultFolder(olFolderContacts).Items
 
    ' process message recipients
     objRecip = objMail.SenderEmailAddress
        ' check to see if the recip is already in Contacts
        strAddress = AddQuote(objRecip)
        For i = 1 To 3
            strFind = "[Email" & i & "Address] = " & _
                      strAddress
            Set objContact = colContacts.Find(strFind)
            If Not objContact Is Nothing Then
                Exit For
            End If
        Next
 
        ' if not, add it
        If objContact Is Nothing Then
            Set objContact = _
              Application.CreateItem(olContactItem)
            With objContact
                .FullName = objMail.SenderName
                .Email1Address = strAddress
                .Save
            End With
        End If
        Set objContact = Nothing
 
 
    Set objNS = Nothing
    Set objContact = Nothing
    Set colContacts = Nothing
End Sub
 
' helper function - put in any module
Function AddQuote(MyText) As String
'Sue Mosher
    AddQuote = Chr(34) & MyText & Chr(34)
End Function

avec ce code tu peux automatiser l'action sur tous les mails copiés dans le dossier mailok

dans THISOUTLOOKSESSION :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
Dim WithEvents colSentItems As Items
 
Private Sub Application_Startup()
'pour evenement itemadd
   Dim NS As Outlook.NameSpace
   Set NS = Application.GetNamespace("MAPI")
   Set colSentItems = NS.GetDefaultFolder(olFolderInbox).folders("mailok").Items
   Set NS = Nothing
 'Fin Section
End Sub
 
Private Sub colSentItems_ItemAdd(ByVal Item As Object)
'By Oliv ' janv 2008 pour Outlook 2003 feat. Sue Mosher
AddRecipToContacts item
end sub

Code :

[sanfric]

Merci à Oliv pour ses bons offices. Effectivement, je cherche à sauvegardes les adresses des expéditeurs figurant dans la boîte de réception de façon automatique ( pas nécessairement à l'ouverture de outlook mais à réception des messages.
- J'ai testé Application_Startup() mais il y a une erreur (voir fichier joint).

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

Set colSentItems = NS.GetDefaultFolder(olFolderInbox).folders("mailok").Items

- Peut-être est-il possible aussi de créer une règle pour traiter les messages à réception à partir du code que tu as modifié. Je ai tenté de créer cette règle en rajoutant un (item as MailItem) à la première ligne de AddSenderSélection avec la mention " sauf si l'expéditeur est dans le carnet d'adresses Contact". Cela fonctionne, mais j'ai trois fois l'adresse qui est copié dans les contacts....

Merci de poursuivre la recherche

[Oliv-]

Salut,
L'erreur, vient du fait qu'il ne trouve pas le dossier "mailok", peut être car j'ai supposé que c'était un sous dossier de la boite de reception, si par contre il est au même niveau il faut modifier par

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

Set colSentItems = NS.GetDefaultFolder(olFolderInbox).parent.folders("mailok").Items

Pour ta règle tu dois simplement utiliser ce qu'il y a en dessous de THISOUTLOOKSESSION dans mon précédent POST.

et dans ta règle faire appel au script colSentItems_ItemAdd.

PAr contre c'est étonnant qu'il te crée plusieurs fois le même contact

[sanfric]

Après plusieurs jours d'absence, je reviens sur ce sujet.
-J'ai tenté les solutions préconisées par Oliv mais je n'ai pas de dossier "mailok". Faut-il le créer ou utiliser "Inbox"?
- Pour créer une règle, il faut voir le Script suivant, dont le code est plus haut:

Private Sub Application_Startup()

que faut-il placer pour cela entre () ?
Merci d'avance.

[Oliv-]

Salut sanfric, mes réponses étaient basées sur la demande initiale de nogood1 c'est de là que vient le dossier MAILOK.

si tu veux opérer sur inbox

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

Set colSentItems = NS.GetDefaultFolder(olFolderInbox)

Il n'y a rien à mettre entre () dans Application_Startup()

[sanfric]

le code modifié par Oliv pour récupérer les adresses des expéditeurs fonctionne. Petit bémol: le If ... then vérifiant si ces expéditeurs ne sont pas déjà dans le dossier Contacts n'a pas l'air de fonctionner. A chaque nouvelle réception du même expéditeur, son adresse mail s'ajoute en doublons.
Pourtant tout me semble normal dans le code.
A suivre...

[djodjo2050]

Bonjour à tous,

je reviens sur ce sujet qui m'interresse et je voudrais confirmer (à regret) que les contacts s'ajoutent même si le contact est déja présent.

En fait je ne comprend pas pourquoi la boucle for s'arrete à i=3 ?

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
' check to see if the recip is already in Contacts
        strAddress = AddQuote(objRecip)
        For i = 1 To 3
            strFind = "[Email" & i & "Address] = " & _
                      strAddress
            Set objContact = colContacts.Find(strFind)
            If Not objContact Is Nothing Then
                Exit For
            End If
        Next

Cette boucle vérifie bien si le contact est bien déja dans le carnet de contact ?
S'il existe, le contact ne doit pas être crée !! ??

Ou est l'erreur ?

Merci à tous

[giggs0112002]

Bonjour,

Veuillez m'excuser de revenir sur un post si vieux, mais j'ai quelques petits problèmes avec les manipulations décrites ci-dessus. J'utilise Outlook 2010 SP1.
Je voudrais bien que Outlook enregistre les adresses mail de ma boite de réception dans mes contacts.

J'utilise les codes suivants dans le VBA et il me met "erreur d'exécution "13" incompatibilité de type".

Module :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
' This procedure can go in any module
Sub AddSenderSelection()
'by oliv 12/11/2011
Dim MonOutlook As Outlook.Application
Dim Mail As Object
Dim LeMail As Outlook.MailItem
Dim LesMails As Object
Set MonOutlook = Outlook.Application
Set LesMails = MonOutlook.ActiveExplorer.Selection
 
For Each LeMail In LesMails
If LeMail.Class = olMail Then
        Call AddRecipToContacts(LeMail)
    End If
Next LeMail
Set LesMails = Nothing
End Sub
 
Sub AddRecipToContacts(objMail As Outlook.MailItem)
'by oliv 12/11/2011
'Adapté de Sue Mosher
    Dim strFind As String
    Dim strAddress As String
    Dim objNS As Outlook.NameSpace
    Dim colContacts As Outlook.Items
    Dim objContact As Outlook.ContactItem
    Dim objRecip 'As Outlook.Recipient
    Dim i As Integer
    On Error Resume Next
 
    ' get Contacts folder and its Items collection
    Set objNS = Application.GetNamespace("MAPI")
    Set colContacts = _
      objNS.GetDefaultFolder(olFolderContacts).Items
 
    ' process message recipients
     objRecip = objMail.SenderEmailAddress
        ' check to see if the recip is already in Contacts
        strAddress = AddQuote(objRecip)
        For i = 1 To 3
            strFind = "[Email" & i & "Address] = " & _
                      strAddress
            Set objContact = colContacts.Find(strFind)
            If Not objContact Is Nothing Then
                Exit For
            End If
        Next
 
        ' if not, add it
        If objContact Is Nothing Then
            Set objContact = _
              Application.CreateItem(olContactItem)
            With objContact
                .FullName = objMail.SenderName
                .Email1Address = strAddress
                .Save
            End With
        End If
        Set objContact = Nothing
 
 
    Set objNS = Nothing
    Set objContact = Nothing
    Set colContacts = Nothing
End Sub
 
' helper function - put in any module
Function AddQuote(MyText) As String
'Sue Mosher
    AddQuote = Chr(34) & MyText & Chr(34)
End Function

et dans ThisOutlookSession

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
Dim WithEvents colSentItems As Items
 
Private Sub Application_Startup()
'pour evenement itemadd
   Dim NS As Outlook.NameSpace
   Set NS = Application.GetNamespace("MAPI")
   Set colSentItems = NS.GetDefaultFolder(olFolderInbox)
   Set NS = Nothing
 'Fin Section
End Sub
 
Private Sub colSentItems_ItemAdd(ByVal Item As Object)
'By Oliv ' janv 2011 pour Outlook 2010 feat. Sue Mosher
AddRecipToContacts Item
End Sub

Quel est le problème? Merci d'avance