Automatiser le transfert d'un mail

**curt** · 25/08/2017, 17h00

Bonjour à tous,

au préalable, ceci est ma première contribution alors soyez tolérant svp - Elle répond à la demande du forum Excel https://www.developpez.net/forums/d1...xcel-cvtheque/
Ensuite, je me suis largement inspiré (et réutilisé) des bouts de procédures créés par d'autres personnes sur de nombreux sites - Qu'ils en soient ici remerciés.

Que réalise cette contribution :

A chaque lancement d'Outlook, les mails non-lus sont recopiés dans un dossier dont le nom est la date et l'heure de réception. On y retrouve :
- Le mail au format .msg
- Le mail au format .txt
- Les pièces jointes

Le mail n'est pas traité dans Outlook et reste dans son état de non-lu (sauf si on valide 3 lignes dans le code).
Le code est suffisamment commenté - mais n'hésitez pas à me rapporter tous bugs, critiques, commentaires et, qui sait, des "petits pouces en l'air !!!"

Le Code à intégrer dans Outlook est le suivant :

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
'Références à activer :
'Microsoft ActiveX Data Objects 6.1 Library
'------------------------------------------
Option Explicit
 
Const olFolderInbox As Integer = 6
'~~> DOSSIER DE DESTINATION
Const AttachmentPath As String = "R:\Downloads\Outlook\"
 
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
 
    OutlookVersExcel
 
End Sub
 
Private Sub Application_Startup()
 
    OutlookVersExcel
 
End Sub
 
Sub OutlookVersExcel()
 
On Error GoTo Erreur
 
Dim oOlAp As Object, oOlns As Object, oOlInb As Object
Dim oOlItm As Object, oOlAtch As Object
 
'~~> Nouveau fichier qui sera créé à partir du amil (Fichier .txt)
Dim NewFileName As String
Dim Mail As String, jour As String
 
'~~> Variables Outlook pour les Emails
Dim eSender As String       'email de l'expéditeur
Dim dtRecvd As Variant      'Date de réception
Dim dtSent As Variant       'Date d'envoi
Dim eSenderName As String   'Nom de l'expéditeur
Dim EntryID As String       'ID de l'email
Dim sSubj As String         'Objet de l'email
Dim sMsg As String          'Message
Dim sEmail As String        'Nom du fichier .msg qui sera créé et sauvegardé
Dim NewFolder As Variant    'Dossier créé pour stocker le mail en arrivée
 
'~~> Variables pour la connexione et le transfert vers Excel
Dim Source As ADODB.Connection
Dim Rst As ADODB.Recordset
Dim ADOCommand As ADODB.Command
Dim FichierExcel As String, FeuilleExcel As String
Dim SQLStr As String    'Requête pour insérer les données Outlook dans la feuille Excel
Dim LastRow As Integer  'Dernière ligne de la feuille Excel
Dim PJ As String        'Présence de pièce(s) jointe(s) dans l'email
 
Dim Fld As ADODB.Field
 
    FichierExcel = AttachmentPath & "Outlook.xlsm"  'Classeur Excel dans lequel on va lister les emails
    FeuilleExcel = "Feuil1" 'Nom de la feuille Excel du classeur décrit ci-dessus
 
    '~~> Connexion au classeur Excel
    Set Source = New ADODB.Connection
    With Source
        .Provider = "Microsoft.Jet.OLEDB.4.0"
        .ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" _
            & FichierExcel & ";Extended Properties=""Excel 12.0;HDR=NO;"""   'HDR=YES > Première ligne Entête
        .Open
 
        'Recherche de la dernière ligne de la feuille Excel
        SQLStr = "SELECT * FROM [Feuil1$];"
        Set Rst = New ADODB.Recordset
        Rst.Open SQLStr, Source, adOpenKeyset, adLockOptimistic
        Rst.MoveLast
        LastRow = Rst.RecordCount + 1 'DERNIERE LIGNE +1 PUISQUE EN-TÊTE dans la feuille Excel
    End With
 
    '~~> Déclaration de l'instance Outlook
    Set oOlAp = GetObject(, "Outlook.application")
    Set oOlns = oOlAp.GetNamespace("MAPI")
    Set oOlInb = oOlns.GetDefaultFolder(olFolderInbox)
 
    '~~> Chargement des informations de l'email dans les variables
    For Each oOlItm In oOlInb.Items.Restrict("[UnRead] = True")
        eSender = oOlItm.SenderEmailAddress
        dtRecvd = "#" & Format(oOlItm.ReceivedTime, "yyyy/MM/dd") & "#"
        dtSent = Format(oOlItm.CreationTime, "yyyy/MM/dd hh:mm")
        NewFolder = Replace(dtSent, "/", " ")       '/ INTERDIT SOUS PEINE D'ERREUR
        NewFolder = Replace(NewFolder, ":", "-")    ': INTERDIT SOUS PEINE D'ERREUR
        sSubj = Replace(oOlItm.Subject, "'", " ")   '" INTERDIT SOUS PEINE D'ERREUR
        sMsg = oOlItm.Body
        eSenderName = oOlItm.SenderName
        EntryID = oOlItm.EntryID
 
    '~~> Vérification de la présence de pièce(s) jointe(s) dans l'email
        PJ = ""
        If oOlItm.Attachments.Count <> 0 Then PJ = "X"
        If Dir(AttachmentPath & NewFolder, vbDirectory) <> "" Then GoTo NextIteration 'Le dossier existe => Mail suivant
 
    '~~> Transfert des données Outlook vers Excel
        'Création de la requête
        Set ADOCommand = New ADODB.Command
 
        SQLStr = "INSERT INTO [" & FeuilleExcel & "$] " _
            & "VALUES (" & dtRecvd & ", " & _
            "'" & eSenderName & "', " & _
            "'" & eSender & "', " & _
            "#" & dtSent & "#, " & _
            "'" & sSubj & "', " & _
            "'" & PJ & "', " & _
            "'" & "=LIEN_HYPERTEXTE(" & Chr(34) & AttachmentPath & NewFolder & Chr(34) & ")" & "'" & ")"
 
'------------------------------------------------------------
'    Set Cn = New ADODB.Connection
'    Cn.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
        "Data Source=" & Fichier & ";" & _
        "Extended Properties=""Excel 8.0;HDR=No;"";"
 
'    Set Cd = New ADODB.Command
'    Cd.ActiveConnection = Cn
'    Cd.CommandText = "SELECT * FROM [Feuil1$G30:G30]"
 
'    Set Rst = New ADODB.Recordset
'    Rst.Open Cd, , adOpenKeyset, adLockOptimistic
'    Rst(0).Value = "Donnée test"
'    Rst.Update
'------------------------------------------------------------
 
        'Exécution de la requête
        Source.Execute SQLStr
 
    'Transfert du contenu de l'email dans le dossier nommé avec NewFolder
        MkDir (AttachmentPath & NewFolder)  'Création du dossier NewFolder
 
    '~~> Extraction des pièces jointes du mail
        '~~> Existe-t'il des pièces jointes dans l'email
        If oOlItm.Attachments.Count <> 0 Then
            For Each oOlAtch In oOlItm.Attachments
                '~~> On les télécharge dans le dossier
                oOlAtch.SaveAsFile AttachmentPath & NewFolder & "\" & oOlAtch.FileName
            Next
        End If
 
    '~~> Sauvegarde de l'email au format .msg (pratique pour le réouvrir dans son format d'origine dans Outlook)
        sEmail = AttachmentPath & NewFolder & "\" & "Email.msg"
        oOlItm.SaveAs sEmail, 3
 
    '~~> Sauvegarde du contenu de l'email dans un fichier .txt
        Mail = "Expéditeur : " & eSender & vbCrLf & vbCrLf
        Mail = Mail & "Date de réception : " & dtRecvd & vbCrLf
        Mail = Mail & "Date d'envoi : " & dtSent & vbCrLf & vbCrLf
        Mail = Mail & "Objet : " & sSubj & vbCrLf & vbCrLf
        Mail = Mail & "Message : " & sMsg & vbCrLf
 
        jour = Year(Now) & "-" & Month(Now) & "-" & Day(Now) & " - " & Hour(Now) & "-" & Minute(Now)
        NewFileName = " Email.txt"
        Open AttachmentPath & NewFolder & "\" & jour & NewFileName For Output As #1
        Print #1, Mail
        Close
        'Syntaxe pour ouvrir le fichier .txt (Pense-bête pour plus tard)
        'Shell "C:\WINDOWS\notepad.exe " & AttachmentPath & jour & NewFileName
 
    '~~> Marquer le mail en court de traitement (NON-LU) en LU
        'Dans ce cas, il faudra valider les trois lignes ci-dessous.
        'REMARQUE : Fonction peu pratique si on veut conserver l'état des emails lus et/ou non-lus
 
        'oOlItm.UnRead = False
        'DoEvents
        'oOlItm.Save
 
NextIteration:
    Next
 
Exit_Erreur:
    Rst.Close
    Source.Close
    Set Source = Nothing
    Set Rst = Nothing
    Set ADOCommand = Nothing
    Exit Sub
 
Erreur:
    MsgBox "Erreur n°" & Err.Number & " - " & Err.Description, vbCritical, "Erreur de procédure !"
    Resume Exit_Erreur
 
End Sub

Pensez à mettre votre classeur Excel (nommé "Outlook.xlsm" dans un dossier de destination (il est en pièce jointe)
J'ai pris :

Code :

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

"R:\Downloads\Outlook\"

En prime, le dossier se retrouve en lien hypertexte dans Excel, ce qui permet d'avoir un sommaire des mails reçus, le lien pour y accéder et le traitement d'Excel (filtre, tri, etc) pour s'y retrouver.
A bientôt.
PS:

au premier pouce en l'air - ça fait plaisir

**riri2938** · 30/08/2018, 11h05

Bonjour, et félicitations pour votre contribution
Juste une question quant au code à intégrer sous Outlook, pouvez-vous préciser dans quel module il doit être inséré ?
Merci de votre retour
Eric

**curt** · 17/09/2018, 18h05

Bonjour Eric,

merci pour le message.
Le code est à mettre dans l'éditeur VBA (Alt F11) dans le module "ThisOutlookSession"

N'hésite pas à revenir si y a un problème.

Curt

Automatiser le transfert d'un mail

Contribuez

Discussions similaires

Partager

Partager