Discussion :

[ThierryP73]

Bonjour à tou(te)s,

Après une recherche moyennement fructueuse, je viens chercher un peu d'aide !
Comme beaucoup, je cherche à déplacer (et non copier) certains messages après envoi, selon le destinataire. J'ai trouvé les macros qui vont (à peu près) bien, mais il me reste deux trois trucs à modifier :
- Une copie de l'Email est placée dans Eléments envoyés : je voudrais la supprimer, mais là je sèche un peu pour trouver le message (forcément c'est le plus récent dans cette boîte mais je connais pas la syntaxe)
- Le message est bien placé dans le dossier souhaité (suivant le destinataire), mais il a le statut "non lu". Comment le passer à "lu" ?

Merci d'avance à toutes les âmes charitables qui se pencheront sur mon souci !

ThierryP

[Oliv-]

Bonjour,
Ce code doit fonctionner

http://outlook.developpez.com/faq/?p...A_Deplace_mail

[ThierryP73]

Bonjour Oliv'

ça tombe bien, le code que j'ai trouvé (parmi d'autres !) est signé Oliv', tu ne pouvais pas mieux tomber

En adaptant et en mixant ton code et d'autres, j'en suis là :

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
 
Private Sub Application_ItemSend(ByVal Message As Object, Cancel As Boolean)
Dim objNS As NameSpace
Dim objFolder As MAPIFolder
Dim FldDossier As Outlook.Folder
If Not Message.Class = olMail Then GoTo fin
Set objNS = Application.GetNamespace("MAPI")
Set FldDossier = objNS.GetDefaultFolder(olFolderSentMail)
'If IsEmpty(Message.Subject) Then MsgBox "Vide" Else MsgBox Message.Subject
Select Case UCase(Message.Recipients(1).Address)
    Case "TRUCMUCHE@MACHIN.FR"
        Nbre = FldDossier.Items.Count
        Set objFolder = "\\monadresse@mondomaine.com\Personnel\Envoi"
        'MsgBox objFolder.FolderPath
        'Message.Move objFolder
        Message.SaveSentMessageFolder = objFolder
        FldDossier.Items(Nbre).Delete
    Case Else
        MsgBox "On ne fait rien"
End Select
fin:
End Sub

Autant je me débrouille avec le VBA pour Excel, autant je ne connais pas grand-chose au fonctionnement d'Outlook.... Donc je bute sur :
- Message.Move : "Incompatibilité de type"
- Message.SaveSent... : "Echec de l'opération"
Je suppose que Message est mal déclaré ?
A quel moment le message est-il copié dans les Eléments envoyés ? Mon Items.Count compte trop tôt, le message en cours d'envoi n'y est pas encore, mais je ne vois pas d'autre évènement utilisable.

D'avance merci du retour,

ThierryP

[Oliv-]

Il n'y a pas besoin de mélanger trop de chose pour y arriver

il n'y a pas de move ou de delete à faire

Avant l'envoi on défini où classer la copie de l’élément envoyé avec .SaveSentMessageFolder

il faut bien sûr que .DeleteAfterSubmit = False

c'est l'équivalent dans l'onglet Options de ton message de "Enregistrer l’élément envoyé dans" / "Ne pas enregistrer"

Une fois envoyé Outlook va mettre la copie dans le dossier choisi.


Lorsque l'on choisi le dossier de destination celui-ci doit exister.


ICI un code plus complet, il ne regarde pas le destinataire mais un élément du sujet mais c'est transposable

attention à l'odre d'ajout des destinataires

Message.Recipients(1).Address désigne le premier destinataire, qui n'est pas forcément dans A

[ThierryP73]

Merci pour le retour !

ça va presque aussi vite qu'au bon vieux temps du MPFE !!!

Je vais éplucher tout ça, je devrais pouvoir m'en sortir.... sinon, je sais où m'adresser

ThierryP

[ThierryP73]

Effectivement, quand j'applique ton code, ça fonctionne.

D'où une dernière question :

Quelle est la syntaxe pour définir le chemin du dossier où copier le message ?
En supposant que le dossier s'appelle "Envoi" et que c'est un sous-dossier de "Personnel" :
si je fais un MsgBox objFolder.FolderPath, il me renvoie : \\monadresse@mondomaine.com\Personnel\Envoi mais la ligne :
Set Item.SaveSentMessageFolder = "\\monadresse@mondomaine.com\Personnel\Envoi"
me renvoie une erreur....
et je voudrais définir dans ma macro les chemins sans passer par le PickFolder

Merci d'avance !

ThierryP

[Oliv-]

Voici un exemple

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
13
14
Sub modele_dossiers()
Dim objFolder As Outlook.Folder
Dim myNamespace As Outlook.NameSpace
Dim myInbox, DossierRacine, SousDossier
 Set myNamespace = Application.GetNamespace("MAPI")
 
'dossier boite de reception
Set myInbox = myNamespace.GetDefaultFolder(olFolderInbox)
Set SousDossier = myInbox.Folders("TESTS")
 
Set DossierRacine = myInbox.Parent
Set objFolder = DossierRacine.Folders("Dossiers").Folders("adwords")
 
End Sub

si tu utilises la fonction suivante tu pourras trouver et créer le dossier s'il n'existe pas et l'utiliser un peu comme tu l'avais écris

Code :

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

Set objFolder = GetFolderByPath("\\monadresse@mondomaine.com\Personnel\Envoi", True)(

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
Function GetFolderByPath(ByVal FolderPath As String, Optional CreateSubFolders As Boolean) As Outlook.Folder
'---------------------------------------------------------------------------------------
' Procedure : GetFolderByPath
' Author    : Diane Poremsky
' Modified by : Oliv
' Date      : 20/10/2016
' Purpose   : Obtenir un dossier OL à partir de son chemin en créant au besoin les sous-dossiers
'---------------------------------------------------------------------------------------
'
    Dim oFolder As Outlook.Folder
    Dim FoldersArray As Variant
    Dim i As Integer
    Dim ParentFolder As Folder
 
    On Error GoTo GetFolderByPath_Error
    If Left(FolderPath, 2) = "\\" Then
        FolderPath = Right(FolderPath, Len(FolderPath) - 2)
    End If
    FoldersArray = Split(FolderPath, "\")
    Set oFolder = Application.Session.Folders.item(FoldersArray(0))
    If Not oFolder Is Nothing Then
        On Error Resume Next
        For i = 1 To UBound(FoldersArray, 1)
            Dim SubFolders As Outlook.Folders
            Set SubFolders = oFolder.Folders
            Set ParentFolder = SubFolders.item(FoldersArray(i))
            If ParentFolder Is Nothing Then
                If CreateSubFolders Then
                    Set ParentFolder = SubFolders.add(FoldersArray(i))
                Else
                    Set GetFolderByPath = Nothing
                    Exit Function
                End If
            End If
            Set oFolder = SubFolders.item(FoldersArray(i))
            If oFolder Is Nothing Then
                Set GetFolderByPath = Nothing
                Exit Function
            End If
            Set ParentFolder = Nothing
        Next
    End If
    Set GetFolderByPath = oFolder
    Exit Function
 
GetFolderByPath_Error:
    Set GetFolderByPath = Nothing
    Resume
    Exit Function
End Function

[ThierryP73]

Je n'avais pas vu ton dernier post.... et entre-temps, j'ai trouvé la syntaxe que tu m'as donnée !

Encore un gros merci pour ton coup demain, je vais pouvoir m'amuser ;o)

ThierryP