Déplacer des mails d'Outlook vers un répertoire dans windows selon des critères

**Oliv-** · 22/02/2016, 12h52

SAlut,
Essaye 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
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
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
Public Bckup As Outlook.Folder

Sub test_this()
    Dim objitem As Object
    Set objitem = ActiveInspector.CurrentItem
    
    Set BTR = objitem.Application.Session.GetDefaultFolder(olFolderInbox)
    Set Bckup = BTR.folders("Test")
    
    ProcessThisItem objitem
    
    
End Sub

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
    Dim objfolder As Outlook.MAPIFolder


    Set OL = Outlook.Application
    Set olNS = OL.GetNamespace("MAPI")

    'soit on le choisi
    '  Set olFolder = olNS.PickFolder


    'Pour les dossiers EMBARGO

    Set olFolder = olNS.folders("EMBARGO Securite-Financiere")
    '    Set objfolder = objfolder.Store.GetDefaultFolder(olFolderInbox)
    Set objfolder = olFolder.folders("EMBARGO")
    Call ProcessFolders(objfolder, True)

    Set BTR = olFolder.folders("Boîte de réception")
    Set Bckup = BTR.folders("Bckup Macro")

    'Pour les dossiers CACIB

    Set olFolder = olNS.folders("EMBARGOCACIB Ddc")
    Call ProcFolders(olFolder, True)

    Set BTR = olFolder.folders("Boîte de réception")
    Set Bckup = BTR.folders("Bckup Macro")

    'Pour les dossiers LCL

    Set olFolder = olNS.folders("EMBARGOLCL Ddc")
    Call ProcFolders(olFolder, True)

    Set BTR = olFolder.folders("Boîte de réception")
    Set Bckup = BTR.folders("Bckup Macro")


    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.Count
    Debug.Print
    For Each objfolder In StartFolder.folders
        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
        Dim j
        i = objfolder.Items.Count
        If i <> 0 Then
            For j = 1 To i
                Set objitem = objfolder.Items(j)
                Call ProcessThisItem(objitem)
            Next j
        End If
    Next
    ' process all the subfolders of this folder
    'on traite tous les sous dossiers
    If SubFolder Then
        Call ProcessFolders(objfolder, SubFolder)
    End If



    Set objfolder = Nothing
End Sub



Sub ProcessThisItem(objitem As Object)
'---------------------------------------------------------------------------------------
' Procedure : ProcessThisItem
' Author    : Oliv
' Date      : 12/02/2016
' Purpose   :
'---------------------------------------------------------------------------------------
    Dim Nomdossier
    Dim OL As Outlook.Application
    Dim olNS As Outlook.NameSpace
    Dim olFolder As Outlook.Folder
    Dim BTR As Outlook.MAPIFolder
    
    Dim FolderToMove As Outlook.Folder
    Dim oMail As Outlook.MailItem

    '
    If objitem.Class = olMail Then
        Dim mymail As Outlook.MailItem
        Set mymail = objitem
        Nomdossier = mymail.Parent.Name

        If InStr(1, mymail.Body, "libéré", vbTextCompare) Or InStr(1, mymail.Body, "annulé", vbTextCompare) Or InStr(1, mymail.Body, "libération", vbTextCompare) Or InStr(1, mymail.Body, "released", vbTextCompare) Or InStr(1, mymail.Body, "annulation", vbTextCompare) Then
            If mymail.CreationTime < DateAdd("d", -60, Date) Then
                Call SaveandMoveConversation(mymail, Bckup, "O:\Projets01\DDC-CC\EMBARGO\" & Nomdossier & "\2016")

                '            Set OL = Outlook.Application
                '            Set olNS = OL.GetNamespace("MAPI")
                '            Set olFolder = olNS.Folders("EMBARGO Securite-Financiere")
                '            Set BTR = olFolder.Folders("Boîte de réception")
                '            Set Bckup = BTR.Folders("Bckup Macro")

                '            Call MoveConversation(mymail, Bckup)
                '            mymail.Move Bckup

            End If
        End If
    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
' Purpose   :
'---------------------------------------------------------------------------------------
'
' exemple repertoire = "c:\mail\"
    Dim NomExport
    Dim PathNomExport
    Dim n
    Dim MemPath

    'Ici on construit le nom du fichier qui sera créé
    NomExport = mymail.subject
    ' & mymail.CreationTime

    'Ici on vérifie le répertoire où l'enregistrer
    If Right(repertoire, 1) <> "\" Then repertoire = repertoire & "\"
    
    'on vérifie s'il existe sinon on le crée
    Module10.waaps_creedir (repertoire)

    'Ici on supprime les caractères non autorisé dans les noms de fichiers
    PathNomExport = repertoire & Left(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace( _
                                                                                                                              NomExport, "\", ""), "/", ""), ":", ""), "*", ""), "?", ""), "<", ""), ">", ""), "|", ""), ".", ""), """", ""), vbTab, ""), Chr(7), ""), 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
    Call ModifDate(CStr(PathNomExport), mymail.CreationTime, 4)
    Call refresh_explorer(PathNomExport)

End Sub

Sub ProcFolders(StartFolder As Outlook.MAPIFolder, SubFolder As Boolean)
'---------------------------------------------------------------------------------------
' Procedure : ProcFolder
' 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.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
    Dim j
    i = StartFolder.Items.Count
    If i <> 0 Then
        For j = 1 To i
            Set objitem = StartFolder.Items(j)
            Call ProcessThisItem(objitem)
        Next j
    End If
    ' process all the subfolders of this folder
    'on traite tous les sous dossiers
    If olMailItem <> 0 Then
        Call ProcFolders(objfolder, SubFolder)
    End If
    '   Set objfolder = Nothing
End Sub

Private Sub Test_Conversation()

    Dim FolderToMove As Outlook.Folder
    Dim oMail As Outlook.MailItem
    ' Obtain the current item for the active inspector.
    Set oMail = Application.ActiveInspector.CurrentItem

    Set FolderToMove = Application.Session.PickFolder

    Call MoveConversation(oMail, FolderToMove)
End Sub


Sub SaveandMoveConversation(oMail As Outlook.MailItem, FolderToMove As Outlook.Folder, repertoire)
'---------------------------------------------------------------------------------------
' Procedure : MoveConversation
' Author    : Oliv
' Date      : 18/02/2016
' Purpose   : Pour déplacer une conversation
'---------------------------------------------------------------------------------------
'
    Dim oConv As Outlook.Conversation
    Dim oTable As Outlook.Table
    Dim oRow As Outlook.Row
    Dim mymail As Outlook.MailItem
    Dim oItem As Outlook.MailItem

    Const PR_STORE_ENTRYID As String = _
          "http://schemas.microsoft.com/mapi/proptag/0x0FFB0102"

    On Error Resume Next

    If Not (oMail Is Nothing) Then
        ' Obtain the Conversation object.
        Set oConv = oMail.GetConversation
        If Not (oConv Is Nothing) Then
            Set oTable = oConv.GetTable
            oTable.Columns.add (PR_STORE_ENTRYID)
            Debug.Print oTable.GetRowCount
            Do Until oTable.EndOfTable
                Set oRow = oTable.GetNextRow
                ' Use EntryID and StoreID to open the item.
                Set oItem = Application.Session.GetItemFromID( _
                            oRow("EntryID"), _
                            oRow.BinaryToString(PR_STORE_ENTRYID))
                Call SavAs_mail_as_msg(oItem, repertoire)
                oItem.Move FolderToMove
            Loop
        End If
    End If
End Sub

avec cette fonction qui permet de créer le dossier windows s'il n'existe pas

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
 
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 FileSystemObject, i As Integer, retour As Boolean
    Dim rp As String, r
 
    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

**clambsf** · 23/02/2016, 10h07

Salut,

Cela n'a rien changé, Do Until oTable.EndOfTable renvoie toujours la valeurs vrai et du coup saute Call SavAs_mail_as_msg(oItem, repertoire)

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
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
Option Explicit

Public Bckup As Outlook.Folder

Sub test_this()
    Dim objitem As Object
    Set objitem = ActiveInspector.CurrentItem
    
    Set BTR = objitem.Application.Session.GetDefaultFolder(olFolderInbox)
    Set Bckup = BTR.Folders("Test")
    
    ProcessThisItem objitem
    
    
End Sub

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
    Dim objfolder As Outlook.MAPIFolder
    Dim BTR As Outlook.MAPIFolder
    Dim Bckup As Outlook.MAPIFolder

    Set OL = Outlook.Application
    Set olNS = OL.GetNamespace("MAPI")

    'soit on le choisi
    '  Set olFolder = olNS.PickFolder


    'Pour les dossiers EMBARGO

    Set olFolder = olNS.Folders("EMBARGO Securite-Financiere")
    '    Set objfolder = objfolder.Store.GetDefaultFolder(olFolderInbox)
    Set objfolder = olFolder.Folders("EMBARGO")
    Call ProcessFolders(objfolder, True)

    Set BTR = olFolder.Folders("Boîte de réception")
    Set Bckup = BTR.Folders("Bckup Macro")

    'Pour les dossiers CACIB

    Set olFolder = olNS.Folders("EMBARGOCACIB Ddc")
    Call ProcFolders(olFolder, True)

    Set BTR = olFolder.Folders("Boîte de réception")
    Set Bckup = BTR.Folders("Bckup Macro")

    'Pour les dossiers LCL

    Set olFolder = olNS.Folders("EMBARGOLCL Ddc")
    Call ProcFolders(olFolder, True)

    Set BTR = olFolder.Folders("Boîte de réception")
    Set Bckup = BTR.Folders("Bckup Macro")


    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.Count
    Debug.Print
    For Each objfolder In StartFolder.Folders
        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
        Dim j
        i = objfolder.Items.Count
        If i <> 0 Then
            For j = 1 To i
                Set objitem = objfolder.Items(j)
                Call ProcessThisItem(objitem)
            Next j
        End If
    Next
    ' process all the subfolders of this folder
    'on traite tous les sous dossiers
    If SubFolder Then
        Call ProcessFolders(objfolder, SubFolder)
    End If



    Set objfolder = Nothing
End Sub



Sub ProcessThisItem(objitem As Object)
'---------------------------------------------------------------------------------------
' Procedure : ProcessThisItem
' Author    : Oliv
' Date      : 12/02/2016
' Purpose   :
'---------------------------------------------------------------------------------------
    Dim Nomdossier
    Dim OL As Outlook.Application
    Dim olNS As Outlook.NameSpace
    Dim olFolder As Outlook.Folder
    Dim BTR As Outlook.MAPIFolder
    
    Dim FolderToMove As Outlook.Folder
    Dim oMail As Outlook.MailItem

    '
    If objitem.Class = olMail Then
        Dim mymail As Outlook.MailItem
        Set mymail = objitem
        Nomdossier = mymail.Parent.Name

        If InStr(1, mymail.Body, "libéré", vbTextCompare) Or InStr(1, mymail.Body, "annulé", vbTextCompare) Or InStr(1, mymail.Body, "libération", vbTextCompare) Or InStr(1, mymail.Body, "released", vbTextCompare) Or InStr(1, mymail.Body, "annulation", vbTextCompare) Then
            If mymail.CreationTime < DateAdd("d", -60, Date) Then
                Call SaveandMoveConversation(mymail, Bckup, "O:\Projets01\DDC-CC\EMBARGO\" & Nomdossier & "\2016")

                '            Set OL = Outlook.Application
                '            Set olNS = OL.GetNamespace("MAPI")
                '            Set olFolder = olNS.Folders("EMBARGO Securite-Financiere")
                '            Set BTR = olFolder.Folders("Boîte de réception")
                '            Set Bckup = BTR.Folders("Bckup Macro")

                '            Call MoveConversation(mymail, Bckup)
                '            mymail.Move Bckup

            End If
        End If
    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
' Purpose   :
'---------------------------------------------------------------------------------------
'
' exemple repertoire = "c:\mail\"
    Dim NomExport
    Dim PathNomExport
    Dim n
    Dim MemPath

    'Ici on construit le nom du fichier qui sera créé
    NomExport = mymail.Subject
    ' & mymail.CreationTime

    'Ici on vérifie le répertoire où l'enregistrer
    If Right(repertoire, 1) <> "\" Then repertoire = repertoire & "\"
    
    'on vérifie s'il existe sinon on le crée
    Module10.waaps_creedir (repertoire)

    'Ici on supprime les caractères non autorisé dans les noms de fichiers
    PathNomExport = repertoire & Left(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace( _
                                                                                                                              NomExport, "\", ""), "/", ""), ":", ""), "*", ""), "?", ""), "<", ""), ">", ""), "|", ""), ".", ""), """", ""), vbTab, ""), Chr(7), ""), 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
    Call ModifDate(CStr(PathNomExport), mymail.CreationTime, 4)
    Call refresh_explorer(PathNomExport)

End Sub

Sub ProcFolders(StartFolder As Outlook.MAPIFolder, SubFolder As Boolean)
'---------------------------------------------------------------------------------------
' Procedure : ProcFolder
' 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.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
    Dim j
    i = StartFolder.Items.Count
    If i <> 0 Then
        For j = 1 To i
            Set objitem = StartFolder.Items(j)
            Call ProcessThisItem(objitem)
        Next j
    End If
    ' process all the subfolders of this folder
    'on traite tous les sous dossiers
    If olMailItem <> 0 Then
        Call ProcFolders(objfolder, SubFolder)
    End If
    '   Set objfolder = Nothing
End Sub

Private Sub Test_Conversation()

    Dim FolderToMove As Outlook.Folder
    Dim oMail As Outlook.MailItem
    ' Obtain the current item for the active inspector.
    Set oMail = Application.ActiveInspector.CurrentItem

    Set FolderToMove = Application.Session.PickFolder

    Call MoveConversation(oMail, FolderToMove)
End Sub


Sub SaveandMoveConversation(oMail As Outlook.MailItem, FolderToMove As Outlook.Folder, repertoire)
'---------------------------------------------------------------------------------------
' Procedure : MoveConversation
' Author    : Oliv
' Date      : 18/02/2016
' Purpose   : Pour déplacer une conversation
'---------------------------------------------------------------------------------------
'
    Dim oConv As Outlook.Conversation
    Dim oTable As Outlook.Table
    Dim oRow As Outlook.Row
    Dim mymail As Outlook.MailItem
    Dim oItem As Outlook.MailItem

    Const PR_STORE_ENTRYID As String = _
          "http://schemas.microsoft.com/mapi/proptag/0x0FFB0102"

    On Error Resume Next

    If Not (oMail Is Nothing) Then
        ' Obtain the Conversation object.
        Set oConv = oMail.GetConversation
        If Not (oConv Is Nothing) Then
            Set oTable = oConv.GetTable
            oTable.Columns.Add (PR_STORE_ENTRYID)
            Debug.Print oTable.GetRowCount
            Do Until oTable.EndOfTable
                Set oRow = oTable.GetNextRow
                ' Use EntryID and StoreID to open the item.
                Set oItem = Application.Session.GetItemFromID( _
                            oRow("EntryID"), _
                            oRow.BinaryToString(PR_STORE_ENTRYID))
                Call SavAs_mail_as_msg(oItem, repertoire)
                oItem.Move FolderToMove
            Loop
        End If
    End If
End Sub

**Oliv-** · 23/02/2016, 10h49

SAlut,

Quelle version de Outlook utilises tu ?

et une petite correction là

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

Public Bckup As Outlook.Folder
'...

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
    Dim objfolder As Outlook.MAPIFolder
    Dim BTR As Outlook.MAPIFolder
    'Dim Bckup As Outlook.MAPIFolder cette variable est déclarée PUBLIC en haut du module

    Set OL = Outlook.Application
    Set olNS = OL.GetNamespace("MAPI")

    'soit on le choisi
    '  Set olFolder = olNS.PickFolder


    'Pour les dossiers EMBARGO

    Set olFolder = olNS.Folders("EMBARGO Securite-Financiere")
    '    Set objfolder = objfolder.Store.GetDefaultFolder(olFolderInbox)
    Set objfolder = olFolder.Folders("EMBARGO")

    Set BTR = olFolder.Folders("Boîte de réception")
    Set Bckup = BTR.Folders("Bckup Macro")

    Call ProcessFolders(objfolder, True)


    'Pour les dossiers CACIB

    Set olFolder = olNS.Folders("EMBARGOCACIB Ddc")
    Set BTR = olFolder.Folders("Boîte de réception")
    Set Bckup = BTR.Folders("Bckup Macro")
    Call ProcFolders(olFolder, True)



    'Pour les dossiers LCL

    Set olFolder = olNS.Folders("EMBARGOLCL Ddc")
    Set BTR = olFolder.Folders("Boîte de réception")
    Set Bckup = BTR.Folders("Bckup Macro")
    Call ProcFolders(olFolder, True)


    MsgBox "Traitement terminé"


End Sub

et là

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
Sub SaveandMoveConversation(oMail As Outlook.MailItem, FolderToMove As Outlook.Folder, repertoire)
'---------------------------------------------------------------------------------------
' Procedure : MoveConversation
' Author    : Oliv
' Date      : 18/02/2016
' Purpose   : Pour déplacer une conversation
'---------------------------------------------------------------------------------------
'
    Dim oConv As Outlook.Conversation
    Dim oTable As Outlook.Table
    Dim oRow As Outlook.Row
    Dim mymail As Outlook.MailItem
    Dim oItem As Outlook.MailItem

    Const PR_STORE_ENTRYID As String = _
          "http://schemas.microsoft.com/mapi/proptag/0x0FFB0102"

    On Error Resume Next

    If Not (oMail Is Nothing) Then
        ' Obtain the Conversation object.
        Set oConv = oMail.GetConversation
        If Not (oConv Is Nothing) Then
            Set oTable = oConv.GetTable
            oTable.Columns.Add (PR_STORE_ENTRYID)
            MsgBox "oTable.GetRowCount", vbOKOnly, "Nombres de messages dans la conversation"

            Do Until oTable.EndOfTable
                Set oRow = oTable.GetNextRow
                ' Use EntryID and StoreID to open the item.
                Set oItem = Application.Session.GetItemFromID( _
                            oRow("EntryID"), _
                            oRow.BinaryToString(PR_STORE_ENTRYID))
                Call SavAs_mail_as_msg(oItem, repertoire)
                oItem.Move FolderToMove
            Loop
        End If
    End If
End Sub

**clambsf** · 23/02/2016, 17h16

J'ai outlook 2010

Je ne peux lancer la macro. J'ai un rejet que je n'avais pas encore eu
Nom ambigu détecté : SaveandMoveConversation

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
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
Public Bckup As Outlook.Folder
 
Sub test_this()
    Dim objitem As Object
    Set objitem = ActiveInspector.CurrentItem
 
    Set BTR = objitem.Application.Session.GetDefaultFolder(olFolderInbox)
    Set Bckup = BTR.Folders("Test")
 
    ProcessThisItem objitem
 
 
End Sub
 
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
    Dim objfolder As Outlook.MAPIFolder
    Dim BTR As Outlook.MAPIFolder
    'Dim Bckup As Outlook.MAPIFolder cette variable est déclarée PUBLIC en haut du module
 
    Set OL = Outlook.Application
    Set olNS = OL.GetNamespace("MAPI")
 
    'soit on le choisi
    '  Set olFolder = olNS.PickFolder
 
 
    'Pour les dossiers EMBARGO
 
    Set olFolder = olNS.Folders("EMBARGO Securite-Financiere")
    '    Set objfolder = objfolder.Store.GetDefaultFolder(olFolderInbox)
    Set objfolder = olFolder.Folders("EMBARGO")
 
    Set BTR = olFolder.Folders("Boîte de réception")
    Set Bckup = BTR.Folders("Bckup Macro")
 
    Call ProcessFolders(objfolder, True)
 
 
    'Pour les dossiers CACIB
 
    Set olFolder = olNS.Folders("EMBARGOCACIB Ddc")
    Set BTR = olFolder.Folders("Boîte de réception")
    Set Bckup = BTR.Folders("Bckup Macro")
    Call ProcFolders(olFolder, True)
 
 
 
    'Pour les dossiers LCL
 
    Set olFolder = olNS.Folders("EMBARGOLCL Ddc")
    Set BTR = olFolder.Folders("Boîte de réception")
    Set Bckup = BTR.Folders("Bckup Macro")
    Call ProcFolders(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.Count
    Debug.Print
    For Each objfolder In StartFolder.Folders
        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
        Dim j
        i = objfolder.Items.Count
        If i <> 0 Then
            For j = 1 To i
                Set objitem = objfolder.Items(j)
                Call ProcessThisItem(objitem)
            Next j
        End If
    Next
    ' process all the subfolders of this folder
    'on traite tous les sous dossiers
    If SubFolder Then
        Call ProcessFolders(objfolder, SubFolder)
    End If
 
 
 
    Set objfolder = Nothing
End Sub
 
 
 
Sub ProcessThisItem(objitem As Object)
'---------------------------------------------------------------------------------------
' Procedure : ProcessThisItem
' Author    : Oliv
' Date      : 12/02/2016
' Purpose   :
'---------------------------------------------------------------------------------------
    Dim Nomdossier
    Dim OL As Outlook.Application
    Dim olNS As Outlook.NameSpace
    Dim olFolder As Outlook.Folder
    Dim BTR As Outlook.MAPIFolder
 
    Dim FolderToMove As Outlook.Folder
    Dim oMail As Outlook.MailItem
 
    '
    If objitem.Class = olMail Then
        Dim mymail As Outlook.MailItem
        Set mymail = objitem
        Nomdossier = mymail.Parent.Name
 
        If InStr(1, mymail.Body, "libéré", vbTextCompare) Or InStr(1, mymail.Body, "annulé", vbTextCompare) Or InStr(1, mymail.Body, "libération", vbTextCompare) Or InStr(1, mymail.Body, "released", vbTextCompare) Or InStr(1, mymail.Body, "annulation", vbTextCompare) Then
            If mymail.CreationTime < DateAdd("d", -60, Date) Then
                Call SaveandMoveConversation(mymail, Bckup, "O:\Projets01\DDC-CC\EMBARGO\" & Nomdossier & "\2016")
 
                '            Set OL = Outlook.Application
                '            Set olNS = OL.GetNamespace("MAPI")
                '            Set olFolder = olNS.Folders("EMBARGO Securite-Financiere")
                '            Set BTR = olFolder.Folders("Boîte de réception")
                '            Set Bckup = BTR.Folders("Bckup Macro")
 
                '            Call MoveConversation(mymail, Bckup)
                '            mymail.Move Bckup
 
            End If
        End If
    End If
End Sub
 
Sub SaveandMoveConversation(oMail As Outlook.MailItem, FolderToMove As Outlook.Folder, repertoire)
'---------------------------------------------------------------------------------------
' Procedure : MoveConversation
' Author    : Oliv
' Date      : 18/02/2016
' Purpose   : Pour déplacer une conversation
'---------------------------------------------------------------------------------------
'
    Dim oConv As Outlook.Conversation
    Dim oTable As Outlook.Table
    Dim oRow As Outlook.Row
    Dim mymail As Outlook.MailItem
    Dim oItem As Outlook.MailItem
 
    Const PR_STORE_ENTRYID As String = _
          "http://schemas.microsoft.com/mapi/proptag/0x0FFB0102"
 
    On Error Resume Next
 
    If Not (oMail Is Nothing) Then
        ' Obtain the Conversation object.
        Set oConv = oMail.GetConversation
        If Not (oConv Is Nothing) Then
            Set oTable = oConv.GetTable
            oTable.Columns.Add (PR_STORE_ENTRYID)
            MsgBox "oTable.GetRowCount", vbOKOnly, "Nombres de messages dans la conversation"
 
            Do Until oTable.EndOfTable
                Set oRow = oTable.GetNextRow
                ' Use EntryID and StoreID to open the item.
                Set oItem = Application.Session.GetItemFromID( _
                            oRow("EntryID"), _
                            oRow.BinaryToString(PR_STORE_ENTRYID))
                Call SavAs_mail_as_msg(oItem, repertoire)
                oItem.Move FolderToMove
            Loop
        End If
    End If
End Sub
End Sub
 
Sub ProcFolders(StartFolder As Outlook.MAPIFolder, SubFolder As Boolean)
'---------------------------------------------------------------------------------------
' Procedure : ProcFolder
' 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.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
    Dim j
    i = StartFolder.Items.Count
    If i <> 0 Then
        For j = 1 To i
            Set objitem = StartFolder.Items(j)
            Call ProcessThisItem(objitem)
        Next j
    End If
    ' process all the subfolders of this folder
    'on traite tous les sous dossiers
    If olMailItem <> 0 Then
        Call ProcFolders(objfolder, SubFolder)
    End If
    '   Set objfolder = Nothing
End Sub
 
Private Sub Test_Conversation()
 
    Dim FolderToMove As Outlook.Folder
    Dim oMail As Outlook.MailItem
    ' Obtain the current item for the active inspector.
    Set oMail = Application.ActiveInspector.CurrentItem
 
    Set FolderToMove = Application.Session.PickFolder
 
    Call MoveConversation(oMail, FolderToMove)
End Sub
 
Sub SaveandMoveConversation(oMail As Outlook.MailItem, FolderToMove As Outlook.Folder, repertoire)
'---------------------------------------------------------------------------------------
' Procedure : MoveConversation
' Author    : Oliv
' Date      : 18/02/2016
' Purpose   : Pour déplacer une conversation
'---------------------------------------------------------------------------------------
'
    Dim oConv As Outlook.Conversation
    Dim oTable As Outlook.Table
    Dim oRow As Outlook.Row
    Dim mymail As Outlook.MailItem
    Dim oItem As Outlook.MailItem
 
    Const PR_STORE_ENTRYID As String = _
          "http://schemas.microsoft.com/mapi/proptag/0x0FFB0102"
 
    On Error Resume Next
 
    If Not (oMail Is Nothing) Then
        ' Obtain the Conversation object.
        Set oConv = oMail.GetConversation
        If Not (oConv Is Nothing) Then
            Set oTable = oConv.GetTable
            oTable.Columns.Add (PR_STORE_ENTRYID)
            Debug.Print oTable.GetRowCount
            Do Until oTable.EndOfTable
                Set oRow = oTable.GetNextRow
                ' Use EntryID and StoreID to open the item.
                Set oItem = Application.Session.GetItemFromID( _
                            oRow("EntryID"), _
                            oRow.BinaryToString(PR_STORE_ENTRYID))
                Call SavAs_mail_as_msg(oItem, repertoire)
                oItem.Move FolderToMove
            Loop
        End If
    End If
End Sub

**Oliv-** · 23/02/2016, 19h15

C est parce que tu as 2 fois.le.meme sub

**clambsf** · 24/02/2016, 10h08

Bonjour,

Peux-tu me dire ce que dois renvoyer oConv comme valeur dans oConv=oMail.get.conversation
Car en avançant Pas à Pas, rien n'est indiqué quand je clique dessus avec la souris et du coup je me dis demande quand il n'y a pas de conversation et qu'il s'agit d'un mail seul, si je ne skip pas Call 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
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
Sub SaveandMoveConversation(oMail As Outlook.MailItem, FolderToMove As Outlook.Folder, repertoire)
'---------------------------------------------------------------------------------------
' Procedure : MoveConversation
' Author    : Oliv
' Date      : 18/02/2016
' Purpose   : Pour déplacer une conversation
'---------------------------------------------------------------------------------------
'
    Dim oConv As Outlook.Conversation
    Dim oTable As Outlook.Table
    Dim oRow As Outlook.Row
    Dim mymail As Outlook.MailItem
    Dim oItem As Outlook.MailItem
 
    Const PR_STORE_ENTRYID As String = _
          "http://schemas.microsoft.com/mapi/proptag/0x0FFB0102"
 
    On Error Resume Next
 
    If Not (oMail Is Nothing) Then
        ' Obtain the Conversation object.
        Set oConv = oMail.GetConversation
        If Not (oConv Is Nothing) Then
            Set oTable = oConv.GetTable
            oTable.Columns.Add (PR_STORE_ENTRYID)
       '    MsgBox "oTable.GetRowCount", vbOKOnly, "Nombres de messages dans la conversation"
 
            Do Until oTable.EndOfTable
                Set oRow = oTable.GetNextRow
                ' Use EntryID and StoreID to open the item.
                Set oItem = Application.Session.GetItemFromID( _
                            oRow("EntryID"), _
                            oRow.BinaryToString(PR_STORE_ENTRYID))
                Call SavAs_mail_as_msg(oItem, repertoire)
                oItem.Move FolderToMove
            Loop
        End If
    End If
End Sub

**Oliv-** · 24/02/2016, 10h58

Salut,

Set oConv = oMail.GetConversation -- > doit te renvoyer un objet conversation(tu peux cliquer dessus dans les espions ou la fenetre varaible locales)
If Not (oConv Is Nothing) Then --> si cet objet n'est pas vide le programme entre dans cette condition
Set oTable = oConv.GetTable--> récupération dans une table des tous les Emails de la conversation(il doit au moins en avoir 1)
oTable.Columns.Add (PR_STORE_ENTRYID)
MsgBox "oTable.GetRowCount", vbOKOnly, "Nombres de messages dans la conversation" --> doit t'afficher le nombre de messages trouvés

Do Until oTable.EndOfTable --> commence à traiter la conversation.

J'ai également OL2010 et chez moi cela fonctionne

**clambsf** · 24/02/2016, 13h31

OMail me renvoie un objet mais pas OConv ni OTable quand je clique dessus

je voudrais rajouter qqch comme
if oconv n'est pas une conversation then
Call SavAs_mail_as_msg(oItem, repertoire)
end if

**Oliv-** · 24/02/2016, 14h45

Sur quel type de Mail n'as tu pas de conversation ? Un email non enregistré, un Email non envoyé ?

Peux tu lancer ce code et me donner le résultat qui se trouvera dans la fenêtre d'execution.

en principe il faudrait qu'il n'y ai que des VRAI.

Code :

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

1
2
3
4
5
6
7
8
9
10
Sub IsConversationEnabledStores()
    Dim colStores As Outlook.Stores
    Dim oStore As Outlook.Store
 
    On Error Resume Next
    Set colStores = Application.Session.Stores
    For Each oStore In colStores
        Debug.Print oStore.displayName & vbTab & "-" & oStore.IsConversationEnabled
    Next
End Sub

Voici une version comme tu souhaites avec l'alternative

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
Sub SaveAndMoveConversation(oMail As Outlook.MailItem, FolderToMove As Outlook.Folder, repertoire)
 
'---------------------------------------------------------------------------------------
' Procedure : Save and MoveConversation
' Author    : Oliv
' Date      : 18/02/2016
' Purpose   : Enreigistre la conversation sur Disque puis la déplace dans un dossier outlook
'---------------------------------------------------------------------------------------
'
    Dim oConv As Outlook.Conversation
    Dim oTable As Outlook.Table
    Dim oRow As Outlook.Row
    Dim oItem As Outlook.MailItem
    Const PR_STORE_ENTRYID As String = _
          "http://schemas.microsoft.com/mapi/proptag/0x0FFB0102"
 
    On Error Resume Next
 
    If Not (oMail Is Nothing) Then
        ' Obtain the Conversation object.
        Set oConv = oMail.GetConversation
        If Not (oConv Is Nothing) Then
            Set oTable = oConv.GetTable
            oTable.Columns.add (PR_STORE_ENTRYID)
            Debug.Print oTable.GetRowCount
            Do Until oTable.EndOfTable
                Set oRow = oTable.GetNextRow
                ' Use EntryID and StoreID to open the item.
                Set oItem = Application.Session.GetItemFromID( _
                            oRow("EntryID"), _
                            oRow.BinaryToString(PR_STORE_ENTRYID))
                Call SavAs_mail_as_msg(oItem, repertoire)
                oItem.Move FolderToMove
            Loop
        Else
            Call SavAs_mail_as_msg(oMail, repertoire)
            oMail.Move FolderToMove
        End If
    End If
End Sub

**clambsf** · 25/02/2016, 16h59

Salut Oliv'

Il s'agit toujours de mails envoyés, certains sont seuls, d'autres sont regroupés en conversation

Le code IsConversationEnabledStores a rendu des Vrai partout

J'ai lancé SaveAndMoveConversation

Arrivé à Do Until oTable.EndOfTable (valeur vrai)
il saute ensuite au premier end if (ligne 38)

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

Sub SaveAndMoveConversation(oMail As Outlook.MailItem, FolderToMove As Outlook.Folder, repertoire)
 
'---------------------------------------------------------------------------------------
' Procedure : Save and MoveConversation
' Author    : Oliv
' Date      : 18/02/2016
' Purpose   : Enreigistre la conversation sur Disque puis la déplace dans un dossier outlook
'---------------------------------------------------------------------------------------
'
    Dim oConv As Outlook.Conversation
    Dim oTable As Outlook.Table
    Dim oRow As Outlook.Row
    Dim oItem As Outlook.MailItem
    Const PR_STORE_ENTRYID As String = _
          "http://schemas.microsoft.com/mapi/proptag/0x0FFB0102"
 
    On Error Resume Next
 
    If Not (oMail Is Nothing) Then
        ' Obtain the Conversation object.
        Set oConv = oMail.GetConversation
        If Not (oConv Is Nothing) Then
            Set oTable = oConv.GetTable
            oTable.Columns.add (PR_STORE_ENTRYID)
            Debug.Print oTable.GetRowCount
            Do Until oTable.EndOfTable
                Set oRow = oTable.GetNextRow
                ' Use EntryID and StoreID to open the item.
                Set oItem = Application.Session.GetItemFromID( _
                            oRow("EntryID"), _
                            oRow.BinaryToString(PR_STORE_ENTRYID))
                Call SavAs_mail_as_msg(oItem, repertoire)
                oItem.Move FolderToMove
            Loop
        Else
            Call SavAs_mail_as_msg(oMail, repertoire)
            oMail.Move FolderToMove
        End If
    End If
End Sub

**Oliv-** · 25/02/2016, 17h06

ETRANGE

Essaye de lancer en commentant cette ligne

Code :

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

 On Error Resume Next

**clambsf** · 25/02/2016, 17h33

Désoler mais ça veut dire quoi lancer en commentant la ligne.
Si c'est ajouter un espion j'ai le rejet "Expression espionne incorrecte"

**Oliv-** · 25/02/2016, 17h50

c'est mettre le signe ' devant la ligne pour qu'elle ne soit pas traitée

Nom : comment.gif
Affichages : 279
Taille : 393,2 Ko

**clambsf** · 25/02/2016, 18h07

j'avais fait cela sans succès.

J'ai une question, si je sélectionne un mail unique,sans conversation

l'instruction If Not (oConv Is Nothing) Then devrait renvoyer Nothing et donc allet à end if ?
Est-ce que je me trompe ?

Dans la macro ça passe à la ligne suivante comme si o.conv était not nothing.

**Oliv-** · 25/02/2016, 20h05

En principe conversation renvoi au minimum le mail en cours.

**clambsf** · 26/02/2016, 09h37

Donc qu'il y ait un mail ou plusieurs oconv renvoie toujours une valeur.
Peux-tu m'expliquer ce que veut dire chacune de ses lignes et aussi qu'est-ce qu'on appelle une table.

Code :

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

1
2
3
4
5
6
 '           Do Until (oTable.EndOfTable)
                Set oRow = oTable.GetNextRow
                ' Use EntryID and StoreID to open the item.
                Set oItem = Application.Session.GetItemFromID( _
                            oRow("EntryID"), _
                            oRow.BinaryToString(PR_STORE_ENTRYID))

**Oliv-** · 26/02/2016, 09h49

Bonjour,

Non pas toujours il y a quelques exceptions
voici ce que dit l'aide

GetConversation renvoie la valeur Null (Nothing en Visual Basic) s’il n’existe aucune conversation pour cet élément. Il n’existe aucune conversation pour un élément dans les scénarios suivants :

L’élément n’a pas été enregistré. Un élément peut être enregistré par programmation, par une action de l’utilisateur ou par enregistrement automatique.
Un élément qui peut être envoyé (par exemple, un élément de courrier, de rendez-vous ou de contact) n’a pas été envoyé.
Les conversations ont été désactivées via le Registre Windows.
La banque ne prend pas en charge le mode d’affichage Conversation (par exemple si Outlook exécute en mode connexion classique une version de Microsoft Exchange antérieure à Microsoft Exchange Server 2010). Utilisez la propriété IsConversationEnabled de l’objet Store pour déterminer si la banque prend en charge le mode d’affichage Conversation.

D'où mes questions précédemment.

Une table ici est le resultat d'une requete,( comme pour SQL, ADODB, RDO,..), en gros c'est une feuille excel.

' Do Until (oTable.EndOfTable) '--> ici on fait une boucle tant qu'on n'est pas à la fin de la table
Set oRow = oTable.GetNextRow '--> on passe à la ligne suivante
' Use EntryID and StoreID to open the item.'-->ligne de commentaire en anglais ;-)
Set oItem = Application.Session.GetItemFromID( oRow("EntryID"), oRow.BinaryToString(PR_STORE_ENTRYID))'--> on utilise l'information de la table qui liste les Emails de la conversation pour ouvrir cet Email par un identifiant unique.

Je ne m'explique pas, pourquoi il trouve bien une conversation mais tombe de suite sur le ENDoftable= true ?

En mettant un ' devant On Error Resume Next s'il y avait une erreur elle devrait s'afficher.

as tu bien essayé en mode pas à pas ?

je vais ajouter des debug.print pour comprendre où cela bloque chez toi.

**Oliv-** · 26/02/2016, 10h14

Comment fais tu pour tester ?

tu lances Lance_Traitement ou test_this ce dernier permet de tester sur le Mail ouvert

est-ce le même comportement sur les différents dossiers ?

'Pour les dossiers EMBARGO
...
'Pour les dossiers CACIB

...
'Pour les dossiers LCL
...

**clambsf** · 29/02/2016, 11h09

Bonjour Oliv'

Pour tester je mets un point d'arrêt quand j'arrive à SaveAndMoveConversation et ensuite je passe en mode pas à pas
J'ai lancé la macro et ai sélectionné une conversation. Même résultat que ce soit avec un mail unique ou une conversation.

J'ai mis un espion sur oconv et ai mis on resume next en commentaire
il y a echec de l'opération avec answerWizard,
Je ne sais pas si çette information sert à quelque chose

**Oliv-** · 29/02/2016, 11h39

Bonjour,

je ne vois pas à quoi correspond answerWizard.

DAns la macro tu as ces lignes

Code :

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

1
2
3
 Set oTable = oConv.GetTable
            oTable.Columns.add (PR_STORE_ENTRYID)
            Debug.Print oTable.GetRowCount

Modifies les comme cela

Code :

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

1
2
3
4
 Set oTable = oConv.GetTable
                         Debug.Print "#1 nb de mail de la conversation=" & vbTab & oTable.GetRowCount
            oTable.Columns.add (PR_STORE_ENTRYID)
            Debug.Print "#2 nb de mail de la conversation=" & vbTab & oTable.GetRowCount

et tu verras dans la "fenetre execution" le résultat

Déplacer des mails d'Outlook vers un répertoire dans windows selon des critères

VBA Outlook

Discussions similaires

Partager

Partager