Bonjour à tou(te)s,

Le script ci-dessous copie les pièces jointes d'une boîte de réception (qui n'est pas celle par défaut) vers un dossier en omettant celles embarquées de type image, puis envoi un rapport des pièces jointes déplacées par mail avant de déplacer les mails en question vers un autre dossier de cette boîte.

Mon problème est le suivant, lorsque j'exécute manuellement le script ci dessous (Règles; Gérer les règles; Bouton "Exécuter une règle"; Bouton "Exécuter") tout fonctionne parfaitement. Mais en automatique, soit le script ne s'exécute pas à l'arrivée d'un nouveau message, ou il s"exécute s'il y a déjà un mail dans la boîte de réception (ce qui n'est pas toujours le cas), aussi il est difficile de trouver une logique du problème.

En espérant que vous pourrez m'aider car ce script doit (devrait) être en Prod prochainement.
Dans tous les cas, Merci d'avance de votre aide.

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
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
 
Sub Execute(Mail As MailItem)
 
Archive_Outlook_eMails_To_Backup_PST_Folder
 
End Sub
 
 
Sub Archive_Outlook_eMails_To_Backup_PST_Folder()
 
 
Dim Items As Outlook.Items
Dim Item As Object
 
Set Items = GetFolderPath("toto@france.com\bzh").Items
 
   SaveAttachement
   report
 
    Dim FldBdr As Outlook.MAPIFolder
    Dim Fldbzh As folder
    Dim Fld As folder
    Dim Message As Outlook.MailItem
    Dim MailItem As Outlook.MailItem
    Dim MailsCount As Double, NumberOfDays As Double
    Dim ns As Outlook.NameSpace
 
     For Each Fld In Outlook.Session.Folders
      If Fld.Name Like "toto@france.com" Then
         Set Fldbzh = Fld.Folders("bzh")
         Set FldBdr = Fld.Folders("Boîte de réception")
         Exit For
      End If
   Next Fld
 
    Set ns = Application.GetNamespace("MAPI")
 
    NumberOfDays = 0
 
 
    MailsCount = FldBdr.Items.Count
 
    While MailsCount > 0
    If MailsCount >= 1 Then FldBdr.Items.Item(MailsCount).Move Fldbzh
    MailsCount = MailsCount - 1
   Wend
 
End Sub
 
Sub SaveAttachement()
 
   Dim strFrom As String
   Dim strTo As String
   Dim strAttachment As String
   Dim bAttachment As Boolean
   Dim objMsg As MailItem
   Dim strFile As String
   Dim MailsCount As Double
 
 
   Set olApp = CreateObject("Outlook.Application")
 
   For Each Fld In Outlook.Session.Folders
      If Fld.Name Like "toto@france.com" Then
         Set Fldbzh = Fld.Folders("bzh")
         Set FldBdr = Fld.Folders("Boîte de réception")
         Exit For
      End If
   Next Fld
 
    Set ns = Application.GetNamespace("MAPI")
 
    Set NameSpace = olApp.GetNamespace("MAPI")
 
    Set objMsg = Application.CreateItem(olMailItem)
 
 
 
    MailsCount = FldBdr.Items.Count
    If MailsCount = O Then
        Exit Sub
    End If
 
 
For Each Mail In FldBdr.Items
For Each attachs In Mail.Attachments
file = attachs.FileName
If Right(attachs.FileName, 3) = "jpg" Then
GoTo NextAttach
ElseIf Right(attachs.FileName, 3) = "png" Then
GoTo NextAttach
ElseIf Right(attachs.FileName, 3) = "bmp" Then
GoTo NextAttach
End If
attachs.SaveAsFile "\\Zebulon\Partage\Script\" & file
i = i + 1
 
NextAttach:
Next attachs
 
Next Mail
 
Set objMsg = Nothing
 
End Sub
 
 
Sub report()
 
   Dim strFrom As String
   Dim strTo As String
   Dim strAttachment As String
   Dim bAttachment As Boolean
   Dim objMsg As MailItem
 
   Set olApp = CreateObject("Outlook.Application")
 
 
 
 
   For Each Fld In Outlook.Session.Folders
      If Fld.Name Like "toto@france.com" Then
         Set Fldbzh = Fld.Folders("bzh")
         Set FldBdr = Fld.Folders("Boîte de réception")
         Exit For
      End If
   Next Fld
 
    Set ns = Application.GetNamespace("MAPI")
 
 
   Set NameSpace = olApp.GetNamespace("MAPI")
 
      Set objMsg = Application.CreateItem(olMailItem)
 
 
       MailsCount = FldBdr.Items.Count
    If MailsCount = O Then
        Exit Sub
    End If
 
 
   For Each Mail In FldBdr.Items
      For Each attachs In Mail.Attachments
 
 
        If Right(attachs.FileName, 3) = "jpg" Then
GoTo NextAttach
ElseIf Right(attachs.FileName, 3) = "png" Then
GoTo NextAttach
ElseIf Right(attachs.FileName, 3) = "bmp" Then
GoTo NextAttach
End If
strAttachment = strAttachment & vbCrLf & attachs.DisplayName
 
        i = i + 1
NextAttach:
       Next attachs
   Next Mail
 
 
  strAttachment = strAttachment & vbNewLine
objMsg.To = "alfred@france.com"
objMsg.Body = "Pièce(s) jointe(s) déplacée(s) vers le dossier :  " & "\\Zebulon\Partage\Script" & vbCrLf & vbCrLf & strAttachment
objMsg.Subject = "Déplacement de pièces jointes"
objMsg.Send
 
Set objMsg = Nothing
 
End Sub
 
Function GetFolderPath(ByVal FolderPath As String) As Outlook.folder
    Dim oFolder As Outlook.folder
    Dim FoldersArray As Variant
    Dim i As Integer
 
    On Error GoTo GetFolderPath_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
        For i = 1 To UBound(FoldersArray, 1)
            Dim SubFolders As Outlook.Folders
            Set SubFolders = oFolder.Folders
            Set oFolder = SubFolders.Item(FoldersArray(i))
            If oFolder Is Nothing Then
                Set GetFolderPath = Nothing
            End If
        Next
    End If
    Set GetFolderPath = oFolder
    Exit Function
 
GetFolderPath_Error:
    Set GetFolderPath = Nothing
    Exit Function
End Function