Automation depuis Access ne fonctionne plus

**clickandgo** · 11/01/2015, 02h27

Oliv , le code est 2 posts plus haut, il n'a pas changé ...
Faisons ça à tête reposée en dehors du W.E. ...

**clickandgo** · 25/06/2015, 23h57

Bonjour à tous

Je reviens sur cette discussion car le code n'est toujours pas opérant , j'ai maintenant une erreur "utilisation incorrecte de null" pointant vers la ligne :

Code :

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

strNumContact = DLookup("numcontact", "contacts", "mail1 = """ & strMail & """ Or Mail2 = """ & strMail & """ Or Mail3 = """ & strMail & """")

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
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
Public Function ImportMailsOutlook()
 
    On Error GoTo Description_Err
 
 
    Dim db As Database
    Dim strAttachment As String
    Dim strSQL As String
    Dim rsMail As DAO.Recordset
    Dim blnMailTrouvé As Boolean
    Dim strMail As String
    Dim strTypeMail As String
    Dim strNumContact As String
    Dim Boucle As Byte ' Variable contenant le numéro de la boucle
 
 
    Dim Ol_App As New Outlook.Application
    Dim Ol_Mapi As Outlook.NameSpace
    Dim Ol_Folder As Outlook.MAPIFolder
    Dim Ol_Items As Outlook.MailItem
    Dim Ol_Attach As Outlook.Attachment
    Dim Ol_SubFolder As Outlook.MAPIFolder ' Déclaration de l'objet sous-dossier
 
    Set rsMail = CurrentDb.OpenRecordset("Mails importés outlook")
    Set Ol_Mapi = Ol_App.GetNamespace("MAPI")
    Set Ol_Folder = Ol_Mapi.PickFolder 'On spécifie ici la fenêtre de sélection de dossiers Outlook
    Set db = CurrentDb
    Boucle = 1 ' Initialisation de la variable Boucle à 1 (Première Boucle)
 
 
 
Debut:
 
    For Each Ol_Items In Ol_Folder.Items
 
' Initialisation des variables strMail et strSQL en fonction du numéro de boucle
        Select Case Boucle
 
            Case "1" ' Première Boucle
               strMail = GetSMTPAddressForRecipient(Ol_Items.Recipients.item(1)) 'Filtre pour éléments envoyés par adresse mail du contact
 
               strSQL = "SELECT NumContact FROM Contacts" _
               & " WHERE Mail1 = """ & strMail & """" _
                     & " OR Mail2 = """ & strMail & """" _
                     & " OR Mail3 = """ & strMail & """"
 
                     'Variable avec Dlookup pour recherche du numéro de contact correspondant à chaque mail importé :
                     strNumContact = DLookup("numcontact", "contacts", "mail1 = """ & strMail & """ Or Mail2 = """ & strMail & """ Or Mail3 = """ & strMail & """")
 
                strTypeMail = "Envoyé" 'Cette variable permettra ensuite de distinguer le type du mail dans la table "Mails importés outlook"
 
                    Debug.Print strNumContact
 
            Case "2" ' Deuxième Boucle
 
                strMail = Get_sender_exchange(Ol_Items) '.SenderEmailAddress 'Filtre pour éléments reçus par adresse mail du contact
 
                strSQL = "SELECT NumContact FROM Contacts" _
                     & " WHERE Mail1 = """ & strMail & """" _
                     & " OR Mail2 = """ & strMail & """" _
                     & " OR Mail3 = """ & strMail & """"
 
                     'Variable avec Dlookup pour recherche du numéro de contact correspondant à chaque mail importé :
                     strNumContact = DLookup("numcontact", "contacts", "mail1 = """ & strMail & """ Or Mail2 = """ & strMail & """ Or Mail3 = """ & strMail & """")
 
                     strTypeMail = "Reçu" 'Cette variable permettra ensuite de distinguer le type du mail dans la table "Mails importés outlook"
 
 
 
        End Select
 
        With db.OpenRecordset(strSQL)
            blnMailTrouvé = (.EOF = False)
 
        End With
 
        If blnMailTrouvé Then 'Vérifie si il y a des données pour un enregistrement donné
 
            For Each Ol_Attach In Ol_Items.Attachments
                strAttachment = strAttachment & Ol_Attach.DisplayName & vbCrLf
 
            Next Ol_Attach
 
 
 
        With rsMail ' Remplissage de la table avec le résultat des filtres :
 
               .AddNew
 
               !Bcc = Ol_Items.Bcc
               !Categories = Ol_Items.Categories
               !Cc = Ol_Items.Cc
               !ConversationTopic = Ol_Items.ConversationTopic
               !CreationTime = Ol_Items.CreationTime
               !HTMLBody = Ol_Items.HTMLBody
               !LastModificationTime = Ol_Items.LastModificationTime
               !ReceivedByName = Ol_Items.ReceivedByName
               !ReceivedTime = Ol_Items.ReceivedTime
               !SenderName = Ol_Items.SenderName
               !Sent = Ol_Items.Sent
               !SentOn = Ol_Items.SentOn
               !SenderAddress = Ol_Items.SenderEmailAddress
               !Size = Ol_Items.Size
               !Subject = Ol_Items.Subject
               !TO = Ol_Items.TO
               !UnRead = Ol_Items.UnRead
               !RecipientMail = Ol_Items.Recipients.item(1).Address
               !Attachments = strAttachment
               !TypeMail = strTypeMail 'On ajoute le type du mail actuel (on peut facilement rajouter des types en recherchant dans les champs du mail une valeur donnée)
               !NumContact = strNumContact ' On récupère le numéro ou Id du contact actuel
 
               .Update
               If Not (err = 3022 Or err = 0) Then
Stop
                    End If
                    On Error GoTo 0
               Debug.Print Ol_Items.HTMLBody
 
            End With
            strAttachment = ""
 
 
 
         End If
   Next Ol_Items
 
' Si la variable Boucle = 1 alors lancement de la deuxième boucle, sinon suite et fin de la fonction
    If Boucle = "1" Then
        Boucle = "2"
                                                                                                                                                                  GoTo Debut
    End If
    rsMail.Close
 
 
    MsgBox "Les données ont été importées"
 
Description_Err:
 
        MsgBox " Erreur " & err.Number & Chr(10) & err.Description
 
 
    'On libère la mémoire :
 
    Set rsMail = Nothing
    Set Ol_Attach = Nothing
    Set Ol_Items = Nothing
    Set Ol_Folder = Nothing
    Set Ol_Mapi = Nothing
    Set Ol_App = Nothing
 
End Function
Function GetSMTPAddressForRecipient(recip As Outlook.Recipient) As String
'Dim recip As Outlook.Recipient
    Dim pa As Outlook.PropertyAccessor
    Const PR_SMTP_ADDRESS As String = _
          "http://schemas.microsoft.com/mapi/proptag/0x39FE001E"
    Set pa = recip.PropertyAccessor
    On Error Resume Next
Debug.Print recip.Name & " SMTP=" _
          & pa.GetProperty(PR_SMTP_ADDRESS)
    GetSMTPAddressForRecipient = pa.GetProperty(PR_SMTP_ADDRESS)
    If GetSMTPAddressForRecipient = "" Then GetSMTPAddressForRecipient = recip.Address
End Function
 
Private Function Get_sender_exchange(OITEM As Outlook.MailItem) As String
    Dim oEU As Outlook.ExchangeUser
    On Error Resume Next
    Set oEU = OITEM.Sender.GetExchangeUser
 
    Get_sender_exchange = oEU.PrimarySmtpAddress
    If Get_sender_exchange = "" Then Get_sender_exchange = OITEM.SenderEmailAddress
End Function

D'autre part la ligne :

Code :

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

strMail = GetSMTPAddressForRecipient(Ol_Items.Recipients.item(1))

n'est apparament pas adéquate puisque ce que l'on veut c'est rechercher les adresses mails des mails reçus dans la table de mails importés, or là la variable strMail indique l'adresse mail du receveur uniquement , quelle serait la commande pour cette option svp ?

**Oliv-** · 26/06/2015, 09h28

Envoyé par clickandgo

Bonjour à tous

Je reviens sur cette discussion car le code n'est toujours pas opérant , j'ai maintenant une erreur "utilisation incorrecte de null" pointant vers la ligne :

Code :

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

strNumContact = DLookup("numcontact", "contacts", "mail1 = """ & strMail & """ Or Mail2 = """ & strMail & """ Or Mail3 = """ & strMail & """")

Envoyé par clickandgo

D'autre part la ligne :

Code :

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

strMail = GetSMTPAddressForRecipient(Ol_Items.Recipients.item(1))

n'est apparament pas adéquate puisque ce que l'on veut c'est rechercher les adresses mails des mails reçus dans la table de mails importés, or là la variable strMail indique l'adresse mail du receveur uniquement , quelle serait la commande pour cette option svp ?

Cela reprend ce que tu faisais au départ , c'est à dire taiter le premier destinataire

Code :

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

1
2
Case "1" ' Première Boucle
               strMail = Ol_Items.Recipients.item(1).Address 'Filtre pour éléments envoyés par adresse mail du contact

Si tu veux tester tous les destinataires d'un Email il faut faire une boucle

Code :

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

1
2
3
4
5
6
7
 
For each dest in Ol_Items.Recipients
 
...
strMail = GetSMTPAddressForRecipient(dest)
...
Next dest

**clickandgo** · 26/06/2015, 12h42

Merci Oliv pour ton explication

Il y a du progrès l'importation se réalise bien mais est incomplète (seulement 196 messages sur 856 ... ) et un message de "incompatibilité de type" survient en fin de traitement en pointant "Next OlItems", bref je comprends pas ...

**Oliv-** · 26/06/2015, 14h03

ca vient de ta déclaration

Code :

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

  Dim Ol_Items As Outlook.MailItem

tu parcours tous les éléments du dossier, mais il peut y avoir autre chose que des EMAILS dans ce dossier du coup ca bug!

essayes comme cela :

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
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
Public Function ImportMailsOutlook()

    On Error GoTo Description_Err


    Dim db As Database
    Dim strAttachment As String
    Dim strSQL As String
    Dim rsMail As DAO.Recordset
    Dim blnMailTrouvé As Boolean
    Dim strMail As String
    Dim strTypeMail As String
    Dim strNumContact As String
    Dim Boucle As Byte    ' Variable contenant le numéro de la boucle


    Dim Ol_App As New Outlook.Application
    Dim Ol_Mapi As Outlook.Namespace
    Dim Ol_Folder As Outlook.MAPIFolder
    Dim Ol_Items As Object
    Dim Ol_Mail As Outlook.MailItem
    Dim Ol_Attach As Outlook.Attachment
    Dim Ol_SubFolder As Outlook.MAPIFolder    ' Déclaration de l'objet sous-dossier

    Set rsMail = CurrentDb.OpenRecordset("Mails importés outlook")
    Set Ol_Mapi = Ol_App.GetNamespace("MAPI")
    Set Ol_Folder = Ol_Mapi.PickFolder    'On spécifie ici la fenêtre de sélection de dossiers Outlook
    Set db = CurrentDb
    Boucle = 1    ' Initialisation de la variable Boucle à 1 (Première Boucle)



Debut:

    For Each Ol_Items In Ol_Folder.Items

        If Ol_Items.Class = olMail Then

            Set Ol_Mail = Ol_Items

            ' Initialisation des variables strMail et strSQL en fonction du numéro de boucle
            Select Case Boucle

            Case "1"    ' Première Boucle
                strMail = GetSMTPAddressForRecipient(Ol_Mail.Recipients.Item(1))    'Filtre pour éléments envoyés par adresse mail du contact

                strSQL = "SELECT NumContact FROM Contacts" _
                       & " WHERE Mail1 = """ & strMail & """" _
                       & " OR Mail2 = """ & strMail & """" _
                       & " OR Mail3 = """ & strMail & """"

                'Variable avec Dlookup pour recherche du numéro de contact correspondant à chaque mail importé :
                strNumContact = DLookup("numcontact", "contacts", "mail1 = """ & strMail & """ Or Mail2 = """ & strMail & """ Or Mail3 = """ & strMail & """")

                strTypeMail = "Envoyé"    'Cette variable permettra ensuite de distinguer le type du mail dans la table "Mails importés outlook"

                Debug.Print strNumContact

            Case "2"    ' Deuxième Boucle

                strMail = Get_sender_exchange(Ol_Mail)    '.SenderEmailAddress 'Filtre pour éléments reçus par adresse mail du contact

                strSQL = "SELECT NumContact FROM Contacts" _
                       & " WHERE Mail1 = """ & strMail & """" _
                       & " OR Mail2 = """ & strMail & """" _
                       & " OR Mail3 = """ & strMail & """"

                'Variable avec Dlookup pour recherche du numéro de contact correspondant à chaque mail importé :
                strNumContact = DLookup("numcontact", "contacts", "mail1 = """ & strMail & """ Or Mail2 = """ & strMail & """ Or Mail3 = """ & strMail & """")

                strTypeMail = "Reçu"    'Cette variable permettra ensuite de distinguer le type du mail dans la table "Mails importés outlook"



            End Select

            With db.OpenRecordset(strSQL)
                blnMailTrouvé = (.EOF = False)

            End With

            If blnMailTrouvé Then    'Vérifie si il y a des données pour un enregistrement donné

                For Each Ol_Attach In Ol_Mail.Attachments
                    strAttachment = strAttachment & Ol_Attach.DisplayName & vbCrLf

                Next Ol_Attach



                With rsMail    ' Remplissage de la table avec le résultat des filtres :

                    .AddNew

                    !Bcc = Ol_Mail.Bcc
                    !Categories = Ol_Mail.Categories
                    !Cc = Ol_Mail.Cc
                    !ConversationTopic = Ol_Mail.ConversationTopic
                    !CreationTime = Ol_Mail.CreationTime
                    !HTMLBody = Ol_Mail.HTMLBody
                    !LastModificationTime = Ol_Mail.LastModificationTime
                    !ReceivedByName = Ol_Mail.ReceivedByName
                    !ReceivedTime = Ol_Mail.ReceivedTime
                    !SenderName = Ol_Mail.SenderName
                    !Sent = Ol_Mail.Sent
                    !SentOn = Ol_Mail.SentOn
                    !SenderAddress = Ol_Mail.SenderEmailAddress
                    !Size = Ol_Mail.Size
                    !Subject = Ol_Mail.Subject
                    !TO = Ol_Mail.TO
                    !UnRead = Ol_Mail.UnRead
                    !RecipientMail = Ol_Mail.Recipients.Item(1).Address
                    !Attachments = strAttachment
                    !TypeMail = strTypeMail    'On ajoute le type du mail actuel (on peut facilement rajouter des types en recherchant dans les champs du mail une valeur donnée)
                    !NumContact = strNumContact    ' On récupère le numéro ou Id du contact actuel

                    .Update
                    If Not (Err = 3022 Or Err = 0) Then
                        Stop
                    End If
                    On Error GoTo 0
                    Debug.Print Ol_Mail.HTMLBody

                End With
                strAttachment = ""



            End If
        End If
    Next Ol_Items

    ' Si la variable Boucle = 1 alors lancement de la deuxième boucle, sinon suite et fin de la fonction
    If Boucle = "1" Then
        Boucle = "2"
        GoTo Debut
    End If
    rsMail.Close


    MsgBox "Les données ont été importées"

Description_Err:

    MsgBox " Erreur " & Err.Number & Chr(10) & Err.Description


    'On libère la mémoire :

    Set rsMail = Nothing
    Set Ol_Attach = Nothing
    Set Ol_Mail = Nothing
    Set Ol_Folder = Nothing
    Set Ol_Mapi = Nothing
    Set Ol_App = Nothing

End Function
Function GetSMTPAddressForRecipient(recip As Outlook.Recipient) As String
'Dim recip As Outlook.Recipient
    Dim pa As Outlook.PropertyAccessor
    Const PR_SMTP_ADDRESS As String = _
          "http://schemas.microsoft.com/mapi/proptag/0x39FE001E"
    Set pa = recip.PropertyAccessor
    On Error Resume Next
    Debug.Print recip.Name & " SMTP=" _
              & pa.GetProperty(PR_SMTP_ADDRESS)
    GetSMTPAddressForRecipient = pa.GetProperty(PR_SMTP_ADDRESS)
    If GetSMTPAddressForRecipient = "" Then GetSMTPAddressForRecipient = recip.Address
End Function

Private Function Get_sender_exchange(OITEM As Outlook.MailItem) As String
    Dim oEU As Outlook.ExchangeUser
    On Error Resume Next
    Set oEU = OITEM.Sender.GetExchangeUser

    Get_sender_exchange = oEU.PrimarySmtpAddress
    If Get_sender_exchange = "" Then Get_sender_exchange = OITEM.SenderEmailAddress
End Function

**clickandgo** · 26/06/2015, 16h56

Merci Oliv,

Gros progrès !, ça importe bien depuis la première boucle.

A la deuxième boucle apparait une erreur : "Objet requis ..." en pointant la ligne :

Code :

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

strMail = Get_sender_exchange(Ol_Items.SenderEmailAddress) 'Filtre pour éléments reçus par adresse mail du contact

De toutes façons l'idéal serait dans un futur que la fonction scanne tous les dossiers et sous dossiers et aille rechercher seulement les mails manquants tout en indiquant les dossiers Outlook dans lesquels ils se trouvent... Pour l'instant je suis obligé d'aller dossier par dossier et c'est pas génial ...

**Oliv-** · 29/06/2015, 15h12

je n'avais pas surligné toutes les occurences où il faut remplacer
Ol_Mail par Ol_Items

tu aurais tu copier l'ensemble du code ! ici la correction

Code :

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

 strMail = Get_sender_exchange(Ol_Mail)

Mais si tu veux une fonction récursive ton code doit ressembler à cela (je n'ai pas testé)

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
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
190
191
192
193
194
195
196
197
198
Dim db As Database
Dim strAttachment As String
Dim strSQL As String
Dim rsMail As DAO.Recordset
Dim blnMailTrouvé As Boolean
Dim strMail As String
Dim strTypeMail As String
Dim strNumContact As String
Dim Boucle As Byte    ' Variable contenant le numéro de la boucle
 
 
Dim Ol_App As New Outlook.Application
Dim Ol_Mapi As Outlook.Namespace
Dim Ol_Folder As Outlook.MAPIFolder
Dim Ol_Items As Object
Dim Ol_Mail As Outlook.MailItem
Dim Ol_Attach As Outlook.Attachment
Dim Ol_SubFolder As Outlook.MAPIFolder
 
Public Function ImportMailsOutlook()
 
    On Error GoTo Description_Err
 
    ' Déclaration de l'objet sous-dossier
 
    Set rsMail = CurrentDb.OpenRecordset("Mails importés outlook")
    Set Ol_Mapi = Ol_App.GetNamespace("MAPI")
    Set Ol_Folder = Ol_Mapi.PickFolder    'On spécifie ici la fenêtre de sélection de dossiers Outlook
    Set db = CurrentDb
 
Debut:
 
    Call ProcessFolder(Ol_Folder, True)
 
    rsMail.Close
 
    MsgBox "Les données ont été importées"
 
Description_Err:
 
    MsgBox " Erreur " & Err.Number & Chr(10) & Err.Description
 
 
    'On libère la mémoire :
 
    Set rsMail = Nothing
    Set Ol_Attach = Nothing
    Set Ol_Mail = Nothing
    Set Ol_Folder = Nothing
    Set Ol_Mapi = Nothing
    Set Ol_App = Nothing
 
End Function
 
Sub ProcessFolder(StartFolder As Outlook.MAPIFolder, SubFolder As Boolean)
'---------------------------------------------------------------------------------------
' Procedure : ProcessFolder
' Author    : OCTU
' Date      : 16/06/2015
' Purpose   : Fonction recursive pour faire quelque chose dans le dossier et ses sous dossiers
'---------------------------------------------------------------------------------------
'
    Dim objFolder As Outlook.MAPIFolder
    Dim item As Object
    'Dim objItem As Object
    On Error Resume Next
 
    ' process all the subfolders of this folder
    For Each objFolder In StartFolder.Folders
        Call ProcessFolder(objFolder, SubFolder)
    Next
 
    ' process all the items in this folder
    For Each item In StartFolder.items
        Call traitement_mail(item)
    Next
 
    Set objFolder = Nothing
End Sub
Sub traitement_mail(Ol_Items)
    If Ol_Items.Class = olMail Then
 
        Set Ol_Mail = Ol_Items
        For Each Boucle In Array("1", "2")
            ' Initialisation des variables strMail et strSQL en fonction du numéro de boucle
            Select Case Boucle
 
            Case "1"    ' Première Boucle
                strMail = GetSMTPAddressForRecipient(Ol_Mail.Recipients.item(1))    'Filtre pour éléments envoyés par adresse mail du contact
 
                strSQL = "SELECT NumContact FROM Contacts" _
                       & " WHERE Mail1 = """ & strMail & """" _
                       & " OR Mail2 = """ & strMail & """" _
                       & " OR Mail3 = """ & strMail & """"
 
                'Variable avec Dlookup pour recherche du numéro de contact correspondant à chaque mail importé :
                strNumContact = DLookup("numcontact", "contacts", "mail1 = """ & strMail & """ Or Mail2 = """ & strMail & """ Or Mail3 = """ & strMail & """")
 
                strTypeMail = "Envoyé"    'Cette variable permettra ensuite de distinguer le type du mail dans la table "Mails importés outlook"
 
                Debug.Print strNumContact
 
            Case "2"    ' Deuxième Boucle
 
                strMail = Get_sender_exchange(Ol_Mail)    '.SenderEmailAddress 'Filtre pour éléments reçus par adresse mail du contact
 
                strSQL = "SELECT NumContact FROM Contacts" _
                       & " WHERE Mail1 = """ & strMail & """" _
                       & " OR Mail2 = """ & strMail & """" _
                       & " OR Mail3 = """ & strMail & """"
 
                'Variable avec Dlookup pour recherche du numéro de contact correspondant à chaque mail importé :
                strNumContact = DLookup("numcontact", "contacts", "mail1 = """ & strMail & """ Or Mail2 = """ & strMail & """ Or Mail3 = """ & strMail & """")
 
                strTypeMail = "Reçu"    'Cette variable permettra ensuite de distinguer le type du mail dans la table "Mails importés outlook"
 
 
 
            End Select
 
            With db.OpenRecordset(strSQL)
                blnMailTrouvé = (.EOF = False)
 
            End With
 
            If blnMailTrouvé Then    'Vérifie si il y a des données pour un enregistrement donné
 
                For Each Ol_Attach In Ol_Mail.Attachments
                    strAttachment = strAttachment & Ol_Attach.DisplayName & vbCrLf
 
                Next Ol_Attach
 
 
 
                With rsMail    ' Remplissage de la table avec le résultat des filtres :
 
                    .AddNew
 
                    !Bcc = Ol_Mail.Bcc
                    !Categories = Ol_Mail.Categories
                    !Cc = Ol_Mail.Cc
                    !ConversationTopic = Ol_Mail.ConversationTopic
                    !CreationTime = Ol_Mail.CreationTime
                    !HTMLBody = Ol_Mail.HTMLBody
                    !LastModificationTime = Ol_Mail.LastModificationTime
                    !ReceivedByName = Ol_Mail.ReceivedByName
                    !ReceivedTime = Ol_Mail.ReceivedTime
                    !SenderName = Ol_Mail.SenderName
                    !Sent = Ol_Mail.Sent
                    !SentOn = Ol_Mail.SentOn
                    !SenderAddress = Ol_Mail.SenderEmailAddress
                    !Size = Ol_Mail.Size
                    !Subject = Ol_Mail.Subject
                    !TO = Ol_Mail.TO
                    !UnRead = Ol_Mail.UnRead
                    !RecipientMail = Ol_Mail.Recipients.item(1).Address
                    !Attachments = strAttachment
                    !TypeMail = strTypeMail    'On ajoute le type du mail actuel (on peut facilement rajouter des types en recherchant dans les champs du mail une valeur donnée)
                    !NumContact = strNumContact    ' On récupère le numéro ou Id du contact actuel
 
                    .Update
                    If Not (Err = 3022 Or Err = 0) Then
                        Stop
                    End If
                    On Error GoTo 0
                    Debug.Print Ol_Mail.HTMLBody
 
                End With
                strAttachment = ""
 
 
 
            End If
        Next Boucle
    End If
 
End Sub
Function GetSMTPAddressForRecipient(recip As Outlook.Recipient) As String
'Dim recip As Outlook.Recipient
    Dim pa As Outlook.PropertyAccessor
    Const PR_SMTP_ADDRESS As String = _
          "http://schemas.microsoft.com/mapi/proptag/0x39FE001E"
    Set pa = recip.PropertyAccessor
    On Error Resume Next
    Debug.Print recip.Name & " SMTP=" _
              & pa.GetProperty(PR_SMTP_ADDRESS)
    GetSMTPAddressForRecipient = pa.GetProperty(PR_SMTP_ADDRESS)
    If GetSMTPAddressForRecipient = "" Then GetSMTPAddressForRecipient = recip.Address
End Function
 
Private Function Get_sender_exchange(OITEM As Outlook.MailItem) As String
    Dim oEU As Outlook.ExchangeUser
    On Error Resume Next
    Set oEU = OITEM.Sender.GetExchangeUser
 
    Get_sender_exchange = oEU.PrimarySmtpAddress
    If Get_sender_exchange = "" Then Get_sender_exchange = OITEM.SenderEmailAddress
End Function

**clickandgo** · 01/07/2015, 11h36

Merci Oliv pour ce magnifique travail !

Il manque apparament la fonction "ProcessFolderSize" pourrais tu la recopier ici ?

Merci d'avance

**Oliv-** · 01/07/2015, 11h50

Bonjour,
C'est une erreur il faut remplacer ProcessFolderSize par ProcessFolder, j'ai corrigé le code

**clickandgo** · 03/07/2015, 19h14

Bonjour Oliv

Il signale "variable non définie" en pointant sur "Set Ol_Mail = Ol_Items"
dans :

Code :

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

1
2
3
4
Sub traitement_mail(Ol_Items)
    If Ol_Items.Class = olMail Then
 
        Set Ol_Mail = Ol_Items

qu'est-ce ?

**clickandgo** · 10/09/2015, 18h23

Bonjour ,

Y a t'il quelqu'un dans la salle ?

Je n'ai pas encore eu de réponse ...

Merci

**Oliv-** · 10/09/2015, 20h35

Bonsoir,
Y a pas grand monde qui répond en tout cas !
Ca veut dire que tu dois la définir=déclarer, sans doute parce que tu as "option explicit" en haut de ton module.

http://silkyroad.developpez.com/VBA/LesVariables/

Code :

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

dim Ol_Mail

**clickandgo** · 11/09/2015, 12h50

Merci Oliv, ça marche presque parfaitement, en fin d'importation j'ai maintenant un message "utilisation incorrecte de null" et rien ne s'importe

Je me permets de poser quelques questions :

1/Comment mettre en place une barre de progression qui s'affiche durant le temps d'importation ?

2/ Est il possible de signaler à l'utilisateur le nombre d'Items à importer ?

En attendant la réponse merci beaucoup pour tout ce travail qui m'a sauvé la vie

Voici le code :

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
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
190
191
192
193
194
195
196
197
198
199
200
201
202
203
Public Function ImportMailsOutlook()
 
Dim db As Database
Dim rsMail As DAO.Recordset
Dim Ol_App As New outlook.Application
Dim Ol_Mapi As outlook.NameSpace
Dim Ol_Folder As outlook.MAPIFolder
 
 
 
 
    On Error GoTo Description_Err
 
    ' Déclaration de l'objet sous-dossier
 
    Set rsMail = CurrentDb.OpenRecordset("Mails importés outlook")
    Set Ol_Mapi = Ol_App.GetNamespace("MAPI")
    Set Ol_Folder = Ol_Mapi.PickFolder    'On spécifie ici la fenêtre de sélection de dossiers Outlook
    Set db = CurrentDb
 
Debut:
 
    Call ProcessFolder(Ol_Folder, True)
 
    rsMail.Close
 
    MsgBox "Les données ont été importées"
 
Description_Err:
 
    MsgBox " Erreur " & err.Number & Chr(10) & err.Description
 
 
    'On libère la mémoire :
 
    Set rsMail = Nothing
    Set Ol_Folder = Nothing
    Set Ol_Mapi = Nothing
    Set Ol_App = Nothing
 
End Function
 
Sub ProcessFolder(StartFolder As outlook.MAPIFolder, SubFolder As Boolean)
'---------------------------------------------------------------------------------------
' Procedure : ProcessFolder
' Author    : OCTU
' Date      : 16/06/2015
' Purpose   : Fonction recursive pour faire quelque chose dans le dossier et ses sous dossiers
'---------------------------------------------------------------------------------------
'
    Dim objFolder As outlook.MAPIFolder
    Dim item As Object
    'Dim objItem As Object
    On Error Resume Next
 
    ' process all the subfolders of this folder
    For Each objFolder In StartFolder.Folders
        Call ProcessFolder(objFolder, SubFolder)
    Next
 
    ' process all the items in this folder
    For Each item In StartFolder.Items
        Call Traitement_Mails(item)
    Next
 
    Set objFolder = Nothing
End Sub
Sub Traitement_Mails(Ol_Items)
 
Dim Ol_Mail As outlook.MailItem
Dim db As Database
Dim boucle As Variant
Dim strMail As String
Dim strSQL As String
Dim strNumContact As String
Dim strTypeMail As String
Dim blnMailTrouvé As Boolean
Dim strAttachment As String
Dim rsMail As DAO.Recordset
Dim Ol_Attach As outlook.Attachment
 
 
    If Ol_Items.Class = olMail Then
 
        Set Ol_Mail = Ol_Items
        For Each boucle In Array("1", "2")
            ' Initialisation des variables strMail et strSQL en fonction du numéro de boucle
            Select Case boucle
 
            Case "1"    ' Première Boucle
                strMail = GetSMTPAddressForRecipient(Ol_Mail.Recipients.item(1))    'Filtre pour éléments envoyés par adresse mail du contact
 
                strSQL = "SELECT NumContact FROM Contacts" _
                       & " WHERE Mail1 = """ & strMail & """" _
                       & " OR Mail2 = """ & strMail & """" _
                       & " OR Mail3 = """ & strMail & """"
 
                'Variable avec Dlookup pour recherche du numéro de contact correspondant à chaque mail importé :
                strNumContact = DLookup("numcontact", "contacts", "mail1 = """ & strMail & """ Or Mail2 = """ & strMail & """ Or Mail3 = """ & strMail & """")
 
                strTypeMail = "Envoyé"    'Cette variable permettra ensuite de distinguer le type du mail dans la table "Mails importés outlook"
 
 
 
            Case "2"    ' Deuxième Boucle
 
                strMail = Get_sender_exchange(Ol_Mail)    '.SenderEmailAddress 'Filtre pour éléments reçus par adresse mail du contact
 
                strSQL = "SELECT NumContact FROM Contacts" _
                       & " WHERE Mail1 = """ & strMail & """" _
                       & " OR Mail2 = """ & strMail & """" _
                       & " OR Mail3 = """ & strMail & """"
 
                'Variable avec Dlookup pour recherche du numéro de contact correspondant à chaque mail importé :
                strNumContact = DLookup("numcontact", "contacts", "mail1 = """ & strMail & """ Or Mail2 = """ & strMail & """ Or Mail3 = """ & strMail & """")
 
                strTypeMail = "Reçu"    'Cette variable permettra ensuite de distinguer le type du mail dans la table "Mails importés outlook"
 
 
 
            End Select
 
            With db.OpenRecordset(strSQL)
                blnMailTrouvé = (.EOF = False)
 
            End With
 
            If blnMailTrouvé Then    'Vérifie si il y a des données pour un enregistrement donné
 
                For Each Ol_Attach In Ol_Mail.Attachments
                    strAttachment = strAttachment & Ol_Attach.DisplayName & vbCrLf
 
                Next Ol_Attach
 
 
 
                With rsMail    ' Remplissage de la table avec le résultat des filtres :
 
                    .AddNew
 
                    !Bcc = Ol_Mail.Bcc
                    !Categories = Ol_Mail.Categories
                    !Cc = Ol_Mail.Cc
                    !ConversationTopic = Ol_Mail.ConversationTopic
                    !CreationTime = Ol_Mail.CreationTime
                    !HTMLBody = Ol_Mail.HTMLBody
                    !LastModificationTime = Ol_Mail.LastModificationTime
                    !ReceivedByName = Ol_Mail.ReceivedByName
                    !ReceivedTime = Ol_Mail.ReceivedTime
                    !SenderName = Ol_Mail.SenderName
                    !Sent = Ol_Mail.Sent
                    !SentOn = Ol_Mail.SentOn
                    !SenderAddress = Ol_Mail.SenderEmailAddress
                    !Size = Ol_Mail.Size
                    !Subject = Ol_Mail.Subject
                    !To = Ol_Mail.To
                    !UnRead = Ol_Mail.UnRead
                    !RecipientMail = Ol_Mail.Recipients.item(1).Address
                    !Attachments = strAttachment
                    !TypeMail = strTypeMail    'On ajoute le type du mail actuel (on peut facilement rajouter des types en recherchant dans les champs du mail une valeur donnée)
                    !NumContact = strNumContact    ' On récupère le numéro ou Id du contact actuel
 
                    .Update
                    If Not (err = 3022 Or err = 0) Then
                        Stop
                    End If
                    On Error GoTo 0
 
 
                End With
                strAttachment = ""
 
 
 
            End If
        Next boucle
    End If
 
Set rsMail = Nothing
Set Ol_Mail = Nothing
Set Ol_Attach = Nothing
End Sub
Function GetSMTPAddressForRecipient(recip As outlook.Recipient) As String
'Dim recip As Outlook.Recipient
    Dim pa As outlook.PropertyAccessor
    Const PR_SMTP_ADDRESS As String = _
          "http://schemas.microsoft.com/mapi/proptag/0x39FE001E"
    Set pa = recip.PropertyAccessor
    On Error Resume Next
    Debug.Print recip.Name & " SMTP=" _
              & pa.GetProperty(PR_SMTP_ADDRESS)
    GetSMTPAddressForRecipient = pa.GetProperty(PR_SMTP_ADDRESS)
    If GetSMTPAddressForRecipient = "" Then GetSMTPAddressForRecipient = recip.Address
End Function
 
Private Function Get_sender_exchange(OITEM As outlook.MailItem) As String
    Dim oEU As outlook.ExchangeUser
    On Error Resume Next
    Set oEU = OITEM.Sender.GetExchangeUser
 
    Get_sender_exchange = oEU.PrimarySmtpAddress
    If Get_sender_exchange = "" Then Get_sender_exchange = OITEM.SenderEmailAddress
End Function

**Oliv-** · 16/09/2015, 11h49

Envoyé par clickandgo

Merci Oliv, ça marche presque parfaitement, en fin d'importation j'ai maintenant un message "utilisation incorrecte de null" et rien ne s'importe

Si l'erreur se produit sur ".Update" c'est que essayes d'inserer dans un champ acces , une valeur NULL qui n'est pas acceptée.

1/Comment mettre en place une barre de progression qui s'affiche durant le temps d'importation ?

Tu trouveras des codes propres à access via

où là par exemple
http://arkham46.developpez.com/artic...rmattente/#LIV
http://www.gaudry.be/ast-rf-185.html

2/ Est il possible de signaler à l'utilisateur le nombre d'Items à importer ?

le nombre Importé OUI il faut ajouter un compteur à chaque envoi vers access
mais le nombre à importer tu ne le connais pas , il faudrait que tu passes une première fois pour connaitre le nombre et/ou marquer les mails à importer puis repasser pour les importer réellement dans access

**clickandgo** · 16/09/2015, 12h00

Merci beaucoup pour ta réponse Oliv

Le problème est que je n'avais pas de problème Null avant que l'on change le code pour l'adapter à Exchange.

1/ Comment gérer les valeurs null ? avec "isnull" ou un truc du genre [nom du champ] &"" ?
Je pense que ça serait trop simple ... Il faudrait d'abord que je sois informé de quel valeur est nulle pour la corriger ensuite, or çà, je ne sais pas faire dans le code ...

2/ Maintenant j'ai alternativement soit une erreur 91 "variable objet ou variable avec bloc WITH non définie" ou l'erreur Null suivant le dossier que je choisis d'importer

Ce pourrait il que l'erreur viennent du traitement des dossiers Outlook plutôt que de la phase d'insertion dans la table de réception ?

Merci de votre aide

**Oliv-** · 16/09/2015, 14h31

Consultes ce billet : http://www.developpez.net/forums/blo.../debogage-vba/
c'est le débogage qui va te permettre de solutionner tout cela.

Pour le point 1, dans access quand tu es en mode création sur ta table tu peux voir pour chaque champs, quelle est la valeur pour "Null interdit", tu peux effectivement dans ce cas essayer ta proposition.

**clickandgo** · 17/09/2015, 12h28

Merci Oliv pour ta réponse

J'avais déjà pensé à déboguer, sans résultat : aucun message d'erreur apparait
J'ai l'impression qu'une des fonctions annexes est la coupable, depuis que l'on a rajouté 'processfolder' la table ne se rempli plus, il y a un "on error ressume next" dedans ça me semble imprudent de le laisser non ?

D'autre part j'ai été obligé de passer "boucle" qui sert de compteur en variant car il ne l'accepte plus en tant que byte, as tu une idée de pourquoi ?

Merci

**Oliv-** · 17/09/2015, 13h01

Salut,

Code :

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

 boucle In Array("1", "2")

Parce que c'est du string

"on error resume next" peut avoir son utilité si c'est pas pour l'ensemble du code notamment en combinant avec "on error goto 0",

pour le débogage c'est mieux effectivement de commenter la ligne "on error resume next"

**clickandgo** · 17/09/2015, 14h21

Ahh, d'accord

En attendant j'ai toujours les 2 même erreurs 91 et 94 et l'importation ne se fait plus ...

Je ne sais plus quoi faire ...

**Oliv-** · 17/09/2015, 15h40

je t'ai corrigé plusieurs problèmes.

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
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
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
Option Compare Database
Dim rsMail As DAO.Recordset
Dim db As Database
Public Function ImportMailsOutlook()
 
 
 
    Dim Ol_App As New Outlook.Application
    Dim Ol_Mapi As Outlook.NameSpace
    Dim Ol_Folder As Outlook.MAPIFolder
 
 
 
 
    'debug 'On Error GoTo Description_Err
 
    ' Déclaration de l'objet sous-dossier
 
    Set rsMail = CurrentDb.OpenRecordset("Mails importés outlook")
    Set Ol_Mapi = Ol_App.GetNamespace("MAPI")
    Set Ol_Folder = Ol_Mapi.PickFolder    'On spécifie ici la fenêtre de sélection de dossiers Outlook
    Set db = CurrentDb
 
Debut:
 
    Call ProcessFolder(Ol_Folder, True)
 
    rsMail.Close
 
    MsgBox "Les données ont été importées"
 
Description_Err:
 
    MsgBox " Erreur " & Err.Number & Chr(10) & Err.Description
 
 
    'On libère la mémoire :
 
    Set rsMail = Nothing
    Set Ol_Folder = Nothing
    Set Ol_Mapi = Nothing
    Set Ol_App = Nothing
 
End Function
 
Sub ProcessFolder(StartFolder As Outlook.MAPIFolder, SubFolder As Boolean)
'---------------------------------------------------------------------------------------
' Procedure : ProcessFolder
' Author    : OCTU
' Date      : 16/06/2015
' Purpose   : Fonction recursive pour faire quelque chose dans le dossier et ses sous dossiers
'---------------------------------------------------------------------------------------
'
    Dim objFolder As Outlook.MAPIFolder
    Dim item As Object
    'Dim objItem As Object
    'On Error Resume Next
 
    ' process all the subfolders of this folder
    For Each objFolder In StartFolder.Folders
        Call ProcessFolder(objFolder, SubFolder)
    Next
 
    ' process all the items in this folder
    For Each item In StartFolder.Items
        Call Traitement_Mails(item)
    Next
 
    Set objFolder = Nothing
End Sub
Sub Traitement_Mails(Ol_Items)
 
    Dim Ol_Mail As Outlook.MailItem
 
    Dim boucle As Variant
    Dim strMail As String
    Dim strSQL As String
    Dim strNumContact    'suppression type oliv-
    Dim strTypeMail As String
    Dim blnMailTrouvé As Boolean
    Dim strAttachment As String
 
    Dim Ol_Attach As Outlook.Attachment
 
 
    If Ol_Items.Class = olMail Then
 
        Set Ol_Mail = Ol_Items
        For Each boucle In Array("1", "2")
            ' Initialisation des variables strMail et strSQL en fonction du numéro de boucle
            Select Case boucle
 
            Case "1"    ' Première Boucle
                If Ol_Mail.Recipients.Count > 0 Then    'ajout oliv-
                    strMail = GetSMTPAddressForRecipient(Ol_Mail.Recipients.item(1))    'Filtre pour éléments envoyés par adresse mail du contact
 
                    strSQL = "SELECT NumContact FROM Contacts" _
                           & " WHERE Mail1 = """ & strMail & """" _
                           & " OR Mail2 = """ & strMail & """" _
                           & " OR Mail3 = """ & strMail & """"
 
                    'Variable avec Dlookup pour recherche du numéro de contact correspondant à chaque mail importé :
                    strNumContact = DLookup("numcontact", "contacts", "mail1 = """ & strMail & """ Or Mail2 = """ & strMail & """ Or Mail3 = """ & strMail & """")
 
                    strTypeMail = "Envoyé"    'Cette variable permettra ensuite de distinguer le type du mail dans la table "Mails importés outlook"
 
                End If
 
            Case "2"    ' Deuxième Boucle
 
                strMail = Get_sender_exchange(Ol_Mail)    '.SenderEmailAddress 'Filtre pour éléments reçus par adresse mail du contact
 
                strSQL = "SELECT NumContact FROM Contacts" _
                       & " WHERE Mail1 = """ & strMail & """" _
                       & " OR Mail2 = """ & strMail & """" _
                       & " OR Mail3 = """ & strMail & """"
 
                'Variable avec Dlookup pour recherche du numéro de contact correspondant à chaque mail importé :
                strNumContact = DLookup("numcontact", "contacts", "mail1 = """ & strMail & """ Or Mail2 = """ & strMail & """ Or Mail3 = """ & strMail & """")
 
                strTypeMail = "Reçu"    'Cette variable permettra ensuite de distinguer le type du mail dans la table "Mails importés outlook"
 
 
 
            End Select
 
            If strSQL <> "" Then    'ajout oliv-
                Set db = CurrentDb    'ajout oliv-
                With db.OpenRecordset(strSQL)
                    blnMailTrouvé = (.EOF = False)
 
                End With
 
                If blnMailTrouvé Then    'Vérifie si il y a des données pour un enregistrement donné
 
                    For Each Ol_Attach In Ol_Mail.Attachments
                        strAttachment = strAttachment & Ol_Attach.DisplayName & vbCrLf
 
                    Next Ol_Attach
 
 
 
                    With rsMail    ' Remplissage de la table avec le résultat des filtres :
 
                        .AddNew
 
                        !Bcc = Ol_Mail.Bcc
                        !Categories = Ol_Mail.Categories
                        !Cc = Ol_Mail.Cc
                        !ConversationTopic = Ol_Mail.ConversationTopic
                        !CreationTime = Ol_Mail.CreationTime
                        !HTMLBody = Ol_Mail.HTMLBody
                        !LastModificationTime = Ol_Mail.LastModificationTime
                        !ReceivedByName = Ol_Mail.ReceivedByName
                        !ReceivedTime = Ol_Mail.ReceivedTime
                        !SenderName = Ol_Mail.SenderName
                        !Sent = Ol_Mail.Sent
                        !SentOn = Ol_Mail.SentOn
                        !SenderAddress = Get_sender_exchange(Ol_Mail)
                        !Size = Ol_Mail.Size
                        !Subject = Ol_Mail.Subject
                        !To = Ol_Mail.To
                        !UnRead = Ol_Mail.UnRead
                        !RecipientMail = GetSMTPAddressForRecipient(Ol_Mail.Recipients.item(1))
                        !Attachments = strAttachment
                        !TypeMail = strTypeMail    'On ajoute le type du mail actuel (on peut facilement rajouter des types en recherchant dans les champs du mail une valeur donnée)
                        !NumContact = strNumContact    ' On récupère le numéro ou Id du contact actuel
                        On Error Resume Next
                        .Update
                        If (Err = 3022 Or Err = 0) Then
                        Else
                        MsgBox Err & vbCr & Err.Description
                            Stop
                        End If
                        On Error GoTo 0
 
 
                    End With
                    strAttachment = ""
 
 
 
                End If
            End If
        Next boucle
    End If
 
 
    Set Ol_Mail = Nothing
    Set Ol_Attach = Nothing
End Sub
Function GetSMTPAddressForRecipient(recip As Outlook.Recipient) As String
'Dim recip As Outlook.Recipient
    Dim pa As Outlook.PropertyAccessor
    Const PR_SMTP_ADDRESS As String = _
          "http://schemas.microsoft.com/mapi/proptag/0x39FE001E"
    Set pa = recip.PropertyAccessor
    On Error Resume Next
    Debug.Print recip.Name & " SMTP=" _
              & pa.GetProperty(PR_SMTP_ADDRESS)
    GetSMTPAddressForRecipient = pa.GetProperty(PR_SMTP_ADDRESS)
    If GetSMTPAddressForRecipient = "" Then GetSMTPAddressForRecipient = recip.Address
End Function
 
Private Function Get_sender_exchange(OITEM As Outlook.MailItem) As String
    Dim oEU As Outlook.ExchangeUser
    On Error Resume Next
    Set oEU = OITEM.Sender.GetExchangeUser
 
    Get_sender_exchange = oEU.PrimarySmtpAddress
    If Get_sender_exchange = "" Then Get_sender_exchange = OITEM.SenderEmailAddress
End Function

Il te reste encore du boulot

Automation depuis Access ne fonctionne plus

VBA Outlook

Discussions similaires

Partager

Partager