Automation depuis Access ne fonctionne plus

**clickandgo** · 08/01/2015, 14h30

Bonjour à tous,

Depuis que je suis passé à la version exchange d'outlook, le code inclus dans le message de discussion suivant http://www.developpez.net/forums/d14...ion-ne-marche/ ne marche plus au moment du remplissage de la table de destination, par contre les étapes préalables comme la présentation du Dialogbox de choix de dossier source lui fonctionne ...

Que faudrait il modifier à ce code selon vous ?

Merci d'avance pour vos réponses

**Oliv-** · 08/01/2015, 16h34

bjr,
il faut exécuter ce code en mode pas à pas et voir à partir de où cela ne marche plus

**clickandgo** · 09/01/2015, 01h44

Bonjour , j'ai rajouté un contrôle d'erreur qui indique une "incompatibilité de type", cependant je ne vois pas ce qui cloche ...

Cette erreur aparait seulement depuis que je suis passé sur Exchange, faut il rajouter des lignes concernant la compatibilité ?

**Oliv-** · 09/01/2015, 07h21

Copie ici le code qui bloque

**clickandgo** · 09/01/2015, 16h54

Si tôt dit si tôt fait :

Il m'indique de temps en temps qu'un champ est trop petit pour accueillir l'information mais n'indique pas quel champ, comment vérifier le champ qui bloque ?

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
 
Public Function ImportMailsOutlook()
 
    On Error Resume Next
 
 
    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 = Ol_Items.Recipients.item(1).Address '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 = 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"
 
                     Debug.Print strNumContact
 
        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ésultats 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
               !ReceivedOnBehalfOfName = Ol_Items.ReceivedOnBehalfOfName
               !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
 
            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"
 
    '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

**Oliv-** · 09/01/2015, 18h34

MDR ,

ya presque 12H entre les 2 messages !

En plus le code "complet" je l'avais vu sur l'autre post.

le mode pas à pas ca veut dire que tu lances la macro dans VBE avec f8 et que tu fais F8 sur chaque arrêt. (ca peut faire beacucoup de F8 avec des boucles si l'anomalie n'est pas systématique.

Maintenant il y a des cas où on ne voit pas où c'était pas bon.
il faut par exemple utiliser

Code :

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

debug.print Ol_Items.BCC

pour voir les valeurs dans la fenêtre exécution.
ou alors tu modifies ton 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
With rsMail ' Remplissage de la table avec le résultats 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
               !ReceivedOnBehalfOfName = Ol_Items.ReceivedOnBehalfOfName
               !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
 
            End With

par un truc 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
With oCommand
        .ActiveConnection = oConnection
        .CommandType = adCmdStoredProc
        .CommandTimeout = 60
        .CommandText = "ps_EDI_parc_GO_chgt_immat_by_immat"
        .Parameters.Refresh
        .NamedParameters = True
        On Error GoTo erreurs
        Dim errOu As String
        errOu = "immat"
        .Parameters("@old_immat") = Intersect(truc.EntireRow, Col_Immat).Value
        errOu = "Centre"
        .Parameters("@new_centre") = Intersect(truc.EntireRow, Col_Centre)
        errOu = "Entree"
        .Parameters("@dateEntree") = Intersect(truc.EntireRow, Col_Entree)
        '        errOu = "NumParcid"
        '        .Parameters("@col_NumPArcId") = Intersect(truc.EntireRow, Col_NumParcID)
        errOu = "newImmat"
        .Parameters("@new_immat") = Intersect(truc.EntireRow, Col_NewImmat)
        errOu = "Contrat"
        .Parameters("@Contrat") = Intersect(truc.EntireRow, Col_Contrat)
        errOu = "Cie"
        .Parameters("@cie_id") = Intersect(truc.EntireRow, Col_Cie_id)
 
    End With
 
    Set rst = oCommand.Execute(Affected)

errOu permet de voir où est l'erreur.

ou alors tu tronques tes enregistrements

Code :

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

    !BCC = left(Ol_Items.BCC,X)

où X est la longueur du champs !BCC dans access.

**Oliv-** · 09/01/2015, 18h44

regarde ici
http://warin.developpez.com/access/d...e=partie_4#4.4
en particulier La propriété FieldSize qui te permettra de trouver le X automatiquement.

et tu peux mettre un test (j'ai pas vérifié si cela fonctionne)

Code :

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

if len(Ol_Items.BCC)>rsMail.Fields("BCC").FieldSize then stop

**clickandgo** · 09/01/2015, 19h53

Merci pour ta réponse Oliv

J'ai recopié la fonction, enlevé les boucles pour la simplifier, et j'ai toujours l'erreur 13 sans qu'aucune ligne de code ne soit pointée.
J'ai effacé tous les champs de remplissage de la table et n'en ai laissé qu'un : la même erreur survient, on dirait que celle-ci n'a pas de rapport avec le remplissage de la table mais plutôt avec le code juste avant.

On dirait comme si il n'arrivait pas à lire le dossier Exchange Outlook ...

Si je choisis le dossier d'un autre compte mail non Exchange une autre erreur apparaît : " utilisation incorrecte de null " mais plus l'erreur d'incompatibilité.

Ce problème est apparu que depuis que j'ai Outlook 2013 + Exchange
Tout marchait parfaitement sous Outlook 2010, ce qui me fait croire qu'il faut modifier peut être les options d'automation quant aux références aux dossiers Outlook ?

J'y suis depuis des heures ... je trouve pas

Help !

**Oliv-** · 09/01/2015, 20h25

T as copié quoi au juste ?
Prends l habitude de copier ici ton code modifié on n est pas derrière ton pc

**clickandgo** · 09/01/2015, 23h17

J'ai simplement retiré les filtres et tous les champs récepteurs des données venant d' Outlook, le résultat étant le même j'en déduis qu'ils n'étaient pas en cause et continue à croire que c'est la méthode d'ouverture et scan des dossiers d'outlook-Exchange qui ne doit plus être la même dans cette version 2013 ...

**Oliv-** · 09/01/2015, 23h56

Peux tu publier le xml qui correspond à ta table access "Mails importés outlook":
tu cliques bouton droit sur le nom de la table dans l'explorateur et tu fais exporter /XML/ en décochant DONNEES surtout

**clickandgo** · 10/01/2015, 00h10

Voici :Mails Importés Outlook.xsd

**Oliv-** · 10/01/2015, 13h04

bonjour,
merci la même chose pour "contacts" stp

**clickandgo** · 10/01/2015, 13h17

C'est moi qui te remercie

Contacts.xsd

**Oliv-** · 10/01/2015, 15h28

Peux tu me resumer l'utilité de cette macro ? Si j'ai bien compris cela repertorie les Emails UNIQUEMENT pour les exp ou dest faisant partie de contacts?

Comme vous un serveur exchange maintenant les membres de ta sté ont des adresses gu genre
RecipientMail
/o=ExchangeLabs/ou=Exchange Administrative Group (FYDIBOHF23SPDLT)/cn=Recipients/cn=cfeadd194d0e41b5ab

pour avoir l'adresse smtp tu utilises la fonction GetSMTPAddressForRecipient, il y a encore plusieurs endroits où corriger

par exemple sur !SenderAddress = Ol_Items.SenderEmailAddress champ pas assez long.

Tu dois déjà dans tes 2 tables modifier la taille des champs texte en les passant à 255
et en passant Attachments en mémo

voici le code modifié qui me permet de tester (mais il reste du boulot ...)
déjà il faut enlever le ON ERROR RESUME NEXT qui masque les erreurs sans stopper dessus.

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
Option Compare Database

Public Ol_App As New Outlook.Application
Public Function ImportMailsOutlook()

'On Error Resume Next


    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_Item
    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_Item In Ol_Folder.Items
        strMail = ""
        strSQL = ""
        blnMailTrouvé = False
        If Ol_Item.Class = olMail Then
            Set Ol_Items = Ol_Item

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

            Case "1"    ' Première Boucle
                If Ol_Items.Recipients.Count > 0 Then
                    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 & """"

                    On Error Resume Next
                    '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 & """")
                    On Error GoTo 0
                    strTypeMail = "Envoyé"    'Cette variable permettra ensuite de distinguer le type du mail dans la table "Mails importés outlook"
                End If
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é :
                On Error Resume Next
                strNumContact = DLookup("numcontact", "contacts", "mail1 = """ & strMail & """ Or Mail2 = """ & strMail & """ Or Mail3 = """ & strMail & """")
                On Error GoTo 0
                strTypeMail = "Reçu"    'Cette variable permettra ensuite de distinguer le type du mail dans la table "Mails importés outlook"

Debug.Print strNumContact

            End Select
            If strSQL <> "" Then
            With db.OpenRecordset(strSQL)
                blnMailTrouvé = (.EOF = False)

            End With
            End If
            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ésultats 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
                    !ReceivedOnBehalfOfName = Ol_Items.ReceivedOnBehalfOfName
                    !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
                    On Error Resume Next
                    .Update
                    If Not (Err = 3022 Or Err = 0) Then
Stop
                    End If
                    On Error GoTo 0
                End With
                strAttachment = ""



            End If
        End If
    Next Ol_Item

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

    '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

**clickandgo** · 10/01/2015, 16h17

Bonjour Oliv

Merci pour tout ce travail...
J'ai commencé à changer certaines tailles de champs comme préconisé mais je reçois après chaque changement "enregistrement trop long", j'ai pensé à compacter la base et ça accepte de changer la taille de certains champs, d'autres ne se laissent pas faire.

Concernant l'utilisation de cette fonction, effectivement elle ne rapatriera que suivant les adresses mails déjà enregistrée dans la base contacts ce qui permet de filtrer...

Je vais continuer à essayer de résoudre par rapport à tes changements, je sens que ça va bientôt marcher , mais cela sera t'il compatible encore si je décidais d'abandonner Exchange ou de la rendre disponible pour d'autres utilisateurs ?

Je te souhaite un bon week-end et te tiens au courant (je travaille épisodiquement ...)

Merci pour ta dévotion

**clickandgo** · 10/01/2015, 16h36

Je viens de terminer l'arrangement du code avec tes modifications et j'ai viré "OnBehalfOf Name" auquel je ne vois pas d'utilité, tous les champs sont maintenant en 255 + attachments en texte long , l'erreur d'incompatibilité sort toujours !!!, ai-je oublié quelque chose ?

Mystère !

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

**Oliv-** · 10/01/2015, 16h49

j'ai eu des erreurs sur .cc et .to sur des emails qui dépassaient 255 caractères, soit tu les mets en texte long soit tu tronques les données avec left()