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