Dim arr() As String
Dim i As Integer
Dim ns As Outlook.Namespace
Dim itm As MailItem
Dim m As Outlook.MailItem
On Error Resume Next
Set ns = Application.Session
arr = Split(EntryIDCollection, ",")
For i = 0 To UBound(arr)
Set itm = ns.GetItemFromID(arr(i))
If itm.Class = olMail Then
Set m = itm
If m Is Nothing Then Exit Sub
'Zde je možnost nastavit filtr na předmět zprávy, tzn. ukládat se budou pouze přílohy zpráv začínajících daným textem
If Left(m.Subject, Len("PREDMET ZPRAVY")) = "PREDMET ZPRAVY" Then
SaveAtt m
End If
End If
Next
Set ns = Nothing
Set itm = Nothing
Set m = Nothing
End Sub
Public Sub SaveAtt(ByRef itm As MailItem)
On Error Resume Next
Dim objAtt As Outlook.Attachment
Dim saveFolder As String
saveFolder = "C:\PRILOHY\"
For Each objAtt In itm.Attachments
objAtt.SaveAsFile saveFolder & objAtt.DisplayName
Next
itm.UnRead = False
End Sub
M@citovat