Discussion :

[TonyNiort79]

Bonjour à tous

le programme "Comment enregistrer mes messages sur disque dur" sur la FAQ MS-Outlook fonctionne très bien,
je voudrais si c'est possible y inclure les sous-dossiers, mais bien entendu, je ne sais pas comment faire, merci à tous pour votre aide.

[Oliv-]

SAlut

Tu veux exporter tous les email sd'un dossier et ses sous dossiers en fichier .msg sur ton disque dur ?

il faut coupler cela
https://www.developpez.net/forums/bl...sous-dossiers/

avec cette une fonction plus récente

https://www.developpez.net/forums/bl...le-disque-msg/


tu peux aussi lire
https://www.developpez.net/forums/bl...ls-vers-excel/

[TonyNiort79]

Bonjour Oliv_

merci beaucoup,
je tente à faire des tests et j'ai un message d'erreur,
effectivement il ne trouve pas la procédure nommée ProcessThisItem
je connais un peu VBA Excel, mais très peu VBA Outlook

[Oliv-]

tu as oublié la seconde partie du code sur le premier lien

c'est dans cette partie que tu dois mettre la fonction
SavAs_mail_as_msg

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
 
 
 
Sub ProcessThisItem(objitem As Object)
'---------------------------------------------------------------------------------------
' Procedure : ProcessThisItem
' Author    : Oliv
' Date      : 12/02/2016
' Purpose   :
'---------------------------------------------------------------------------------------
'
    If objitem.Class = olMail Then
        Dim MyMail As Outlook.MailItem
        Set MyMail = objitem
 
       'ici le code
       call SavAs_mail_as_msg (objitem, "c:\temp\")
    End If
 
 
End Sub

[TonyNiort79]

Bonjour à tous,
Oliv-
je pensais avoir tout copié,

je viens de recopier la partie manquante, et lancé la macro,
le programme me demande de déclarer certaines variables ce que j'ai fait,

déjà sur la procédure Sub SavAs_mail_as_msg(MyMail As Outlook.MailItem, repertoire), j'ai créé

Code :

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

1
2
3
4
 Dim NomExport As String
 Dim PathNomExport As String
 Dim n As Integer
 Dim MemPath As String

puis sur la procédure Function waaps_creedir(lerep As String) As Boolean, j'ai créé

Code :

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

1
2
    Dim rep As String
    Dim REP_TOP As String

maintenant sur cette procédure il me demande un tableau car il bloque sur Ubound



je ne sais pas si toutes les déclarations sont bonnes
mais avec les tableaux je n'y connais rien

[TonyNiort79]

Bonjour Olivier,
je me suis aperçu qu'il y avait des procédures en doublons d'où les erreurs,
j'ai effacé toutes les anciennes procédures et je n'ai copié que celles indiquées dans tes liens (liste image ci-dessous)

il n'y a plus de message d'erreur,
une fenêtre me demande quel répertoire sélectionner,
aussitôt, un message m'indique "traitement terminé"
et il n'y a rien dans mon répertoire C:\mail (le répertoire existe bien)
je dois peut-être indiquer l'appel d'une procédure quelque part ?
merci beaucoup pour ton aide

[Oliv-]

Bonjour
y a t'il bien le \ à la fin du chemin ?

sinon regarde à la racine si tu as des fichiers mailquelquechose.msg

[TonyNiort79]

Bonjour Olivier,
oui il y a bien le \ à la fin du chemin
par contre j'ai fait une recherche et il n'y a pas d'appel à la procédure SavAs_mail_as_msg (call SavAs_mail_as_msg)

[Oliv-]

Salut,
Y a effectivement des trucs bizarres dans mon code , j'ai corrigé

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
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
Option Explicit
 
 
Sub Lance_Traitement()
'---------------------------------------------------------------------------------------
' Procedure : Lance_Traitement
' Author    : Oliv
' Date      : 12/02/2016
' Purpose   :
'---------------------------------------------------------------------------------------
'
    Dim OL As Outlook.Application
    Dim olNS As Outlook.NameSpace
    Dim olFolder As Outlook.Folder
 
    Set OL = Outlook.Application
    Set olNS = OL.GetNamespace("MAPI")
 
    'soit on connait le dossier
    'Set olFolder = olNS.GetDefaultFolder(olFolderInbox).folders
 
    'soit on le choisi
    Set olFolder = olNS.PickFolder
 
    Call ProcessFolders(olFolder, True)
    MsgBox "Traitement terminé"
End Sub
 
Sub ProcessFolders(StartFolder As Outlook.MAPIFolder, SubFolder As Boolean)
'---------------------------------------------------------------------------------------
' Procedure : ProcessFolder
' Author    : Oliv'
' Date      : 12/02/2016
' Purpose   : Traitement récursif sur les dossiers OUTLOOK
'---------------------------------------------------------------------------------------
'
    Dim objFolder As Outlook.MAPIFolder
    Dim objitem As Object
 
    'Dim objItem As Object
    On Error Resume Next
 
    ' do something specific with this folder
    Debug.Print StartFolder.FolderPath, StartFolder.Items.Count
    Debug.Print
    If StartFolder.DefaultItemType = olMailItem Then
        '  ICI LE TRAITEMENT POUR CHAQUE DOSSIER
        ' Call ProcessThisFolder(StartFolder)
    End If
 
    ' process all the items in this folder
    'ICI LE TRAITEMENT POUR TOUS LES ELEMENTS DU DOSSIER
 
    Dim i
    For i = StartFolder.Items.Count To 1 Step -1
        Set objitem = StartFolder.Items(i)
        Call ProcessThisItem(objitem)
    Next i
 
    ' process all the subfolders of this folder
    'on traite tous les sous dossiers
    If SubFolder Then
        For Each objFolder In StartFolder.Folders
            Call ProcessFolders(objFolder, SubFolder)
        Next
    End If
 
    Set objFolder = Nothing
End Sub
 
 
 
 
Sub ProcessThisItem(objitem As Object)
'---------------------------------------------------------------------------------------
' Procedure : ProcessThisItem
' Author    : Oliv
' Date      : 12/02/2016
' Purpose   :
'---------------------------------------------------------------------------------------
'
    If objitem.Class = olMail Then
        Dim MyMail As Outlook.MailItem
        Set MyMail = objitem
 
        'ici le code
        Call SavAs_mail_as_msg(objitem, "c:\temp\")
    End If
 
 
End Sub
 
 
Sub SavAs_mail_as_msg(MyMail As Outlook.MailItem, repertoire)
'---------------------------------------------------------------------------------------
' Procedure : SavAs_mail_as_msg
' Author    : Oliv
' Date      : 12/02/2016 modifié 01/07/2020
' Purpose   :
'---------------------------------------------------------------------------------------
'
' exemple repertoire = "c:\mail\"
    Dim NomExport As String
    Dim PathNomExport As String
    Dim n As Integer
    Dim MemPath As String
 
    'Ici on construit le nom du fichier qui sera créé
    'par exemple : DATE CREATION + EXPEDITEUR + SUJET
    Dim Expediteur
    Expediteur = Get_sender_SMTP(MyMail)
    NomExport = Format(MyMail.CreationTime, "yyyymmdd hh:nn") & "-" & Expediteur & "-" & MyMail.Subject
    NomExport = remplaceCaracteresInterdit(NomExport)
 
    'Ici on vérifie le répertoire où l'enregistrer
    If Right(repertoire, 1) <> "\" Then repertoire = repertoire & "\"
    Call waaps_creedir(CStr(repertoire))
 
 
    'On construit le chemin et le nom du fichier pour l'export
    PathNomExport = repertoire & Left(NomExport, 160) & ".msg"
 
    'Ici on vérifie que le fichier n'existe pas déjà sinon il serait écrasé
    n = 1
    MemPath = PathNomExport
    While Dir(PathNomExport) <> ""
        'MsgBox "Le fichier " & vbCr & PathNomExport & vbCr & "existe déjà", vbInformation
        PathNomExport = Left(MemPath, Len(MemPath) - 4) & "(" & n & ")" & ".msg"
        n = n + 1
 
    Wend
    MyMail.SaveAs PathNomExport, OlSaveAsType.olMSG
 
    ' pour changer la date du fichier (voir en bas)
    '    Call ModifDate(CStr(PathNomExport), MyMail.CreationTime, 4)
 
    'on peut aussi l'enregistrer dans d'autres formats
    'Type de fichier à enregistrer. Il peut s'agir d'une des constantes OlSaveAsType suivantes : olHTML, olMSG, olRTF, olTemplate, olDoc, olTXT, olVCal, olVCard, olICal ou olMSGUnicode.
 
End Sub
 
 
Function remplaceCaracteresInterdit(ByVal CheminStr As String)
    Dim objCurrentMessage As Outlook.MailItem
 
    Dim liste As Variant
    Dim L
    liste = Array("\", "/", ":", "*", "?", "<", ">", "|", """", vbTab, Chr(7))
    For L = 0 To UBound(liste)
        CheminStr = Replace(CheminStr, liste(L), "")
    Next L
    remplaceCaracteresInterdit = Trim(CheminStr)
    'MsgBox CheminStr
End Function
 
 
Function waaps_creedir(lerep As String) As Boolean
'----------------------------------------------------------------------
' FUNCTION :    waaps_creedir
'               Création d'un répertoire (récursif)
'----------------------------------------------------------------------
' Paramètres :
'   rep :       répertoire à créer par son chemin relatif % au root
'----------------------------------------------------------------------
'   retour :    True si le répertoire est créé
'----------------------------------------------------------------------
' Global utilisé : REP_TOP
'----------------------------------------------------------------------
' COPYRIGHTS : 1994-2005 CAXTON / WAAPS / BRUNO VILLACAMPA
'   Utilisation commerciale interdite
'   Utilisation personnelle / professionnelle autorisée
'   Le message courant doit être préservé
'----------------------------------------------------------------------
    Dim FSO As Object, i As Integer, retour As Boolean
    Dim rp As String, r
    Dim rep As Variant
    Dim REP_TOP As String
 
 
    Set FSO = CreateObject("Scripting.filesystemobject")
 
    rp = Replace(lerep, "\", "/")
    rp = Replace(rp, "//", "/")
    rep = Split(rp, "/")
    r = REP_TOP
    retour = True
    For i = 0 To UBound(rep)
        If (rep(i) <> "") Then
            r = r & rep(i) & "\"
            If (Not FSO.FolderExists(r)) Then
                FSO.CreateFolder (CStr(r))
                If (Not FSO.FolderExists(r)) Then retour = False
            End If
        End If
    Next
    Set FSO = Nothing
    waaps_creedir = retour
End Function
 
Private Function Get_sender_SMTP(Oitem As Outlook.MailItem) As String
    Dim oEU As Outlook.ExchangeUser
    On Error Resume Next
    Set oEU = Oitem.Sender.GetExchangeUser
 
    Get_sender_SMTP = oEU.PrimarySmtpAddress
 
    If Get_sender_SMTP = "" Then Get_sender_SMTP = GetFromFromHeader(Oitem)
 
 
    If Get_sender_SMTP = "" Then Get_sender_SMTP = Oitem.SenderEmailAddress
End Function
 
Function GetFromFromHeader(objMail As Outlook.MailItem) As String
'---------------------------------------------------------------------------------------
' Procedure : GetToFromHeader
' Author    : OLIV- from original code brettdj
' Date      : 04/06/2015
' Purpose   :
'---------------------------------------------------------------------------------------
'
    Dim objRegex As Object
    Dim objRegM As Object
    Dim MailHeader As String
    Dim ExtractText As String
    Dim i
    Const PR_TRANSPORT_MESSAGE_HEADERS = "http://schemas.microsoft.com/mapi/proptag/0x007D001F"
    MailHeader = objMail.PropertyAccessor.GetProperty(PR_TRANSPORT_MESSAGE_HEADERS)
 
    Set objRegex = CreateObject("vbscript.regexp")
    With objRegex
        .ignorecase = True
        .Pattern = "(\n)From:.*<(.+)>"
        If .test(MailHeader) Then
            Set objRegM = .Execute(MailHeader)
            For i = 0 To objRegM(0).submatches.Count - 1
                If InStr(1, objRegM(0).submatches(i), "@", vbTextCompare) Then
                    GetFromFromHeader = objRegM(0).submatches(i)
                    Exit For
                End If
            Next i
        Else
            GetFromFromHeader = ""
        End If
    End With
End Function

[TonyNiort79]

Bonjour Olivier,
Cela fonctionne très bien,
je n'ai plus besoin de sélectionner tous les mails, sous-dossiers par sous-dossiers
le gain de temps est impressionnant,
de plus, je ne risque pas de passer à coté d'un sous-dossier, ni de manquer un mail lors de la selection
merci beaucoup





je voulais savoir encore une chose,
serait-il possible de créer aussi les sous-dossier ?

[Oliv-]

Salut

effectivement on peut reproduire l'arborescence.

Dans le code déclencheur

Code :

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

Call SavAs_mail_as_msg(objitem, "c:\temp\",true)

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
Sub SavAs_mail_as_msg(mymail As Outlook.MailItem, repertoire, Optional withArbo As Boolean)
'---------------------------------------------------------------------------------------
' Procedure : SavAs_mail_as_msg
' Author    : Oliv
' Date      : 12/02/2016 modifié 03/07/2020
' Purpose   :
'---------------------------------------------------------------------------------------
'
' exemple repertoire = "c:\mail\"
    Dim NomExport As String
    Dim PathNomExport As String
    Dim n As Integer
    Dim MemPath As String
 
    'Ici on construit le nom du fichier qui sera créé
    'par exemple : DATE CREATION + EXPEDITEUR + SUJET
    Dim Expediteur
    Expediteur = Get_sender_SMTP(mymail)
    NomExport = Format(mymail.CreationTime, "yyyymmdd hh:nn") & "-" & Expediteur & "-" & mymail.Subject
    NomExport = remplaceCaracteresInterdit(NomExport)
 
    'Ici on vérifie le répertoire où l'enregistrer
    If Right(repertoire, 1) <> "\" Then repertoire = repertoire & "\"
 
    If withArbo Then
        Dim arbo As String
        Dim ofolder As Outlook.Folder
 
        Set ofolder = mymail.Parent
        arbo = ofolder.FolderPath
        'soit on supprime le nom de la boite
        repertoire = repertoire & Replace(arbo, "\\" & ofolder.Store.displayName & "\", "", , , vbTextCompare) & "\"
        'soit on le laisse
        'repertoire = repertoire & Replace(arbo, "\\", "") & "\"
 
    End If
 
    Call waaps_creedir(CStr(repertoire))
 
 
    'On construit le chemin et le nom du fichier pour l'export
    PathNomExport = repertoire & Left(NomExport, 160) & ".msg"
 
    'Ici on vérifie que le fichier n'existe pas déjà sinon il serait écrasé
    n = 1
    MemPath = PathNomExport
    While DIR(PathNomExport) <> ""
        'MsgBox "Le fichier " & vbCr & PathNomExport & vbCr & "existe déjà", vbInformation
        PathNomExport = Left(MemPath, Len(MemPath) - 4) & "(" & n & ")" & ".msg"
        n = n + 1
 
    Wend
    mymail.SaveAs PathNomExport, OlSaveAsType.olMSG
 
    ' pour changer la date du fichier (voir en bas)
    '    Call ModifDate(CStr(PathNomExport), MyMail.CreationTime, 4)
 
    'on peut aussi l'enregistrer dans d'autres formats
    'Type de fichier à enregistrer. Il peut s'agir d'une des constantes OlSaveAsType suivantes : olHTML, olMSG, olRTF, olTemplate, olDoc, olTXT, olVCal, olVCard, olICal ou olMSGUnicode.
 
End Sub

[TonyNiort79]

Bonjour Olivier,
Super,
j'avais un projet contenant 38 répertoires dont quelques-uns en avaient aussi avec un total de 380 mails
j'ai réussi à créer un historique d'un projet très rapidement, tout en respectant ma structure
je pourrai aussi créer un historique à chaque fin de projet, il suffira que je monte bien ma structure pour l'arborescence
chose que je ferai au fur et à mesure de chaque projet

tu fait partie des élites
un très grand merci