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
|
Option Explicit
Public myNewFolder As Outlook.MAPIFolder
Public Tour As Double
Sub MoveFolders()
'---------------------------------------------------------------------------------------
' Procedure : MoveFolders
' Author : Oliv
' Date : 15/02/2018
' Purpose :
'---------------------------------------------------------------------------------------
'
Dim olFolder As Outlook.Folder
Dim OL As Object
Dim u, i, User, UserRecip As Recipient, UserStore
If UCase(Application) = "OUTLOOK" Then
Set OL = Application
Else
Set OL = CreateObject("outlook.application")
End If
Dim objNS As Outlook.Namespace
Dim objFolderOrigine As Outlook.MAPIFolder
Dim DossiersOrigine As Variant
Dim DossiersCible As Variant
DossiersOrigine = Array("Mailbox", "send Items")
DossiersCible = Array(olFolderInbox, olFolderSentMail)
Set objNS = OL.GetNamespace("MAPI")
For u = 2 To Cells(Rows.Count, 1).End(xlUp).Row
MsgBox Cells(u, 1).Value
User = Cells(u, 1).Value
On Error Resume Next
Set UserRecip = objNS.CreateRecipient(User)
Set UserStore = objNS.GetSharedDefaultFolder(UserRecip, olFolderInbox).Parent.Store
If UserStore Is Nothing Or IsEmpty(UserStore) Then
' Set myNewFolder = UserStore.GetDefaultFolder(olFolderInbox)
' MsgBox myNewFolder.FolderPath
Debug.Print User & ": inaccessible"
Else
For i = 0 To UBound(DossiersOrigine)
Set objFolderOrigine = UserStore.GetDefaultFolder(olFolderInbox).Parent.Folders(DossiersOrigine(i))
Set myNewFolder = UserStore.GetDefaultFolder(DossiersCible(i))
If objFolderOrigine Is Nothing Then Debug.Print DossiersOrigine(i) & ":Non trouvé dans " & objNS.GetDefaultFolder(olFolderInbox).Parent
If myNewFolder Is Nothing Then Debug.Print DossiersCible(i) & ":Non trouvé dans " & objNS.DefaultStore
If objFolderOrigine Is Nothing Or myNewFolder Is Nothing Then
Else
'MsgBox objFolderOrigine.FolderPath & vbCr & myNewFolder.FolderPath
Call ProcessFolderMove(objFolderOrigine, objFolderOrigine, myNewFolder, myNewFolder)
End If
Set objFolderOrigine = Nothing
Set myNewFolder = Nothing
Next i
End If
Set UserRecip = Nothing
Set UserStore = Nothing
Next u
Set objNS = Nothing
Set objFolderOrigine = Nothing
Set myNewFolder = Nothing
End Sub
Sub ProcessFolderMove(StartFolder As Outlook.MAPIFolder, objFolderOrigine As Outlook.MAPIFolder, DestinationParentFolder As Outlook.MAPIFolder, DestinationOrigine As Outlook.MAPIFolder)
Tour = Tour + 1
Dim objFolder As Outlook.MAPIFolder
Dim destFolder As Outlook.MAPIFolder
Dim myItem
Dim n
'Dim objItem As Object
On Error Resume Next
' do something specific with this folder
Debug.Print StartFolder.FolderPath, StartFolder.Folders.Count, StartFolder.Items.Count
Debug.Print
'on teste si on est à la racine de la BAL
If InStr(3, StartFolder.FolderPath, "\") = 0 Then GoTo racine
If StartFolder.FolderPath = objFolderOrigine.FolderPath Then GoTo racine
If StartFolder.DefaultItemType = olMailItem Then
' MsgBox StartFolder.Name
Set destFolder = DestinationParentFolder.Folders(StartFolder.Name)
On Error GoTo 0
If Not IsEmpty(destFolder) And Not destFolder Is Nothing Then
For Each objFolder In StartFolder.Folders
On Error GoTo 0
Call ProcessFolderMove(objFolder, objFolderOrigine, destFolder, DestinationOrigine)
Next
For n = StartFolder.Items.Count To 1 Step -1
Set myItem = StartFolder.Items(n)
If myItem.Class <> olMail And myItem.Class <> olReport Then Stop: myItem.Display
myItem.Move destFolder
Next n
Debug.Print "Move " & StartFolder.FolderPath & " vers " & DestinationParentFolder.FolderPath
If StartFolder.Items.Count = 0 Then StartFolder.Delete
Else
On Error Resume Next
StartFolder.MoveTo DestinationParentFolder
Debug.Print "Move " & StartFolder.FolderPath & " vers " & DestinationParentFolder.FolderPath
End If
End If
Exit Sub
racine:
' process all the subfolders of this folder
For n = StartFolder.Folders.Count To 1 Step -1
Set objFolder = StartFolder.Folders(n)
On Error GoTo 0
Call ProcessFolderMove(objFolder, objFolderOrigine, DestinationParentFolder, DestinationOrigine)
Next n
'process items
For n = StartFolder.Items.Count To 1 Step -1
Set myItem = StartFolder.Items(n)
If myItem.Class <> olMail And myItem.Class <> olReport Then Stop: myItem.Display
myItem.Move DestinationParentFolder
Next n
Set objFolder = Nothing
End Sub |
Déplacement des mails et répertoires d'un dossier vers la boite de réception
Répondre avec citation
Oliv'
Partager