Déplacer un message dans un dossier

Version imprimable

26/09/2016, 22h04
nathalie.de

Déplacer un message dans un dossier

Bonjour !

J'ai un petit soucis que je n'arrive pas à régler :

J'ai des 3 messages qui proviennent toujours de la même personnes entre 7h du matin et midi.

Sur ces messages j'ai crée une règle exécutant un script permettant d'extraire les 3 pièces jointes et de les mettre sur mon pc dans un dossier.

jusqu'ici tout marche bien.

Je souhaite ensuite transférer ces messages dans un dossier d'outlook pour les archiver afin que le script ne tourne pas en boucle.

je crée une règle pour ca je sais faire, mais la règle de transfert de message se fait toujours avant celle du script. Du coup le script ne trouve plus les messages. Même si je met la règle de transfert tout à la fin des autres règles.

Je ne trouve pas comment faire pour que la règle du script s'effectue avant celle du transfert.

Si quelqu'un a une idée je suis preneuse !

merci pour votre aide !

Nathalie ;)

Bonjour,
Ajoutes ton déplacement dans ton script.

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
deplacement:
        'on déplace le mail vers un dossier outlook
        If Deplace Then
            Dim myDestFolder As Outlook.MAPIFolder
 
 
 
'sous dossier de BOITE DE RECEPTION
            Set myDestFolder = Application.Session.GetDefaultFolder(olFolderInbox).Folders("toto")
 
'sous dossier au niveau de boite de reception
           Set myDestFolder = Application.Session.GetDefaultFolder(olFolderInbox).Parent.Folders("toto").Folders("ssdossier")
 
 
 
            If Not myDestFolder Is Nothing Then
                MyMail.Move myDestFolder
            Else
                Erreur = Erreur & vbCr & "Email non déplacé :" & DossierMove & " Dossier non trouvé"
            End If
        End If

déplacer un message dans outlook

merci oliv' pour ton aide...

Mais je n'arrive pas à le faire marcher en l’insérant dans mon script. Voici mon script merci pour ton aide !

Code:

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
 
Dim x As Integer
 
 
   'Permet d'extraire toutes les pj de boite de réception dont le nom se termine par xml
Sub ExtrairePjXml(Item As Outlook.MailItem)
    Dim Ol As New Outlook.Application
    Dim Ns As Outlook.NameSpace
    Dim Inbox As MAPIFolder
 
    Set Ns = Ol.GetNamespace("MAPI")
    Set Inbox = Ns.GetDefaultFolder(olFolderInbox)
 
    Dim x As Integer
    Dim y As Integer
    Dim OLmail 'As Outlook.MailItem
    Dim pceJointe As Outlook.Attachment
    Dim SousDossier As Outlook.MAPIFolder
 
    If Inbox.DefaultItemType = 0 Then
        For Each OLmail In Inbox.Items
            If Not OLmail.Attachments.Count = 0 Then
                For y = 1 To OLmail.Attachments.Count
                     Set pceJointe = OLmail.Attachments(y)
                     'pceJointe.SaveAsFile "C:\" & x & "_" & pceJointe
                     If pceJointe.FileName Like "*PROD.NATHALIE*" Then
                        x = x + 1
                        NomDoss = "\\scellius\scellius$\Journaux\" & Format(Date, "ddmmyyyy")
If Dir(NomDoss, vbDirectory) = "" Then MkDir NomDoss 'Créé le dossier s'il nexiste pas
pceJointe.SaveAsFile NomDoss & "\" & pceJointe.FileName
 
                     End If
                    Set pceJointe = Nothing
                Next y
            End If
        Next OLmail
    Else
        MsgBox (Inbox.DefaultItemType)
    End If
 
 Dim myNameSpace As Outlook.NameSpace
 Dim myInbox As Outlook.Folder
 Dim myDestFolder As Outlook.Folder
 Dim myItems As Outlook.Items
 Dim myItem As Object
 
 Set myNameSpace = Application.GetNamespace("MAPI")
 Set myInbox = myNameSpace.GetDefaultFolder(olFolderInbox)
 Set myItems = myInbox.Items
 Set myDestFolder = myInbox.Folders("journaux prod")
 Set myItem = myItems.Find("[SenderName] = 'so_send_journal_fond@sips-atos.com'")
 While TypeName(myItem) <> "Nothing"
 myItem.Move myDestFolder
 Set myItem = myItems.FindNext
 Wend

02/10/2016, 14h52
Oliv-

Salut
Tu as déjà un objet qui désigne ton email en cours de traitement donc tu dois utiliser item.move... Et pas myitem

déplacer un message dans outlook

Merci pour ton aide,

je suis débutante en VB donc pas facile pour moi.

J'ai réussi à faire tourner un script qui effectivement me transfert bien les messages en question dans un dossier Outlook (code ci dessous), mais il est sous forme de module et je ne sais pas comment l’insérer à mon script déjà existant et que je t'avais donné plus haut et qui lui marche très bien avec une règle "d’exécution de script".

Du coup l'autre étant en module si je recrée une autre règle je ne la trouve pas.

Il faudrait que j'arrive à réunir les deux mais je suis trop novice.....
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 Sub script(mail As MailItem) DeplacerMessage "so_send_journal_fond@sips-atos.com", "toto" 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 Set myOlApp = Outlook.Application Set myNamespace = myOlApp.GetNamespace("MAPI") Set myFolder = myNamespace.GetDefaultFolder(olFolderInbox) Set myItems = myFolder.Items Set myRestrictItems = myItems.Restrict("[De] = '" & Nom & "'") For i = myRestrictItems.Count To 1 Step -1 myRestrictItems(i).Move myFolder.Folders(Dossier) Next End Function

Bonjour,
En repartant de ton précédent code tu vas voir c'est assez simple

Code:

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
Dim x As Integer
 
 
   'Permet d'extraire toutes les pj de boite de réception dont le nom se termine par xml
Sub ExtrairePjXml(Item As Outlook.MailItem)
    Dim Ol As New Outlook.Application
    Dim Ns As Outlook.NameSpace
    Dim Inbox As MAPIFolder
 
    Set Ns = Ol.GetNamespace("MAPI")
    Set Inbox = Ns.GetDefaultFolder(olFolderInbox)
 
    Dim x As Integer
    Dim y As Integer
    Dim pceJointe As Outlook.Attachment
 
 
            If Not item.Attachments.Count = 0 Then
                For y = 1 To item.Attachments.Count
                     Set pceJointe = item.Attachments(y)
                     'pceJointe.SaveAsFile "C:\" & x & "_" & pceJointe
                     If pceJointe.FileName Like "*PROD.NATHALIE*" Then
                        x = x + 1
                        NomDoss = "\\scellius\scellius$\Journaux\" & Format(Date, "ddmmyyyy")
If Dir(NomDoss, vbDirectory) = "" Then MkDir NomDoss 'Créé le dossier s'il nexiste pas
pceJointe.SaveAsFile NomDoss & "\" & pceJointe.FileName
 
                     End If
                    Set pceJointe = Nothing
                Next y
            End If
 
 Dim myDestFolder As Outlook.Folder
 
 Set myInbox = NS.GetDefaultFolder(olFolderInbox)
 Set myDestFolder = myInbox.Folders("journaux prod")
Item.Move myDestFolder

Peux tu me confirmer ce que tu cherches à faire ? Ton script tu l'utilises quand ? avec une règle ?

Si oui en principe il doit s'exécuter sur le mail qui arrive et répond aux critères définis.

Précédemment tu lançais ton code à partir d'un email puis tu parcourais tous les Emails de la boite de réception !!

05/10/2016, 11h43
nathalie.de

1 pièce(s) jointe(s)

déplacer un message dans outlook

bonjour !

oui le script je l'utilise avec une règle sur la notion "exécuter un script". Ca marche très bien elle crée bien le dossier voulu avec la date du jour sur mon pc dés l'arrivé des 3 messages du jour. Seulement, si après cette action, je ne transfère pas les messages dans autre dossier, le script tourne en boucle et m'incorpore à chaque fois les pièces jointes dans le même dossier.

Pièce jointe 221949
05/10/2016, 12h35
Oliv-

Bonjour,
Oui c'est normal de la façon dont il était écrit

As tu essayé mon code modifié ?
05/10/2016, 12h39
Oliv-

Il faut bien sûr que ta règle comporte un filtre !

sinon change comme cela à la fin

Code:

if x>0 then Item.Move myDestFolder
05/10/2016, 15h03
nathalie.de

1 pièce(s) jointe(s)

déplacer un message dans outlook

Oui j'ai testé voici l'erreur qui sort :

Pièce jointe 221966

il manque juste la ligne "end sub" à la fin

Code:

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
Dim x As Integer
 
 
   'Permet d'extraire toutes les pj de boite de réception dont le nom se termine par xml
Sub ExtrairePjXml(Item As Outlook.MailItem)
    Dim Ol As New Outlook.Application
    Dim Ns As Outlook.NameSpace
    Dim Inbox As MAPIFolder
 
    Set Ns = Ol.GetNamespace("MAPI")
    Set Inbox = Ns.GetDefaultFolder(olFolderInbox)
 
    Dim x As Integer
    Dim y As Integer
    Dim pceJointe As Outlook.Attachment
 
 x=0
            If Not item.Attachments.Count = 0 Then
                For y = 1 To item.Attachments.Count
                     Set pceJointe = item.Attachments(y)
                     'pceJointe.SaveAsFile "C:\" & x & "_" & pceJointe
                     If pceJointe.FileName Like "*PROD.NATHALIE*" Then
                        x = x + 1
                        NomDoss = "\\scellius\scellius$\Journaux\" & Format(Date, "ddmmyyyy")
If Dir(NomDoss, vbDirectory) = "" Then MkDir NomDoss 'Créé le dossier s'il nexiste pas
pceJointe.SaveAsFile NomDoss & "\" & pceJointe.FileName
 
                     End If
                    Set pceJointe = Nothing
                Next y
            End If
 
 Dim myDestFolder As Outlook.Folder
 
 Set myInbox = NS.GetDefaultFolder(olFolderInbox)
 Set myDestFolder = myInbox.Folders("journaux prod")
if x>0 then Item.Move myDestFolder
end sub

05/10/2016, 17h47
nathalie.de

déplacer un message dans outlook

arf...évidemment c'était tout bêtement indiqué....

Je viens de faire un test ça marche du tonnerre !!! :D

milles mercis pour ton aide !!!!

Au plaisir !

Nathalie