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 |
Problème d'exécution du script via une règle
Répondre avec citation
Oliv'
Envoyé par d_dalcan
Partager