Sub
Anlage_verschieben()
Dim
strPath
As
String
Dim
Mail_Date
As
String
Dim
Mail_Jahr
As
String
Dim
Mail_Monat
As
String
Dim
Mail_Tag
As
String
Dim
Anhang_Name
As
String
Dim
objMail
As
Outlook.MailItem
Dim
intAnlagen
As
Integer
, i
As
Integer
strPath =
"C:\Neuer Ordner"
For
Each
objMail
In
Outlook.ActiveExplorer.Selection
If
objMail.Type = 5
Then
Else
With
objMail
intAnlagen = .Attachments.Count
If
intAnlagen > 0
Then
For
i = 1
To
intAnlagen
Mail_Date = objMail.CreationTime
Mail_Date = Left(Mail_Date, 10)
Mail_Jahr = Mid(Mail_Date, 7, 4)
Mail_Monat = Mid(Mail_Date, 4, 2)
Mail_Tag = Mid(Mail_Date, 1, 2)
Mail_Date = Mail_Jahr & Mail_Monat & Mail_Tag &
"_"
Anhang_Name = Mail_Date & .Attachments.Item(i).Filename
.Attachments.Item(i).SaveAsFile strPath & "\" & Anhang_Name
Next
i
End
If
End
With
End
If
Next
objMail
End
Sub