Zitat:
Private WithEvents Items As Outlook.Items'Diese Kategorie automatisch zuweisen
Private Const AUTO_CATEGORY As String = "mit Klimax-Datei"
Private Sub Application_Startup()
Dim Ns As Outlook.NameSpace
Dim Inbox As Outlook.MAPIFolder
Dim Subfolder As Outlook.MAPIFolder
Set Ns = Application.GetNamespace("MAPI")
'Posteingang
Set Inbox = Ns.GetDefaultFolder(olFolderInbox)
'Unterordner des Posteingangs
Set Subfolder = Inbox.Folders("Mail mit Anhang")
Set Items = Subfolder.Items
End Sub
Private Sub Items_ItemAdd(ByVal Item As Object)
Dim colAtts As Outlook.Attachments
Dim oAtt As Outlook.Attachment
Dim sFile As String
Dim sDirectory As String
Dim sFileType As String
Dim Cats() As String
Dim i&
Dim Exists As Boolean
Set colAtts = oMail.Attachments
If colAtts.Count Then
For Each oAtt In colAtts
sFileType = LCase$(Right$(oAtt.FileName, 4))
Select Case sFileType
Case ".xls", ".doc"
sFile = ATTACHMENT_DIRECTORY & oAtt.FileName
oAtt.SaveAsFile sFile
If Len(Item.Categories) Then
'Prüfe, ob die Kategorie schon zugewiesen ist
Cats = Split(Item.Categories, ";")
For i = 0 To UBound(Cats)
If LCase$(Cats(i)) = LCase$(AUTO_CATEGORY) Then
Exists = True
Exit For
End If
Next
If Exists = False Then
Item.Categories = Item.Categories & ";" & AUTO_CATEGORY
Item.Save
End If
Else
Item.Categories = AUTO_CATEGORY
Item.Save
End If
End Select
End Sub