Déplacer un mail dans un "dossier personnel" de mon choix

**Dailyplanet** · 17/10/2008, 16h42

Bonjour,

Dans Outlook 2003 j'ai plusieurs fichiers de données (.pst) qui pointent dans différents "Dossiers personnels".
Lorsque je reçois un mail, j'aimerais qu'il soit automatiquement déplacer dans un "Dossier personnel" de mon choix.

J'ai ce code mais celui-ci déplace uniquement dans le dossier en cours.

Code :

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

1
2
3
4
5
6
7
8
 
    Dim myNameSpace As Outlook.NameSpace
    Dim myInbox As Outlook.MAPIFolder
    Set myNameSpace = objOutlook.GetNamespace("MAPI")
    Set myInbox = myNameSpace.GetDefaultFolder(olFolderInbox)
    Set myDestFolder = myInbox.Folders("test")
    Myentryid = objMail.EntryID
     Set objMail = objMail.Move(myDestFolder)

Avez-vous une solutions ?
Dailyplanet

**Heureux-oli** · 17/10/2008, 20h08

Salut,

Pourquoi le faire en VBA ?

Tu peux créer une règle qui peut très bien le faire.

**Dailyplanet** · 20/10/2008, 11h33

En fait, j'ai une macro (donné par Dolphy35) qui fait bien plus que simplement délacer un Mail.
En plus de ce qu'elle fait, j'aimerai pouvoir déplacer dans un "Dossier personnel" de mon choix qui est rattaché à un fichier de dossiers personnels (.pst).

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
Sub CreationReunion()
'---------------------------------------------------------------------------------------
' Procédure : CreationReunion
' Auteur    : Dolphy35 - http://dolphy35.developpez.com/
' Date      : 16/05/2008
' Détail    : Création d'une nouvelle entrée du calendrier + ajout du texte +
'             ajout raccourci du mail + déplacer dans répertoire "Dossier  d'archivage" à la racine de Boîte aux lettres.
'---------------------------------------------------------------------------------------
'
'Déclaration des objets
 
    Dim objOutlook As Outlook.Application
    Dim objReunion As Outlook.AppointmentItem
    Dim objExplorer As Outlook.Explorer
    Dim objSelection As Outlook.Selection
    Dim objMail As Object
    Dim strMail As String
    Dim strSujet As String
    Dim strDate As String
 
    'Instance des Objets
    Set objOutlook = Outlook.Application    'Instance de l'application
    Set objExplorer = objOutlook.ActiveExplorer
    Set objSelection = objExplorer.Selection
    Set objReunion = objOutlook.CreateItem(olAppointmentItem)  'Instance de la nouvelle entrée du calendrier
 
    'Récupère les infos du mail reçu
    For Each objMail In objSelection
        With objMail
            strMail = .SenderEmailAddress
            strSujet = .Subject
            strDate = .ReceivedTime
        End With
    'Déplacement du mail et création du raccourci
    Dim myNameSpace As Outlook.NameSpace
    Dim myInbox As Outlook.MAPIFolder
    Set myNameSpace = objOutlook.GetNamespace("MAPI")
    Set myInbox = myNameSpace.GetDefaultFolder(olFolderInbox).parent
    Set myDestFolder = myInbox.Folders("Dossier d'archivage")
    Myentryid = objMail.EntryID
    Set objMail = objMail.Move(myDestFolder)
 
    'définition de la réunion
    With objReunion
        .MeetingStatus = olMeeting
        .Subject = strSujet
        .Location = "Mon Bureau"
        .Recipients.Add (strMail)
        .Body = "-selon votre demande du " + strDate + "." + Chr(13) + Chr(13) + "Voici comment traiter ce mail:" + Chr(13) + "-ouvrez ce mail avec Outlook ou https://webmail.heig-vd.ch" + Chr(13) + "-cliquez sur les boutons Accepter/Refuser/etc qui apparaissent en haut à gauche du mail selon votre disponibilité" + Chr(13) + "" + Chr(13) + ""
        .Attachments.Add objMail, olOLE, , objMail.Subject
        .Display
 
        End With
 
    Next
    'Vide des instances
    Set objOutlook = Nothing
    Set objReunion = Nothing
    Set objExplorer = Nothing
    Set objSelection = Nothing
 
End Sub

Dailyplanet

**Oliv-** · 20/10/2008, 14h18

Salut,
il suffit de changer la destination là :

Code :

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

1
2
3
Set myNameSpace = objOutlook.GetNamespace("MAPI")
Set myInbox = myNameSpace.GetDefaultFolder(olFolderInbox).parent
Set myDestFolder = myInbox.Folders("Dossier d'archivage")

par

Code :

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

1
2
3
Set myNameSpace = objOutlook.GetNamespace("MAPI")
Set myInbox = myNameSpace.Folders("Dossiers personnels")
Set myDestFolder = myInbox.Folders("sous dossier")

**Dailyplanet** · 23/10/2008, 15h47

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
Sub CreationReunion()
'---------------------------------------------------------------------------------------
' Procédure : CreationReunion
' Auteur    : Dolphy35 - http://dolphy35.developpez.com/
' Date      : Mai 2008
' Détail    : Création d'une nouvelle entrée du calendrier + ajout du texte +
'             ajout raccourci du mail + déplacer dans répertoire test à la racine
'             de Boîte aux lettres.
'---------------------------------------------------------------------------------------
'Déclaration des objets
 
    Dim objOutlook As Outlook.Application
    Dim objReunion As Outlook.AppointmentItem
    Dim objExplorer As Outlook.Explorer
    Dim objSelection As Outlook.Selection
    Dim objMail As Object
    Dim strMail As String
    Dim strSujet As String
    Dim strDate As String
 
    'Instance des Objets
    Set objOutlook = Outlook.Application    'Instance de l'application
    Set objExplorer = objOutlook.ActiveExplorer
    Set objSelection = objExplorer.Selection
    Set objReunion = objOutlook.CreateItem(olAppointmentItem)  'Instance de la nouvelle entrée du calendrier
 
    'Récupère les infos du mail reçu
    For Each objMail In objSelection
        With objMail
            strMail = .SenderEmailAddress
            strSujet = .Subject
            strDate = .ReceivedTime
        End With
    'Déplacement du mail et création du raccourci
    Dim myNameSpace As Outlook.NameSpace
    Dim myInbox As Outlook.MAPIFolder
    Set myNameSpace = objOutlook.GetNamespace("MAPI")
    Set myInbox = myNameSpace.GetDefaultFolder(olFolderInbox).Parent
    Set myInbox = myNameSpace.Folder("Dossiers personnels")
    Set myDestFolder = myInbox.Folders("sous dossier")
    Myentryid = objMail.EntryID
    Set objMail = objMail.Move(myDestFolder)
 
    'définition de la réunion
    With objReunion
        .MeetingStatus = olMeeting
        .Subject = strSujet
        .Location = "Mon Bureau"
        .Recipients.Add (strMail)
        .Body = "-selon votre demande du " + strDate + "." + Chr(13) + Chr(13) + "Voici comment traiter ce mail:" + Chr(13) + "-ouvrez ce mail avec Outlook ou https://webmail.heig-vd.ch" + Chr(13) + "-cliquez sur les boutons Accepter/Refuser/etc qui apparaissent en haut à gauche du mail selon votre disponibilité" + Chr(13) + "" + Chr(13) + ""
        .Attachments.Add objMail, olOLE, , objMail.Subject
        .Display
 
        End With
 
    Next
    'Vide des instances
    Set objOutlook = Nothing
    Set objReunion = Nothing
    Set objExplorer = Nothing
    Set objSelection = Nothing
 
End Sub

J'ai modifié comme tu me le proposes, j'ai créé Dossiers personnels et sous dossier mais j'ai une erreur à la ligne:

--> Set myInbox = myNameSpace.Folder("Dossiers personnels")

Quelle est mon erreur ?

Dailyplanet

**Oliv-** · 23/10/2008, 16h56

Salut,
ta ligne

Code :

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

Set myInbox = myNameSpace.GetDefaultFolder(olFolderInbox).Parent

n'est pas bonne voir mon post précédent

**Dailyplanet** · 24/10/2008, 09h53

Oups ! là j'était complètement à l'ouest

En plus de la ligne que j'avais oublié de suprimer, il manquait un "s" à:
Set myInbox = myNameSpace.Folders("Dossiers personnels")

Voici le code corrigé pour ceux que ça intéresse:

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
Sub CreationReunion()
'---------------------------------------------------------------------------------------
' Procédure : CreationReunion
' Auteur    : Dolphy35 - http://dolphy35.developpez.com/
' Date      : Mai 2008
' Détail    : Création d'une nouvelle entrée du calendrier + ajout du texte +
'             ajout raccourci du mail + déplacer dans répertoire test à la racine
'             de Boîte aux lettres.
'---------------------------------------------------------------------------------------
'Déclaration des objets
 
    Dim objOutlook As Outlook.Application
    Dim objReunion As Outlook.AppointmentItem
    Dim objExplorer As Outlook.Explorer
    Dim objSelection As Outlook.Selection
    Dim objMail As Object
    Dim strMail As String
    Dim strSujet As String
    Dim strDate As String
 
    'Instance des Objets
    Set objOutlook = Outlook.Application    'Instance de l'application
    Set objExplorer = objOutlook.ActiveExplorer
    Set objSelection = objExplorer.Selection
    Set objReunion = objOutlook.CreateItem(olAppointmentItem)  'Instance de la nouvelle entrée du calendrier
 
    'Récupère les infos du mail reçu
    For Each objMail In objSelection
        With objMail
            strMail = .SenderEmailAddress
            strSujet = .Subject
            strDate = .ReceivedTime
        End With
    'Déplacement du mail et création du raccourci
    Dim myNameSpace As Outlook.NameSpace
    Dim myInbox As Outlook.MAPIFolder
    Set myNameSpace = objOutlook.GetNamespace("MAPI")
    Set myInbox = myNameSpace.Folders("Dossiers personnels")
    Set myDestFolder = myInbox.Folders("sous dossier")
    Myentryid = objMail.EntryID
    Set objMail = objMail.Move(myDestFolder)
 
    'définition de la réunion
    With objReunion
        .MeetingStatus = olMeeting
        .Subject = strSujet
        .Location = "Mon Bureau"
        .Recipients.Add (strMail)
        .Body = "-selon votre demande du " + strDate + "." + Chr(13) + Chr(13) + "Voici comment traiter ce mail:" + Chr(13) + "-ouvrez ce mail avec Outlook ou https://webmail.heig-vd.ch" + Chr(13) + "-cliquez sur les boutons Accepter/Refuser/etc qui apparaissent en haut à gauche du mail selon votre disponibilité" + Chr(13) + "" + Chr(13) + ""
        .Attachments.Add objMail, olOLE, , objMail.Subject
        .Display
 
        End With
 
    Next
    'Vide des instances
    Set objOutlook = Nothing
    Set objReunion = Nothing
    Set objExplorer = Nothing
    Set objSelection = Nothing
 
End Sub

Merci Oliv-
Dailyplanet

**jolinon** · 24/10/2008, 14h13

Salut à vous deux,

[personnelement à Oliv']
______________________________

Je trouve le code très intéressant. et en rapport à ce code voici ma question:

le but de ce code est de sauvegarder automatiquement les mails arrivants dans Outlook dans un dossier personnel préalablement crée. Eh bien il faut si je ne me trompe pas la placer dans le module "ThisOutlokkSession" (ou bien?). Bien mon problème c'est que l'orsque j'ouvre ce module il y a un module qui s'y ajoute automatiquement (D'après le tuto c'est normal!). eh bien vient maintenenat le module NewMail qui est déjà en lui un sub. Comment combiner les deux sub. faut-il placer le sub suivant à l'intérieur du sub NewMail()?

ou alors que faut-il faire ?

je vous en prie aidez-moi. j'en ai bougrement besoin.
J'ai même envoyé un mail à Oliv' sur la question, mais je n'est pas recu de réponse.

cordialement et merci d'avance
Jolion Thierry

**jolinon** · 24/10/2008, 14h16

Faut-il placer le sub:

Sub CreationReunion()

...

End sub

à l'intérieur du Sub:

sub Newmail()

End sub automatiquement crée?

après avoir relu mon texte j'ai remarqué je n'avais peut-être pas été clair

**Dailyplanet** · 24/10/2008, 16h03

Envoyé par jolinon

Faut-il placer le sub:
Sub CreationReunion()
...
End sub
à l'intérieur du Sub:
sub Newmail()
End sub automatiquement crée?
après avoir relu mon texte j'ai remarqué je n'avais peut-être pas été clair

Chez moi le code de mon précédent post fonctionne très bien.
Pourtant "ThisOutlokkSession" est vide.

Concernant ta question, le pro c'est Oliv-. Moi je suis encore que débutant.

Dailyplanet

**Oliv-** · 24/10/2008, 17h23

Envoyé par jolinon

le but de ce code est de sauvegarder automatiquement les mails arrivants dans Outlook dans un dossier personnel préalablement crée. Eh bien il faut si je ne me trompe pas la placer dans le module "ThisOutlokkSession" (ou bien?). Bien mon problème c'est que l'orsque j'ouvre ce module il y a un module qui s'y ajoute automatiquement (D'après le tuto c'est normal!). eh bien vient maintenenat le module NewMail qui est déjà en lui un sub. Comment combiner les deux sub. faut-il placer le sub suivant à l'intérieur du sub NewMail()?

2 Solutions pour traiter automatiquement des mails à leur arrivée

soit utiliser l'évenement dans ThisOutlookSession

Code :

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

1
2
3
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
'ici on met le code voulu ou le nom d'une macro existante
End Sub

soit utiliser les règles (avec éventuellement l'exécution d'un script)

J'ai même envoyé un mail à Oliv' sur la question, mais je n'est pas recu de réponse.

Désolé j'en n'ai pas souvenir, mais j'ai un très bon antispam

**jolinon** · 24/10/2008, 21h40

Salut Oliv'

merci pour la réponse:

Code :

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

1
2
3
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
'ici on met le code voulu ou le nom d'une macro existante
End Sub

Mais le code en question commence avec sub ...

dois-je l'insérer complétement à l'endroit indiqué, si bien que j'ai 2 sub au début:

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
 
Sub Application_NewMailEx(ByVal EntryIDCollection As String)
Sub CreationReunion()
'---------------------------------------------------------------------------------------
' Procédure : CreationReunion
' Auteur    : Dolphy35 - http://dolphy35.developpez.com/
' Date      : Mai 2008
' Détail    : Création d'une nouvelle entrée du calendrier + ajout du texte +
'             ajout raccourci du mail + déplacer dans répertoire test à la racine
'             de Boîte aux lettres.
'---------------------------------------------------------------------------------------
'Déclaration des objets
 
    Dim objOutlook As Outlook.Application
    Dim objReunion As Outlook.AppointmentItem
    Dim objExplorer As Outlook.Explorer
    Dim objSelection As Outlook.Selection
    Dim objMail As Object
    Dim strMail As String
    Dim strSujet As String
    Dim strDate As String
 
    'Instance des Objets
    Set objOutlook = Outlook.Application    'Instance de l'application
    Set objExplorer = objOutlook.ActiveExplorer
    Set objSelection = objExplorer.Selection
    Set objReunion = objOutlook.CreateItem(olAppointmentItem)  'Instance de la nouvelle entrée du calendrier
 
    'Récupère les infos du mail reçu
    For Each objMail In objSelection
        With objMail
            strMail = .SenderEmailAddress
            strSujet = .Subject
            strDate = .ReceivedTime
        End With
    'Déplacement du mail et création du raccourci
    Dim myNameSpace As Outlook.NameSpace
    Dim myInbox As Outlook.MAPIFolder
    Set myNameSpace = objOutlook.GetNamespace("MAPI")
    Set myInbox = myNameSpace.GetDefaultFolder(olFolderInbox).Parent
    Set myInbox = myNameSpace.Folder("Dossiers personnels")
    Set myDestFolder = myInbox.Folders("sous dossier")
    Myentryid = objMail.EntryID
    Set objMail = objMail.Move(myDestFolder)
 
    'définition de la réunion
    With objReunion
        .MeetingStatus = olMeeting
        .Subject = strSujet
        .Location = "Mon Bureau"
        .Recipients.Add (strMail)
        .Body = "-selon votre demande du " + strDate + "." + Chr(13) + Chr(13) + "Voici comment traiter ce mail:" + Chr(13) + "-ouvrez ce mail avec Outlook ou https://webmail.heig-vd.ch" + Chr(13) + "-cliquez sur les boutons Accepter/Refuser/etc qui apparaissent en haut à gauche du mail selon votre disponibilité" + Chr(13) + "" + Chr(13) + ""
        .Attachments.Add objMail, olOLE, , objMail.Subject
        .Display
 
        End With
 
    Next
    'Vide des instances
    Set objOutlook = Nothing
    Set objReunion = Nothing
    Set objExplorer = Nothing
    Set objSelection = Nothing
 
End Sub
End sub

et 2 End à la fin?
Et qu'est-ce que je fais de l'argument "EntryIDCollection " entrée au début?

merci d'avance

**jolinon** · 24/10/2008, 22h09

Salut,

je viens d'essayer le code comme je l'ai expliquer il y a un instant, mais j'ai une erreur:

"End Sub attendu", à l'arrivée d'un nouveau Mail. et après que j'ai cliqué sur debugger, j'obtiens le pointage de l'erreur sur le premier Sub de NewMailEX(...).
Quel est le problème?

merci d'avance

**Oliv-** · 27/10/2008, 09h23

Salut,
ah non c'es pas comme cela, on met juste le nom de la macro secondaire (et les arguments éventuels) dans la macro principale,
ca doit donne run truc comme cela (attention j'ai pas vérifié le fonctionnement)
:

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
public    objMail  As Object
 
Sub Application_NewMailEx(ByVal EntryIDCollection As String)
     Dim intInitial As Integer
    Dim intFinal As Integer
    Dim strEntryId As String
    Dim intLength As Integer
 
    intInitial = 1
    intLength = Len(EntryIDCollection)
    MsgBox "Collection of EntryIds: " & EntryIDCollection
    intFinal = InStr(intInitial, EntryIDCollection, ",")
    Do While intFinal <> 0
        strEntryId = Strings.Mid(EntryIDCollection, intInitial, (intFinal - intInitial))
 
        MsgBox "EntryId: " & strEntryId
        Set objMail = Application.Session.GetItemFromID(strEntryId)
        MsgBox objMail .Subject
CreationReunion
        intInitial = intFinal + 1
        intFinal = InStr(intInitial, EntryIDCollection, ",")
    Loop
    strEntryId = Strings.Mid(EntryIDCollection, intInitial, (intLength - intInitial) + 1)
    MsgBox strEntryId
     Set objMail = Application.Session.GetItemFromID(strEntryId)
    MsgBox objMail .Subject
CreationReunion
 
End sub 
 
Sub CreationReunion()
'---------------------------------------------------------------------------------------
' Procédure : CreationReunion
' Auteur    : Dolphy35 - http://dolphy35.developpez.com/
' Date      : Mai 2008
' Détail    : Création d'une nouvelle entrée du calendrier + ajout du texte +
'             ajout raccourci du mail + déplacer dans répertoire test à la racine
'             de Boîte aux lettres.
'---------------------------------------------------------------------------------------
'Déclaration des objets
 
    Dim objOutlook As Outlook.Application
    Dim objReunion As Outlook.AppointmentItem
    Dim objExplorer As Outlook.Explorer
'    Dim objSelection As Outlook.Selection
'    Dim objMail As Object
    Dim strMail As String
    Dim strSujet As String
    Dim strDate As String
 
    'Instance des Objets
    Set objOutlook = Outlook.Application    'Instance de l'application
    Set objExplorer = objOutlook.ActiveExplorer
'    Set objSelection = objExplorer.Selection
    Set objReunion = objOutlook.CreateItem(olAppointmentItem)  'Instance de la nouvelle entrée du calendrier
 
    'Récupère les infos du mail reçu
           With objMail
            strMail = .SenderEmailAddress
            strSujet = .Subject
            strDate = .ReceivedTime
           End With
    'Déplacement du mail et création du raccourci
    Dim myNameSpace As Outlook.NameSpace
    Dim myInbox As Outlook.MAPIFolder
    Set myNameSpace = objOutlook.GetNamespace("MAPI")
    Set myInbox = myNameSpace.GetDefaultFolder(olFolderInbox).Parent
    Set myInbox = myNameSpace.Folder("Dossiers personnels")
    Set myDestFolder = myInbox.Folders("sous dossier")
    Myentryid = objMail.EntryID
    Set objMail = objMail.Move(myDestFolder)
 
    'définition de la réunion
    With objReunion
        .MeetingStatus = olMeeting
        .Subject = strSujet
        .Location = "Mon Bureau"
        .Recipients.Add (strMail)
        .Body = "-selon votre demande du " + strDate + "." + Chr(13) + Chr(13) + "Voici comment traiter ce mail:" + Chr(13) + "-ouvrez ce mail avec Outlook ou https://webmail.heig-vd.ch" + Chr(13) + "-cliquez sur les boutons Accepter/Refuser/etc qui apparaissent en haut à gauche du mail selon votre disponibilité" + Chr(13) + "" + Chr(13) + ""
        .Attachments.Add objMail, olOLE, , objMail.Subject
        .Display
 
        End With
 
     'Vide des instances
    Set objOutlook = Nothing
    Set objReunion = Nothing
    Set objExplorer = Nothing
 '   Set objSelection = Nothing
 
End Sub

**Dailyplanet** · 27/10/2008, 09h30

Envoyé par Dailyplanet

En fait, j'ai une macro (donné par Dolphy35) qui fait bien plus que simplement délacer un Mail.
En plus de ce qu'elle fait, j'aimerai pouvoir déplacer dans un "Dossier personnel" de mon choix qui est rattaché à un fichier de dossiers personnels (.pst).

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
Sub CreationReunion()
'---------------------------------------------------------------------------------------
' Procédure : CreationReunion
' Auteur    : Dolphy35 - http://dolphy35.developpez.com/
' Date      : 16/05/2008
' Détail    : Création d'une nouvelle entrée du calendrier + ajout du texte +
'             ajout raccourci du mail + déplacer dans répertoire "Dossier  d'archivage" à la racine de Boîte aux lettres.
'---------------------------------------------------------------------------------------
'
'Déclaration des objets
 
    Dim objOutlook As Outlook.Application
    Dim objReunion As Outlook.AppointmentItem
    Dim objExplorer As Outlook.Explorer
    Dim objSelection As Outlook.Selection
    Dim objMail As Object
    Dim strMail As String
    Dim strSujet As String
    Dim strDate As String
 
    'Instance des Objets
    Set objOutlook = Outlook.Application    'Instance de l'application
    Set objExplorer = objOutlook.ActiveExplorer
    Set objSelection = objExplorer.Selection
    Set objReunion = objOutlook.CreateItem(olAppointmentItem)  'Instance de la nouvelle entrée du calendrier
 
    'Récupère les infos du mail reçu
    For Each objMail In objSelection
        With objMail
            strMail = .SenderEmailAddress
            strSujet = .Subject
            strDate = .ReceivedTime
        End With
    'Déplacement du mail et création du raccourci
    Dim myNameSpace As Outlook.NameSpace
    Dim myInbox As Outlook.MAPIFolder
    Set myNameSpace = objOutlook.GetNamespace("MAPI")
    Set myInbox = myNameSpace.GetDefaultFolder(olFolderInbox).parent
    Set myDestFolder = myInbox.Folders("Dossier d'archivage")
    Myentryid = objMail.EntryID
    Set objMail = objMail.Move(myDestFolder)
 
    'définition de la réunion
    With objReunion
        .MeetingStatus = olMeeting
        .Subject = strSujet
        .Location = "Mon Bureau"
        .Recipients.Add (strMail)
        .Body = "-selon votre demande du " + strDate + "." + Chr(13) + Chr(13) + "Voici comment traiter ce mail:" + Chr(13) + "-ouvrez ce mail avec Outlook ou https://webmail.heig-vd.ch" + Chr(13) + "-cliquez sur les boutons Accepter/Refuser/etc qui apparaissent en haut à gauche du mail selon votre disponibilité" + Chr(13) + "" + Chr(13) + ""
        .Attachments.Add objMail, olOLE, , objMail.Subject
        .Display
 
        End With
 
    Next
    'Vide des instances
    Set objOutlook = Nothing
    Set objReunion = Nothing
    Set objExplorer = Nothing
    Set objSelection = Nothing
 
End Sub

Maintenant cette macro fonctionne très bien et est assignée à un bouton.

Ma question: Lorsque je sélectionne un mail, ne serait-il pas possible d'assigner la macro ci-dessus au click droit de ma souris, c-à-d dans le menu contextuel au lieu de l'assigner à un bouton ?

Dailyplanet

**jolinon** · 28/10/2008, 16h47

Ma question: Lorsque je sélectionne un mail, ne serait-il pas possible d'assigner la macro ci-dessus au click droit de ma souris, c-à-d dans le menu contextuel au lieu de l'assigner à un bouton ?

salut, non je ne penses pas, mais je n'esn suis pas sûr.

je pars du principe que les makros sont en fait liès avec Outlook et qu'une assignation hors de Outlook ne serai pas commode.

__________________________________________________________

Merci pour ton code, mais pour une raison ou pour une autre elle ne fonctionne pas sous moi. moi je veux juste pouvoir déplacer un mail qui arrivent vers un dossier

**Oliv-** · 29/10/2008, 09h42

SAlut à Tous,

Jolinon peux tu créer une discussion propre à ton problème car là c'est le bordel on ne sait plus de quel sujet on parle.

je pars du principe que les makros sont en fait liès avec Outlook et qu'une assignation hors de Outlook ne serai pas commode.

je pense qu'il veut un clic droit DANS outlook .

**Dailyplanet** · 30/10/2008, 09h34

Envoyé par Oliv-

je pense qu'il veut un clic droit DANS outlook .

Oui Oliv- c'est exactement cela. Connais-tu la solution ?

Dailyplanet

**Oliv-** · 30/10/2008, 15h40

Salut,

regarde ici ca doit correspondre
http://www.outlookcode.com/threads.a...messageid=3612
Merci de publier ici ton code après.

**HecsS** · 16/12/2008, 16h03

Bonjour,

Je suis en train d'essayer de faire une macro qui s'apparente fortement à celle ci, mais je n'arrive pas a l'adapter a mes dessins :

Je voudrais déplacer le mail en court d'envoi dans un dossier nommé "archive" sans laisser de double dans les "éléments envoyés"....

Les règles outlook permet de déplacer une "copie" dans un dossier mais pas de supprimer l'originale...

J'ai trouvé ce code mais une boite de dialogue apparait pour choisir le dossier, mais je voudrais que se soit automatique dans le dossier "archive".

If Not Item.Class = olMail Then GoTo fin

Dim objNS As NameSpace
Dim objFolder As MAPIFolder

Set objNS = Application.GetNamespace("MAPI")
Set objFolder = objNS.PickFolder
If TypeName(objFolder) = "Nothing" Then
Set objNS = Application.GetNamespace("MAPI")
Set objFolder = objNS.GetDefaultFolder(olFolderDeletedItems)
End If
Set Item.SaveSentMessageFolder = objFolder
fin:

Quelqu'un peu m'aider ?
Merci !

Déplacer un mail dans un "dossier personnel" de mon choix

VBA Outlook

Discussions similaires

Partager

Partager