Discussion :

[djibril]

Je ne sais pas comment tester ton code redemption pour le lancer depuis le compte administrateur sur les comptes de mon choix. Un peu comme ce que j'ai fait pour les autres programmes.

[Oliv-]

Deux petites questions :
Ton redemption, je l'installe uniquement sur le poste où je lance ma macro, ok ? Pas besoin de toucher au serveur exchange.

oui uniquement sur ton poste où tu as ton outlook de paramétré.

Quand tu fais le renommage, comment tu fais pour renommer le vrai Inbox en autre chose, vu que c'est un dossier système ?
Y a aucun risque ?

REDEMPTION Permet de faire cela ! DAns mon exemple j'ai pas renommé le dossier, je vais modifié le code.

j'ai fait un test sur un pst et sur un compte exchange cela semble ok, mais je ne peux garantir qu'il n'y ai pas de raté.



pour tester le code en fait tu changes juste la valeur entre guillemets par le nom de la boite voulu .

Code :

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

  Set store = Session.Stores("mabal@toto.com")

[Oliv-]

attends que je change le code stp!

[djibril]

En attendant un dernier test de Redemption, même si je trouve cela dangereux, le programme de copie suivant bogue :

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
 
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", "sent Items")
    DossiersCible = Array(olFolderInbox, olFolderSentMail)
 
    Set objNS = OL.GetNamespace("MAPI")
 
    For u = 2 To Cells(Rows.Count, 1).End(xlUp).Row
 
        User = Cells(u, 1).Value & " " & Cells(u, 2).Value
		MsgBox (User)
       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

Si j'ai l'arborescence suivante :
Mailbox
- mails
--> 111/mails
--> 222/mails
--> 333/mails
----> 444/mails

Les dossiers 333 et 444 ne sont pas déplacés, pourtant ton programme semble bien récursif !

[Oliv-]

peut être à cause de la ligne

Code :

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

If StartFolder.DefaultItemType = olMailItem Then

A vérifier avec le listage (#15)


Pour le code avec REDEMPTION, les tests sur une bal exchange ne sont pas vraiment concluants, cela marche pour définir le type de dossier par défaut, pas pas pour supprimer l'ancien dossier
il faudrait creuser un peu plus.
voici le code au cas où

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
Sub ChangeDefaultCalendrierAndDelete()
'---------------------------------------------------------------------------------------
' Procedure : ChangeDefaultCalendrierAndDelete
' Author    : Oliv
' Date      : 20/02/2018
' Purpose   :
'---------------------------------------------------------------------------------------
'
 
    Dim Session, store, folder, FolderOld, i
 
    Const olFolderCalendar = 9
    Const olFolderInbox = 6
    Const olFolderSentMail = 5
 
    Dim DossiersOrigine, DossiersCible, DossiersNouveauxNoms
 
    Dim FolderOldName
 
 
    Set Session = CreateObject("Redemption.RDOSession")
    Session.Logon
    '    Set store = Session.Stores("pst_vide")
    Set store = Session.Stores("GsNord.Paq@grassavoye.com")
 
    Err.Clear
    On Error Resume Next
 
    '    DossiersOrigine = Array(olFolderInbox, olFolderSentMail, olFolderCalendar)
    '    DossiersCible = Array("Mailbox", "send Items", "Calendrier")
    DossiersOrigine = Array(olFolderInbox, olFolderSentMail)
    DossiersCible = Array("Mailbox", "send Items")
        DossiersNouveauxNoms = Array("Boîte de réception", "send Items")
 
 
 
    For i = 0 To UBound(DossiersOrigine)
        'does the store already have a default Calendar folder?
        Set FolderOld = store.GetDefaultFolder(DossiersOrigine(i))
        FolderOldName = DossiersNouveauxNoms(i)
        If Err.Number = 0 Then
            'no default Calendar folder. Check if there is a folder named "Calendrier"
            'and if not, create one
            Err.Clear
            Set folder = store.IPMRootFolder.Folders(DossiersCible(i))
            If (Err.Number <> 0) Or (folder Is Nothing) Then
                'create a new folder
                Err.Clear
                Set folder = store.IPMRootFolder.Folders.Add(DossiersCible(i))
            End If
 
            If StrComp(folder.FolderPath, FolderOld.FolderPath, vbTextCompare) <> 0 Then
            folder.SetAsDefaultFolder (DossiersOrigine(i))
            If Err.Number = 0 Then
                Err.Clear
                On Error GoTo 0
                FolderOld.Delete
                folder.Name = FolderOldName
            Else
                MsgBox Err & vbCr & Err.Description
            End If
            End If
        End If
        Set folder = Nothing
        Set FolderOld = Nothing
        Err.Clear
    Next i
 
End Sub

[djibril]

Je ne sais pas comment te remercier pour le temps passé à m'aider. C'est sympa.
Pour Redemption, je crois que je vais laisser tomber. J'ai testé aussi le soft MFCMAPI, mais bon, les manipulations restent assez dangereuses.

Je vais rester sur le programme de copie plus sûr. Il faut juste que je trouve pourquoi ça bogue. Je l'utiliserai pour des boites critiques, pas pour tout le monde. ce sera déjà très bien. Encore merci.

Je vais tester ton #15

[djibril]

Voici ce que j'obtiens :

Code :

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

1
2
3
4
5
.FolderPath	.DefaultItemType	.Items.Count
\\xxxx yyyyy\Mailbox	0	0
\\xxxx yyyyy\Mailbox\333	0	10
\\xxxx yyyyy\Mailbox\333\444	0	1
\\xxxx yyyyy\Mailbox\555	0	1

[Oliv-]

Pour redemption, c'est peut être chez moi juste un problème de droits insuffisants côtè EXCHANGE...


Pour l'autre méthode en principe si le dossier 555 n'existe pas dans inbox il déplace le dossier dans inbox, si le dossier existe déjà il déplace élément/élément.

qu'a de particulier l'item contenu dans 555 ?

il faudrait suivre en pas à pas pour voir ce qu'il fait

[djibril]

en fait, dans Mailbox je peux avoir des mails, des dossiers de mails et des dossiers de dossiers de mails.
Le programme coppie correctement tous les mails et dossiers de mails.
Dès qu'il y a des sous dossiers, il ne se passe plus rien.

[djibril]

Après investigation, le code cherche à faire un move de \\xx yy\Mailbox\333 vers \\xx yy\Inbox alors que le dossier 333 contient un sous répertoire 444 avec des mails.
Ce qui veut dire le code ne rentre pas ici :

Code :

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

If Not IsEmpty(destFolder) And Not destFolder Is Nothing Then

Le .MoveTo ne sait pas copier tout le contenu plus les sous dossiers ?

[Oliv-]

en principe il sait.
mais c'est pourquoi je demandais de vérifier 555 car pas de sous dossier

[djibril]

Bonsoir,

Je confirme que les dossiers contenant des sous dossiers ne sont pas copiés .

[Oliv-]

est ce que tu peux les déplacer "manuellement" en faisant clic droit sur le dossier et déplacer.

Moi sur certains il me met un message impossible de déplacer car le dossier peut contenir des éléments privés

[djibril]

Bonjour,

C'est ce que je vais faire. De toute façon, je ne ferai pas le déplacement pour toutes les boites. Ce sera au cas par cas. Donc premièrement, déplacement via un clic droit pour les dossiers et le reste via la macro.
Merci pour tes aides durant ces derniers jours. Je te tiens au courant lorsque j'aurai complétement terminé.

[Oliv-]

Salut,
en fait ma question c'était "est ce que cela fonctionne manuellement ?"

Selon le paramétrage des comptes chez moi l'erreur se produit ou non , si le compte où je veux faire les déplacements, est un compte Principal, cela fonctionne
si c'est un compte "secondaire" j'ai le message


la copie fait pareil.

Donc soit il faut paramétrer le compte différemment, soit il faut
traiter dossier par dossier en créant le dossier dans la destination et en déplaçant item par item ,cela fonctionne.

[djibril]

Tous les comptes que je vais migrer sont des comptes principaux et pourtant la copie ne se fait pas.
Mais bon, j'ai la solution qui me suffira. Si je repère un dossier contenant des sous dossier, copier à la main. Et pour le reste macro.

[djibril]

Oliv pour l'aide. Toute ma messagerie (plus d'1To de données de mails) a été migrée avec beaucoup de soucis liés au logiciel de migration de merde que l'on a acheté. Néanmoins, les macros m'ont permis de corriger pas mal de souci.