[ OL-2010 ] Exécution macro réception mail

**Radack08** · 12/09/2017, 11h52

Bonjour à tous,

Voilà, un client possède un fax to mail, initialement tout cela arrivait sur un poste XP et fonctionnait correctement, le client par précaution la machine XP donnant des signes de faiblesses a voulu déplacer sur un poste Seven avec Outlook 2010.

N'y connaissant rien en DEV et la personne ayant créé cette routine n'étant plus joignable ... j'ai simplement recopié la macro du poste XP et je l'ai copié sur le poste Seven.

Celle-ci est censée lorsqu'un mail arrive, extraire la pièce jointe dans un dossier, et déplacer le mail dans les éléments supprimés.

Il y a donc une règle qui est censée s’exécuter quand un mail arrive qui est créé telle quelle :

S'applique à la réception d'un message
Venant de "xxx@zzz.fr"
Exécuter le script "xxx"

Cela marche mais le problème est que cela s’exécute avec un mail de décalage ... je m'explique imaginons la boite mail est vide, si je reçois un mail, il ne se passe rien, lors de la réception d'un autre mail la macro s'exécute pour le premier mail mais pas pour le second .. et ainsi de suite ..

Savez-vous d'où peut provenir se problème ?

Voici le code de la macro en question :

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
Sub Macro_Extraction_PJ()
 
'***********************************************
'* This script gets Outlook email attachements *
'* and saves them into a specified directory.  *
'*_____________________________________________*
'*          By Philippe Heiz, 2003.           *
'***********************************************
 
'---------------------------------
' CHANGE THE FOLLOWING SETTINGS
'---------------------------------
 
Outlook_Archive = "Dos_perso"
Outlook_Folder = "Boîte de réception"
Outlook_SubFolder1 = ""
Outlook_SubFolder2 = ""
Outlook_SubFolder3 = ""
 
Subject_InStr = ""
Get_All_Files = True
Delete_Mail = True
 
Target_Folder = "C:\fax_mail\recept\"
Target_File_Name = ""
 
Log_File_Long_Name = "C:\fax_mail\log.txt"
 
'---------------------------------
' DO NOT CHANGE THE FOLLOWING CODE
'---------------------------------
 
    cpt = 0
    Set objOutlook = CreateObject("Outlook.Application")
    Set objFolder = objOutlook.GetNamespace("MAPI").Folders(Outlook_Archive)
 
    If Not Log_File_Long_Name = "" Then Set objFSO = CreateObject("Scripting.FileSystemObject")
    If Not Log_File_Long_Name = "" Then Set objLog = objFSO.CreateTextFile(Log_File_Long_Name)
    If Not Log_File_Long_Name = "" Then objLog.WriteLine Now()
    If Not Log_File_Long_Name = "" Then objLog.WriteLine "-------------------------"
 
    On Error Resume Next
    For i = 0 To 3
    Select Case i
    Case 0
        If Not Outlook_Folder = "" Then
            Set objFolder = objFolder.Folders(Outlook_Folder)
        Else
            Exit For
        End If
    Case 1
        If Not Outlook_SubFolder1 = "" Then
            Set objFolder = objFolder.Folders(Outlook_SubFolder1)
        Else
            Exit For
        End If
    Case 2
        If Not Outlook_SubFolder2 = "" Then
            Set objFolder = objFolder.Folders(Outlook_SubFolder2)
        Else
            Exit For
        End If
    Case 3
        If Not Outlook_SubFolder3 = "" Then
            Set objFolder = objFolder.Folders(Outlook_SubFolder3)
        Else
            Exit For
        End If
    End Select
    Next
 
    If Not Err.Number = 0 Then
    If Not Log_File_Long_Name = "" Then objLog.WriteLine "ERROR: Outlook archive path is not valid:"
    If Not Log_File_Long_Name = "" Then objLog.WriteLine Chr(9) & "Outlook_Archive =" & Chr(9) & Outlook_Archive
    If Not Log_File_Long_Name = "" Then objLog.WriteLine Chr(9) & "Outlook_Folder =" & Chr(9) & Outlook_Folder
    If Not Log_File_Long_Name = "" Then objLog.WriteLine Chr(9) & "Outlook_SubFolder1 =" & Chr(9) & Outlook_SubFolder1
    If Not Log_File_Long_Name = "" Then objLog.WriteLine Chr(9) & "Outlook_SubFolder2 =" & Chr(9) & Outlook_SubFolder2
    If Not Log_File_Long_Name = "" Then objLog.WriteLine Chr(9) & "Outlook_SubFolder3 =" & Chr(9) & Outlook_SubFolder3
    If Not Log_File_Long_Name = "" Then objLog.WriteLine "-------------------------"
    Exit Sub
    End If
    On Error GoTo 0
 
    Set objItems = objFolder.Items
    For mailIndex = objItems.Count To 1 Step -1
        'On Error Resume Next
        Set objMailItem = objItems.Item(mailIndex)
        If objMailItem.Attachments.Count > 0 Then
            If Not InStr(1, objMailItem.Subject, Subject_InStr, 1) = 0 Then
                If Not Log_File_Long_Name = "" Then objLog.WriteLine objMailItem.Subject
 
        On Error Resume Next
                If Get_All_Files Then
                    For i = 1 To objMailItem.Attachments.Count
                        Set PJ = objMailItem.Attachments.Item(i)
                        PJ.SaveAsFile Target_Folder & PJ.DisplayName
                        If Not Log_File_Long_Name = "" Then objLog.WriteLine Chr(9) & PJ.DisplayName
                        cpt = cpt + 1
                    Next
                Else
                    Set PJ = objMailItem.Attachments.Item(1)
                    If Target_File_Name = "" Then Target_File_Name = PJ.DisplayName
                    PJ.SaveAsFile Target_Folder & Target_File_Name
                    If Not Log_File_Long_Name = "" Then objLog.WriteLine Chr(9) & PJ.DisplayName
                    cpt = cpt + 1
                End If
                If Not Err.Number = 0 Then
            If Not Log_File_Long_Name = "" Then objLog.WriteLine "ERROR: Target path is not valid:"
            If Not Log_File_Long_Name = "" Then objLog.WriteLine Chr(9) & Target_Folder
            If Not Log_File_Long_Name = "" Then objLog.WriteLine "-------------------------"
                Exit Sub
        End If
        On Error GoTo 0
 
                If Delete_Mail Then objMailItem.Delete
            End If
        End If
    Next
 
    If Not Log_File_Long_Name = "" Then objLog.WriteLine "-------------------------"
    If Not Log_File_Long_Name = "" Then objLog.WriteLine cpt & " attachment(s) treated"
End Sub

Merci beaucoup.

Invité · 13/09/2017, 05h41

Envoyé par Radack08

Bonjour,

Modifiez peut-être votre boucle For MailIndex (sans garantie) :

Code :

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

1
2
3
4
5
 
  Set objItems = objFolder.Items
    For mailIndex = objItems.Count To 1 Step -1
        'On Error Resume Next
        Set objMailItem = objItems.Item(mailIndex)

En :

Code :

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

1
2
3
4
5
 
  Set objItems = objFolder.Items
    For mailIndex = objItems.Count-1 To 0 Step -1
        'On Error Resume Next
        Set objMailItem = objItems.Item(mailIndex)

**Oliv-** · 13/09/2017, 11h14

Bonjour,
Je ne pense pas que le code publié puisse être utilisé comme script ! as tu modifié ce code ?

il devrait comportait un argument comme
Sub regle_exportPJ(Mail As Outlook.MailItem)
Call ExportSuppression_PJ_V2(Mail, True, True, False, "c:\temp\newexportmsg", True, "\\maboite\Boîte de réception\Test", True)
End Sub

voici une routine qui fait cela très bien

https://www.developpez.net/forums/bl...yperlien-mail/

**Radack08** · 13/09/2017, 11h50

Bonjour,

Je n'ai rien modifié du tout, je n'ai aucune compétence dans ce domaine malheureusement :/

Merci beaucoup pour le lien du coup je dois juste reprendre le code que tu as donné et y ajouter :

Classement du mail dans un Dossier OUTLOOK différent -->Deplace:=true en renseignant le dossier DossierMove ="C:\temp\"

Afin de faire à la réception d'un mail

Extraction PJ dans un dossier ( c:\fax_mail\Recept )
Déplacement vers les éléments supprimés

Comment intégré le déplacement à ce script ?

Merci beaucoup

**Oliv-** · 13/09/2017, 15h42

Sur l'ancien poste qu'est ce qui était noté dans la règle pour la valeur de XXX ?

"Exécuter le script "xxx""

La macro ne se charge pas que de traiter le dernier mail , mais en principe elle parcourt tous les Emails de la boite !

Est ce que ces Emails/fax on un sujet vide ?

edit : est ce que la boite se nomme Dos_perso ? ou alors il faut traiter la boite de reception par defaut ?

**Radack08** · 13/09/2017, 15h48

Pareil que sur le poste actuel c'est à dire "Projet 1.Extraction.PJ"

Voici un screen du mail type reçu :

Merci beaucoup de ton aide

edit : il n'y a qu'une boite de configuré sur le poste, celle du fax et la boite s'appelle effectivement dos_perso ( aucune idée pourquoi elle a été renommé ainsi ^^ )

edit 2 : j'ai dit une connerie, il y a deux boites mails de configurées mais la boite concernée reste dos_perso

**Oliv-** · 13/09/2017, 15h57

donc tu dois avoir une macro dans un module Extraction qui se nomme "PJ"

**Oliv-** · 14/09/2017, 15h06

Bon je confirme le phénomène sur OL2010, le mail qui déclenche la règle n'est pas traité par une macro qui parcourerait tous les items de la boite de réception, c'est comme s'il n'était pas encore là !

Donc il faut traiter le mail arrivant et éventuellement traiter les autres Emails qui répondent aux critères et qui seraient encore dans la BAL.

Le code a été développé de la sorte sans doute à cause d'une contrainte de OUTLOOK 2003 c'est bien ce programme qui était sur ton XP ?

Mais de toute façon un script qui s’exécute via une règle comporte un argument ITEM

Code :

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

Sub Extraction_PJ(Item As Outlook.MailItem)

donc en principe on utilise cet OBJET "ITEM" qui est le mail arrivé, pour traiter ce mail t ainsi de suite avec les suivants.

**Radack08** · 14/09/2017, 15h14

Effectivement on dirait que lorsqu'un mail arrive la macro ne s'applique pas sur lui ... même lorsque je rajoute à la règle de déplacer dans un dossier spécifique avant l’exécution de la macro, le mail va bien dans le dossier mais la macro .. nada.

Oui c'est bien Outlook 2003 qu'il y a sur le poste XP. Le code n'est donc plus valable ?

**Oliv-** · 14/09/2017, 15h31

Voici comment il devrait être

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
Sub Extraction_PJ(Item As Outlook.MailItem)
 
'***********************************************
'* This script gets Outlook email attachements *
'* and saves them into a specified directory.  *
'*_____________________________________________*
'*          By Philippe Heiz, 2003.           *
'*   update Oliv'   2017                      *
'***********************************************
 
    '---------------------------------
    ' CHANGE THE FOLLOWING SETTINGS
    '---------------------------------
 
    Subject_InStr = ""
    Get_All_Files = True
    Delete_Mail = True
 
    Target_Folder = "C:\fax_mail\recept\"
 
    Target_File_Name = ""
    Log_File_Long_Name = "C:\fax_mail\log.txt"
 
 
    '---------------------------------
    ' DO NOT CHANGE THE FOLLOWING CODE
    '---------------------------------
 
    Cpt = 0
 
    If Not Log_File_Long_Name = "" Then Set objFSO = CreateObject("Scripting.FileSystemObject")
    If Not Log_File_Long_Name = "" Then Set objLog = objFSO.CreateTextFile(Log_File_Long_Name)
    If Not Log_File_Long_Name = "" Then objLog.WriteLine Now()
    If Not Log_File_Long_Name = "" Then objLog.WriteLine "-------------------------"
 
 
    'On Error Resume Next
    If Item.Attachments.Count > 0 Then
        If Not InStr(1, Item.Subject, Subject_InStr, 1) = 0 Then
            If Not Log_File_Long_Name = "" Then objLog.WriteLine Item.Subject
 
            On Error Resume Next
            For i = 1 To Item.Attachments.Count
                Set PJ = Item.Attachments.Item(i)
                PJ.SaveAsFile Target_Folder & PJ.DisplayName
                If Not Log_File_Long_Name = "" Then objLog.WriteLine Chr(9) & PJ.DisplayName
                Cpt = Cpt + 1
            Next
            If Delete_Mail Then Item.Delete
 
        End If
    End If
    If Not Log_File_Long_Name = "" Then objLog.WriteLine "-------------------------"
    If Not Log_File_Long_Name = "" Then objLog.WriteLine Cpt & " attachment(s) treated"
    Set objLog = Nothing
    On Error GoTo 0
 
End Sub

**Radack08** · 14/09/2017, 16h18

Ça marche nickel je te remercie beaucoup !

[ OL-2010 ] Exécution macro réception mail

VBA Outlook

Discussions similaires

Partager

Partager