Discussion :

[Oliv-]

Il faudrait que tu publie l'ensemble de ton code ici pour voir ce qui cloche

[clambsf]

En fait la modification de date se fait bien mail elle n'apparait que lorsqu'il y a le transfert d'un 2ème mail dans le même dossier.
C'est déjà mieux mais alors le dernier mail transféré n'est jamais à jour.
Connais-tu un moyen pour pallier à cela ?

[Oliv-]

c'est peut être juste un problème de rafraîchissement de l'explorateur

[clambsf]

Je crois que j'ai trouvé, il faut simplement que j'actualise l'affichage.
j'ai essayé

Application.ScreenUpdating = true à la fin de ModifDate mais ça n'a pas marché

[Oliv-]

où regarde tu cette date dans l'explorateur windows ? c'est F5 (manuellement)

[clambsf]

Ne peut-on pas automatiser cette actualisation ?

[Oliv-]

Salut,

avec 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
Public Sub refresh_explorer(rep)
'---------------------------------------------------------------------------------------
' Procedure : refresh_explorer
' Author    : Oliv
' Date      : 18/02/2016
' Purpose   : rafraichie l'explorateur ouvert sur le dossier passé en argument
' AJOUTER UNE REFERENCE à 'Microsoft Internet control'
'---------------------------------------------------------------------------------------
'
 
'find the right internet explorer webpage
    Dim allExplorerWindows As New SHDocVw.ShellWindows
    Dim IEwindow As Object
    Dim FSO
    Set FSO = CreateObject("Scripting.FileSystemObject")
    AFolder = FSO.GetParentFolderName(rep)
 
    Set allExplorerWindows = New SHDocVw.ShellWindows
    AFolder = Replace(AFolder, "\", "/")
    For Each IEwindow In allExplorerWindows
        Debug.Print IEwindow.LocationURL
        If InStr(IEwindow.LocationURL, AFolder) <> 0 Then
            IEwindow.Refresh
            'on peut quitter au premier trouvé
            'exit for
        End If
    Next
End Sub
 
Sub Test_refresh_explorer()
    PathNomExport = "E:\temp\PRINTtemp\Email RE Badge tour09042014 123004.msg"
    Call ModifDate(CStr(PathNomExport), Date, 4)
    Call refresh_explorer(PathNomExport)
 
End Sub

[clambsf]

Bonjour,

Sur refresh_explorer j'ai le message de rejet suivant :

type non défini sur Dim allExplorerWindows As New SHDocVw.ShellWindows

[Oliv-]

Il faut lire un peu !

' AJOUTER UNE REFERENCE à 'Microsoft Internet control'

[clambsf]

J'avais lu mais compte tenu des mes connaissances limitées, cela ne me parle pas du tout.
C'est quoi Microsoft Internet Control ?

[Oliv-]

une dll

dans VBE (la fenetre des macros)
clic menu / outils /références

et tu coches 'Microsoft Internet control'

[clambsf]

OK merci

Le message une fois raffraichi est comme ceci : Email ANNULATION- 150817_EUR 5000,00_IIRO _SF TCBrtf17082015 163601

Peut-on supprimer les chiffres après rtf et email en début de titre car le titre d'origine est celui-là :ANNULATION- 150817_EUR 5000,00_IIRO _SF TCB.rtf ?


J'ai une deuxième question dans un autre domaine : Une fois le fichier recopié dans le repertoire, je veux déplacer l'email de départ dans un dossier backup Macro (au cas où) plutôt que de le supprimer.
Voici le code :

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

mymail.Move Bckup

Il arrive que le mail que j'ai à déplacer soit un mail unique ou une conversation avec plusieurs mail, comment dois-je faire, dans le cas d'une conversation, pour déplacer tous les mails de la conversation et les laisser ensemble ?

[Oliv-]

OK merci

Le message une fois raffraichi est comme ceci : Email ANNULATION- 150817_EUR 5000,00_IIRO _SF TCBrtf17082015 163601

Peut-on supprimer les chiffres après rtf et email en début de titre car le titre d'origine est celui-là :ANNULATION- 150817_EUR 5000,00_IIRO _SF TCB.rtf ?

Il me semblait que c'est ce que tu voulais !

il faut changer cette partie

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
13
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\"
 
 
    'Ici on construit le nom du fichier qui sera créé
    NomExport = MyMail.subject

J'ai une deuxième question dans un autre domaine : Une fois le fichier recopié dans le repertoire, je veux déplacer l'email de départ dans un dossier backup Macro (au cas où) plutôt que de le supprimer.
Voici le code :

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

mymail.Move Bckup

Il arrive que le mail que j'ai à déplacer soit un mail unique ou une conversation avec plusieurs mail, comment dois-je faire, dans le cas d'une conversation, pour déplacer tous les mails de la conversation et les laisser ensemble ?

pour que ce soit plus lisible met ton code dans la balise code en cliquant sur l'icone #

Il faut utiliser les informations de conversation

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
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 MoveConversation(oMail As Outlook.MailItem, FolderToMove As Outlook.Folder)
'---------------------------------------------------------------------------------------
' 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 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))
                oItem.Move FolderToMove
            Loop
        End If
    End If
End Sub

[clambsf]

Sur le point 1, c'est bien la colonne date de création que je voulais changer et non pas rajouter des infos dans le titre. J'avais du mal m'exprimé.Merci pour l'info.

Sur le point 2, ou j'intègre la procedure Test_conversation ?
Et elle permet bien de tester bien le cas où il y a un mail seul et celui ou c'est une conversation

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
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 Bckup 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) Then
            If mymail.CreationTime < DateAdd("d", -60, Date) Then
                Call SavAs_mail_as_msg(mymail, "O:\Projets01\DDC-CC\EMBARGO\" & Nomdossier & "\2016")
            End If
        End If
        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")
 
        mymail.Move Bckup
 
    End If
End Sub

[Oliv-]

C'est juste le call de la sub qu'il faut ajouter après la ligne

Code :

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

1
2
 mymail.Move Bckup
Call MoveConversation(mymail, Bckup)

mais elle pourrait remplacer même cette ligne

[clambsf]

J'arrive à faire tourner la macro et je réalise que dans SaveAs_mail_as_msg, c'est ok pour des mails uniques et que doit-on faire s'il faut sauvegarder toute la conversation ?
C'est à peu près la même macro que Move Conversation sauf qu'on doit placer save et le chemin je suppose ?

[Oliv-]

J'ai compris, en relisant, que tu voudrais enregistrer toute la conversation sur le Disque!

Tu as je pense compris le principe.

Pour traiter toute la conversation , c'est à dire l'exporter et la déplacer il faut inclure SavAs_mail_as_msg dans MoveConversation

parce que dans ta conversation est inclu ton mail initiale et sinon tu auras un doublon lors de l'export sur disque.

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
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(mymail, repertoire)
                oItem.Move FolderToMove
            Loop
        End If
    End If
End Sub

et donc tu changes dans ProcessThisItem

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
Sub ProcessThisItem(objitem As Object)
'---------------------------------------------------------------------------------------
' Procedure : ProcessThisItem
' Author    : Oliv
' Date      : 12/02/2016
' Purpose   :
'---------------------------------------------------------------------------------------
    Dim Nomdossier
 
    Dim olNS As Outlook.NameSpace
    Dim olFolder As Outlook.Folder
    Dim BTR As Outlook.MAPIFolder
    Dim Bckup As Outlook.MAPIFolder
    Dim FolderToMove As Outlook.Folder
    Dim oMail As Outlook.MailItem
 
 
'cette partie pourrait se trouver dans la macro de départ en définissant 
'PUBLIC Bckup  
        Set olNS = objitem.application.GetNamespace("MAPI")
        Set olFolder = olNS.Folders("EMBARGO Securite-Financiere")
        Set BTR = olFolder.Folders("Boîte de réception")
        Set Bckup = BTR.Folders("Bckup Macro")
 
 
    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) Then
            If mymail.CreationTime < DateAdd("d", -60, Date) Then
 
Call SaveAndMoveConversation(mymail, Bckup ,"O:\Projets01\DDC-CC\EMBARGO\" & Nomdossier & "\2016")
 
            End If
        End If
 
 
 
 
    End If
End Sub

j'ai pas testé mais le principe est là et ca doit marcher

[clambsf]

Bonjour Oliv',

Merci encore pour ton aide.

La macro a sélectionné un mail et Do Until oTable.EndOfTable renvoie vrai ce qui fait que je saute call SavAs_mail_as_msg.
Y a-t-il quelque chose a 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
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(oMail, repertoire)
                oItem.Move FolderToMove
            Loop
        End If
    End If
End Sub

[Oliv-]

Il faudrait que tu publis le code complet que tu utilises, il y a eu trop de changements, pour déterminer les codes que tu utilises

[clambsf]

Voici le premier module

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
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)
 
    'Pour les dossiers CACIB
 
    Set olFolder = olNS.Folders("EMBARGOCACIB Ddc")
    Call ProcFolders(olFolder, True)
 
    'Pour les dossiers LCL
 
    Set olFolder = olNS.Folders("EMBARGOLCL Ddc")
    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 Bckup 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 & "\"
 
    '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(oMail, repertoire)
                oItem.Move FolderToMove
            Loop
        End If
    End If
End Sub

et voici le second

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
Public Const OFS_MAXPATHNAME = 260
 
Type OFSTRUCT
   cBytes As Byte
   fFixedDisk As Byte
   nErrCode As Integer
   Reserved1 As Integer
   Reserved2 As Integer
   szPathName(OFS_MAXPATHNAME) As Byte
End Type
Type FILETIME
        dwLowDate As Long
        dwHighDate As Long
End Type
Type SYSTEMTIME
        wYear As Integer
        wMonth As Integer
        wDayOfWeek As Integer
        wDay As Integer
        wHour As Integer
        wMinute As Integer
        wSecond As Integer
        wMillisecs As Integer
End Type
 
 
' constante
Public Const FILE_SHARE_READ = &H1
Public Const FILE_SHARE_WRITE = &H2
Public Const GENERIC_WRITE = &H40000000
Public Const OPEN_EXISTING = 3
 
' declarations api
Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" _
          (ByVal lpFileName As String, _
          ByVal dwDesiredAccess As Long, _
          ByVal dwShareMode As Long, _
          ByVal lpSecurityAttributes As Long, _
          ByVal dwCreationDisposition As Long, _
          ByVal dwFlagsAndAttributes As Long, _
          ByVal hTemplateFile As Long) As Long
Declare Function LocalFileTimeToFileTime Lib "kernel32" _
          (lpLocalFileTime As FILETIME, _
          lpFileTime As FILETIME) As Long
Declare Function SetFileTime Lib "kernel32" _
          (ByVal hFile As Long, _
          lpcreation As FILETIME, _
          lpLecture As FILETIME, _
          lpLastWriteTime As FILETIME) As Long
Declare Function GetFileTime Lib "kernel32" _
        (ByVal hFile As Long, lpCreationTime As FILETIME, _
         lpLastAccessTime As FILETIME, _
         lpLastWriteTime As FILETIME) As Long
Declare Function SystemTimeToFileTime Lib "kernel32" _
          (lpSystemTime As SYSTEMTIME, _
          lpFileTime As FILETIME) As Long
Declare Function FileTimeToSystemTime Lib "kernel32" _
        (lpFileTime As FILETIME, _
         lpSystemTime As SYSTEMTIME) As Long
 
Public Function GetFT(sDate) As FILETIME
    Dim udtSysTime As SYSTEMTIME
    Dim udtLocalTime As FILETIME
    Dim Ft As FILETIME
    Dim RetVal As Long
 
    With udtSysTime
        .wYear = Year(sDate)
        .wMonth = Month(sDate)
        .wDay = Day(sDate)
        .wDayOfWeek = Weekday(sDate) - 1
        .wHour = Hour(sDate)
        .wMinute = Minute(sDate)
        .wSecond = Second(sDate)
    End With
    RetVal = SystemTimeToFileTime(udtSysTime, udtLocalTime)
    RetVal = LocalFileTimeToFileTime(udtLocalTime, GetFT)
End Function
 
Public Function GetFileDateString(CT As FILETIME, sFormat As String) As String
  Dim ST As SYSTEMTIME
  Dim ds As Single
 
 'Convertir les infos du fichier en un format temps affichable
    If FileTimeToSystemTime(CT, ST) Then
        ds = DateSerial(ST.wYear, ST.wMonth, ST.wDay)
        GetFileDateString = Format$(ds, sFormat)
    Else
        GetFileDateString = ""
    End If
End Function
 
'******** MODIFIER UN FICHIER ***********************
Public Sub ModifDate(sNomFichier As String, sDate As String, byType As Byte)
'byType = 1 =>Date de creation
'byType = 2 =>Date de Lecture
'byType = 3 =>Date derniere ecriture
'byType = 4 => toutes
    Dim hFile As Long
    Dim Ft As FILETIME
    Dim FTc As FILETIME
    Dim FTa As FILETIME
    Dim FTw As FILETIME
    Dim RetVal As String
 
    hFile = CreateFile(sNomFichier, GENERIC_WRITE, FILE_SHARE_READ Or FILE_SHARE_WRITE, ByVal 0&, OPEN_EXISTING, 0, 0)
    GetFileTime hFile, FTc, FTa, FTw
    Select Case byType
        Case 1
            ' modification Date de creation
            Ft = GetFT(sDate)
            RetVal = SetFileTime(hFile, Ft, FTa, FTw)
        Case 2
            ' modification Date de Lecture
            Ft = GetFT(sDate)
            RetVal = SetFileTime(hFile, FTc, Ft, FTw)
        Case 3
            ' modification Date derniere ecriture
            Ft = GetFT(sDate)
            RetVal = SetFileTime(hFile, FTc, FTa, Ft)
        Case 4
            ' modification toutes
            Ft = GetFT(sDate)
            RetVal = SetFileTime(hFile, Ft, Ft, Ft)
    End Select
 
 
End Sub
 
Public Sub refresh_explorer(rep)
'---------------------------------------------------------------------------------------
' Procedure : refresh_explorer
' Author    : Oliv
' Date      : 18/02/2016
' Purpose   : rafraichie l'explorateur ouvert sur le dossier passé en argument
' AJOUTER UNE REFERENCE à 'Microsoft Internet control'
'---------------------------------------------------------------------------------------
'
 
'find the right internet explorer webpage
    Dim allExplorerWindows As New SHDocVw.ShellWindows
    Dim IEwindow As Object
    Dim FSO
    Set FSO = CreateObject("Scripting.FileSystemObject")
    AFolder = FSO.GetParentFolderName(rep)
 
    Set allExplorerWindows = New SHDocVw.ShellWindows
    AFolder = Replace(AFolder, "\", "/")
    For Each IEwindow In allExplorerWindows
        Debug.Print IEwindow.LocationURL
        If InStr(IEwindow.LocationURL, AFolder) <> "" Then
            IEwindow.Refresh
            'on peut quitter au premier trouvé
            'exit for
        End If
    Next
End Sub
 
Sub Test_refresh_explorer()
    PathNomExport = "E:\temp\PRINTtemp\Email RE Badge tour09042014 123004.msg"
    Call ModifDate(CStr(PathNomExport), Date, 4)
    Call refresh_explorer(PathNomExport)
 
End Sub