Discussion :

[Grim971]

Bonjour,

Je bloque sur la création d'un fichier de sauvegarde de mes mails (PST) contenant un dossier outlook et ses sous-dossiers.

Voilà exactement ce que je souhaite faire :
1 - Exporter les mails contenus dans le dossier et les sous-dossiers vers un PST.
2- Supprimer dans outlook le dossier, les sous-dossiers et les mails qui viennent d'être enregistrés dans le PST.

J'étais parti sur ce bout de code, avec comme variable :

pathNomExport correspondant au chemin de sauvegarde de mon PST (par exemple : C:\mondossier.pst )
FolderTrouve correspondant au dossier sous outlook (par exemple : ns.Folders(1).Folders(2016)


Merci et bonne soirée,

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
 
   Dim strFileName As String, strDisplayName As String
   Dim objOutlook As Outlook.Application, objNS As Outlook.NameSpace
   Dim myMail As Outlook.MAPIFolder
   Dim myDestFolder As Outlook.MAPIFolder
   Dim myItems As Items, myItem As Object
   Dim myFolder As Outlook.MAPIFolder
   Dim sSentFrom As String, i As Integer
 
   On Error Resume Next
   Set objOutlook = GetObject(, "Outlook.Application")
   If Err.Number <> 0 Then Set objOutlook = CreateObject("Outlook.Application")
 
        '------------------------------------------------
        'Create New PST folder
        '------------------------------------------------
        Set objNS = objOutlook.GetNamespace("MAPI")
        objNS.AddStore pathNomExport
        Set objFolder = FolderTrouve
        strDisplayName = objFolder.Name
        objNS.RemoveStore objFolder ' Step 1 to refresh folder tree view
        objNS.AddStore pathNomExport ' Step 2 to refresh folder tree view
 
        '------------------------------------------------
        'Move mail items to new PST.
        '------------------------------------------------
        Set myMail = FolderTrouve
        Set myItems = myMail.Items
        Set myDestFolder = objNS.Folders.pathNomExport
        myDestFolder.Name = strDisplayName
 
        'Loop through all items in sent items box.
        'For i = myItems.Count To 1 Step -1
        For i = myItems.Count To 0 Step -1
            Set myItem = myItems(i)
            myItem.Move myDestFolder
        Next
 
   Set objOutlook = Nothing
   Set objNS = Nothing
   Set objFolder = Nothing
   Set mySent = Nothing
   Set myDestFolder = Nothing

[Oliv-]

Bonjour,

Si tu veux déplacer tout un dossier tu peux faire

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
 
 
Const PathNomExport = "c:\temp\test3pst.pst"
Sub test()
 
    Dim strFileName As String, strDisplayName As String
    Dim objOutlook As Outlook.Application, objNS As Outlook.NameSpace
    Dim myMail As Outlook.MAPIFolder
    Dim myDestFolder As Outlook.MAPIFolder
    Dim myItems As Items, myItem As Object
    Dim myFolder As Outlook.MAPIFolder
    Dim sSentFrom As String, i As Integer
 
    On Error Resume Next
    Set objOutlook = GetObject(, "Outlook.Application")
    If Err.Number <> 0 Then Set objOutlook = CreateObject("Outlook.Application")
 
    '------------------------------------------------
    'Create New PST folder
    '------------------------------------------------
    Set objNS = objOutlook.GetNamespace("MAPI")
    objNS.AddStore PathNomExport
    Set objFolder = objNS.Folders.GetLast
 
 
    Set FolderTrouve = objNS.PickFolder
    strDisplayName = FolderTrouve.NAme
 
    'pour changer le nom affiché du PST
    objFolder.NAme = strDisplayName
    objNS.RemoveStore objFolder    ' Step 1 to refresh folder tree view
    objNS.AddStore PathNomExport    ' Step 2 to refresh folder tree view
 
    '        '------------------------------------------------
    '        'Move mail items to new PST.
    '        '------------------------------------------------
    '        Set myMail = FolderTrouve
    '        Set myItems = myMail.Items
    '        Set myDestFolder = objNS.Folders.PathNomExport
    '        myDestFolder.NAme = strDisplayName
    '
    '        'Loop through all items in sent items box.
    '        'For i = myItems.Count To 1 Step -1
    '        For i = myItems.Count To 0 Step -1
    '            Set myItem = myItems(i)
    '            myItem.Move myDestFolder
    '        Next
 
    'MOVE FOLDER
    On Error GoTo 0
    FolderTrouve.MoveTo objFolder
 
    Set objOutlook = Nothing
    Set objNS = Nothing
    Set objFolder = Nothing
    Set mySent = Nothing
    Set myDestFolder = Nothing
End Sub

[Grim971]

Merci cela fonctionne super.