Déplacer un courriel

**robert.parise** · 08/04/2014, 19h33

Bonjour à tous

Dans ma boite de reception de courriel, j'ai des dossiers classer par entreprise avec lesquelles je travaille et des sous-dossiers de contact dans ces entreprises

Je nomme ces sous-dossiers (contact) selon le nom de l'expéditeur.

Je voudrais semi-automatisé le déplacement des courriels. Par un clic droit, le couriel se déplacerait vers de sous dossier.

J'ai utilisé plusieurs bout de code écrit par "dolphy35" dans l'aide VBA (un gros merci).

Avec le code ci-bas, je suis capable de:
- Déclencher une action par le menu contextuel du clic droit de la souris
- Récupérer le nom de l'expéditeur
- Vérifier si le sous-dossier au nom de l'expéditeur existe

Je bloque sur la dernière partie, le^déplacement du courriel. Merci à l'avance

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
Private Sub Application_ItemContextMenuDisplay( _
        ByVal CommandBar As Office.CommandBar, _
        ByVal Selection As Selection)
 
    Dim objButton As CommandBarButton
    Dim intButtonIndex As Integer
    Dim intCounter As Integer
 
    'Test si 1 seul mail est sélectionné
    If Selection.Count = 1 Then
        'Test si la sélection correspond à un E-mail
        If Selection.Item(1).Class = olMail Then
            Set objButton = CommandBar.Controls.Add( _
                            msoControlButton, , , , True)
            With objButton
                .Style = msoButtonIconAndCaption
                .Caption = "Déplacer le courriel"
                .FaceId = 463
                .OnAction = "Project1.ThisOutlookSession.InfosMail"
            End With
        End If
    End If
 
End Sub
 
Public Sub InfosMail()
 
'Déclarations des objets et variables
    Dim myOlApp As New Outlook.Application
    Dim myOlExp As Outlook.Explorer
    Dim myOlSel As Outlook.Selection
    Dim msg As Outlook.MailItem
    Dim myNamespace As Outlook.NameSpace
    Dim myFolder As Outlook.MAPIFolder
'    Instancie les objets
    Set myOlExp = myOlApp.ActiveExplorer
    Set myOlSel = myOlExp.Selection
    Set msg = myOlSel
    Set myNamespace = myOlApp.GetNamespace("MAPI")
    Set myFolder = myNamespace.GetDefaultFolder(olFolderInbox)
 
'    Boucle permettant de parcourir les pièces jointes une à une
    For Each myItem In myOlSel
        strEXP = myItem.SenderName
        MsgBox strEXP
        Compteur = 0
        EnumerateFoldersInStores
 
'        msg.Move myFolder.folders(strEXP)
'        DeplacerMessage strEXP, strEXP
 
 
    Next
 
'    Vide des objets pour libération de la mémoire
    Set myOlApp = Nothing
    Set myOlExp = Nothing
    Set myOlSel = Nothing
 
End Sub
 
 
Function DeplacerMessage(Nom As String, Dossier As String)
    Dim myOlApp As Outlook.Application
    Dim myNamespace As Outlook.NameSpace
    Dim myFolder As Outlook.MAPIFolder
    Dim myItems As Outlook.Items
    Dim myRestrictItems As Outlook.Items
    Dim myItem As Outlook.MailItem
     Dim myOlExp As Outlook.Explorer
    Dim myOlSel As Outlook.Selection
'    Instancie les objets
    Set myOlExp = myOlApp.ActiveExplorer
    Set myOlSel = myOlExp.Selection
 
    Set myOlApp = Outlook.Application
    Set myNamespace = myOlApp.GetNamespace("MAPI")
    Set myFolder = myNamespace.GetDefaultFolder(olFolderInbox)
    Set myItems = myFolder.Items
 
        myOlSel.Move myFolder.folders(Dossier)
 
End Function
 
 
Sub EnumerateFoldersInStores()
    Dim olApp As New Outlook.Application
    Dim colStores As Outlook.Stores
    Dim oStore As Outlook.Store
    Dim oRoot As Outlook.folder
 
    On Error Resume Next
    Set colStores = olApp.Session.Stores
 
    For Each oStore In colStores
 
        Set oRoot = oStore.GetRootFolder
        Debug.Print (oRoot.FolderPath) 'Affiche la racine du répertoire
        Racine = oRoot                           'Mémorise la racine du répertoire
        EnumerateFolders oRoot           'Appel de la sous procédure
 
     Next
 
    If Compteur = 0 Then
        MsgBox "Le dossier de l'expéditeur n'existe pas.  Le message ne sera pas déplacer"
        Exit Sub
    ElseIf Compteur = 1 Then
        MsgBox "Répertoire trouvé, le courriel sera déplacer"
    ElseIf Compteur > 1 Then
        MsgBox " Il existe plus d'un répertoire au nom de l'expéditeur"
    End If
End Sub
 
 
Private Sub EnumerateFolders(ByVal oFolder As Outlook.folder)
    Dim folders As Outlook.folders
    Dim folder As Outlook.folder
    Dim foldercount As Integer
 
    On Error Resume Next
    Set folders = oFolder.folders
    foldercount = folders.Count
 
    If foldercount Then
 
        For Each folder In folders
            Debug.Print (folder.FolderPath) 'Affiche le chemin du contenu du répertoire (sous-dossier)
            EnumerateFolders folder
 
            If folder Like strEXP Then
               boolverif = False
               Compteur = Compteur + 1
               SsDossier = folder.FolderPath
               Exit Sub
               SsRacine = Racine
            End If
        Next
 
   End If
End Sub

Merci à l'avance

Robert

**Oliv-** · 09/04/2014, 10h53

Bonjour,
Travailles tu avec plusieurs BAL, au même niveau que ta BAL principale (exchange ou PST) ?

Je pense que tu dois recentrer ta macro EnumerateFoldersInStores pour ne chercher ton dossier que dans ta boite principale, idéalement dans le dossier qui regroupe tous les entreprise (à moins qu'ils ne soient à la racine)

Après le problème c'est que si tu trouves le nom (attention à la casse) tu ne renvois pas la valeur de
SsDossier = folder.FolderPath

Tu dois soit créer une fonction soit changer la portée de ta varaible en la mettant en public par exemple.

edit je pense que tu as omis de publier les déclarations de variables

il manque de la cohésion entre tes procédures, mais tu n'es pas loin.

edit:
Que fais tu des doublons de SenderName ? ta procédure ne te le dira pas telle quelle à cause du exit sub dans la boucle de recherche du folder.

Essaye ainsi

DANS ThisOUTLOOKSession

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
 
Private Sub Application_ItemContextMenuDisplay( _
        ByVal CommandBar As Office.CommandBar, _
        ByVal Selection As Selection)
 
    Dim objButton As CommandBarButton
    Dim intButtonIndex As Integer
    Dim intCounter As Integer
 
    'Test si 1 seul mail est sélectionné
    If Selection.Count = 1 Then
        'Test si la sélection correspond à un E-mail
        If Selection.Item(1).Class = olMail Then
            Set objButton = CommandBar.Controls.add( _
                            msoControlButton, , , , True)
            With objButton
                .Style = msoButtonIconAndCaption
                .Caption = "Déplacer le courriel¤"
                .FaceId = 463
                .OnAction = "InfosMail" '"Project1.ThisOutlookSession.InfosMail"
            End With
        End If
    End If
 
End Sub

Dans un 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
Public strEXP As String
Public SsDossier As String
Public DossierCible As Outlook.folder
Public Compteur As Integer
 
'End Sub
 
Public Sub InfosMail()
 
'Déclarations des objets et variables
    Dim myOlApp As New Outlook.Application
    Dim myOlExp As Outlook.Explorer
    Dim myOlSel As Outlook.Selection
    Dim msg As Outlook.MailItem
    Dim myNamespace As Outlook.NameSpace
    Dim RacineFolder As Outlook.MAPIFolder
'    Instancie les objets
    Set myOlExp = myOlApp.ActiveExplorer
    Set myOlSel = myOlExp.Selection
    'Set msg = myOlSel
    Set myNamespace = myOlApp.GetNamespace("MAPI")
    Set RacineFolder = myNamespace.GetDefaultFolder(olFolderInbox).Parent
 
   racine = RacineFolder.FolderPath                           'Mémorise la racine du répertoire
 
 
 
'    Boucle permettant de parcourir les ITEM un à un mais n'est pas utile pour le clic droit qui ne se déclenche que si 1 seul élement est selectionné
    For Each myItem In myOlSel
        strEXP = myItem.SenderName
        MsgBox strEXP
        Compteur = 0
    SsDossier = ""
    Set DossierCible = Nothing
 
                EnumerateFolders RacineFolder           'Appel de la sous procédure
 
 
    If Compteur = 0 Then
        MsgBox "Le dossier de l'expéditeur n'existe pas.  Le message ne sera pas déplacer"
        Exit Sub
    ElseIf Compteur = 1 Then
        MsgBox "Répertoire trouvé, le courriel sera déplacé"
        myItem.Move DossierCible
 
 
    ElseIf Compteur > 1 Then  ' ne peut pas arriver avec le exit sub
        MsgBox " Il existe plus d'un répertoire au nom de l'expéditeur"
    End If
 
 
 
 
    Next
 
'    Vide des objets pour libération de la mémoire
    Set myOlApp = Nothing
    Set myOlExp = Nothing
    Set myOlSel = Nothing
 
End Sub
 
 
 
 
Private Sub EnumerateFolders(ByVal oFolder As Outlook.folder)
    Dim folders As Outlook.folders
    Dim folder As Outlook.folder
    Dim foldercount As Integer
 
    On Error Resume Next
    Set folders = oFolder.folders
    foldercount = folders.Count
 
    If foldercount Then
 
        For Each folder In folders
            Debug.Print (folder.FolderPath) 'Affiche le chemin du contenu du répertoire (sous-dossier)
 
            If MajusculesSansAccent(strEXP) = MajusculesSansAccent(folder.Name) Then
               boolverif = False
               Compteur = Compteur + 1
               Set DossierCible = folder
               SsDossier = folder.FolderPath
               Exit Sub
 
            Else:
            EnumerateFolders folder
 
            End If
        Next
 
   End If
End Sub
 
Function MajusculesSansAccent(MyString As String) As String
    Dim accent
    Dim ssaccent
    Dim temp
 
    accent = "ÀÁÂÃÄÅÇÈÉÊËÌÍÎÏÑÒÓÔÕÖÙÚÛÜÝàáâãäåçèéêëìíîïðñòóôõöùúûýÿ"
    ssaccent = "AAAAAACEEEEIIIINOOOOOUUUUYAAAAAACEEEEIIIIONOOOOOUUUYY"
 
    If Len(accent) <> Len(ssaccent) Then
        MsgBox "erreur de paramétrage"
        Exit Function
    End If
 
            temp = MyString
            For i = 1 To Len(accent)
                temp = Replace(temp, Mid(accent, i, 1), Mid(ssaccent, i, 1))
            Next i
            MajusculesSansAccent = UCase(temp)
 
End Function

**robert.parise** · 11/04/2014, 15h22

Merci beaucoup, ca fonctionnne NICKEL!!!

Merci

Déplacer un courriel

VBA Outlook

Discussions similaires

Partager

Partager