Sieht besser aus. Stimmt. :-D Funktioniert aber leider immer noch nicht.....

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 ".xml"
            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
                End If
                Exit For
            Next i
            End If
             
            If Exists = False Then
                Item.Categories = Item.Categories & ";" & AUTO_CATEGORY
                Item.Save
            Else
                Item.Categories = AUTO_CATEGORY
                Item.Save
            End If
             
        Case Else
         
        End Select
    Next oAtt
End If
End Sub