Bonjour,

Depuis quelque temps cette fonction ne marche plus, je n'ai aucun message d'erreur, la boite de dialogue me dit données importées mais rien n'est importé à la fin. Au début de la fonction je peux choisir les dossiers Outlook à scanner et importer, comme avant ....

Cela vient t'il du fait que j'utilise exchange ?

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
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
Merci pour votre aide