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