Sub EMailCategory()
  'On Error Resume Next
  Dim sName As String
  Dim mpath As String
  Dim mdate As String
  Dim mname As Variant
  Dim mcat As String
  Dim mcat1 As String
  Dim fName As String
 
  Const PATH = "\\Netzlaufwerk1\Test" 'Berechtigungen zum Schreiben vorhanden
  'Const PATH = "\\Netzlaufwerk2\Test" ' keine Berechtigungen vorhanden
  'Const PATH = "D:\abc\test" 'Berechtigung zum Schreiben nicht vorhanden, aber _
    zum lesen
 
  If Application.ActiveExplorer.Selection.Count = 0 Then
      Exit Sub
  End If
 
  For Each objitem In Application.ActiveExplorer.Selection
 
        'SubjectName
        sName = objitem.Subject
        'Ersetzt Sonderzeichen
        ReplaceCharsForFileName sName, "_"
 
        'Empfangszeit der E-Mail wird ausgelesen
        mdate = Format(objitem.ReceivedTime, "yyyy-mm-dd_hh-nn-ss")
 
        'Auslesen des Senders
        mname = Split(objitem.Sender, "(")
        mname(0) = Left(mname(0), Len(mname(0)) - 1) 'schneidet ein Leerzeichen 
        ' weg
 
        'Prüfung ob Kategorie selektiert wurde
        If objitem.Categories = "" Then
            mpath = PATH & "\non_category\"
        Else
            mcat = Replace(objitem.Categories, ";", "_")
            mcat1 = Replace(mcat, " ", "")
            mpath = PATH & mcat1 & "\"
        End If
 
        'Falls Ordner nicht vorhanden wird er erstellt
        If Dir$(mpath, vbDirectory + vbHidden) = "" Then
                MkDir mpath
            End If
 
        'Datei abspeichern
        fName = mpath & mdate & "__" & sName & "_" & mname(0) & ".msg"
        objitem.SaveAs fName, 3
 
        If Dir(PATH & fName) <> "" Then
        MsgBox "Die E-Mail " & sName & " von " & mname(0) & " konnte nicht" & _
          "gespeichert werden." & vbCrLf & "Grund: keine Schreibberechtigung" & _
          "für den Ordner."
 
        Else
        MsgBox "Alles okay!"
        End If
 
  Next
 
End Sub
 
Private Sub ReplaceCharsForFileName(sName As String, _
  sChr As String _
)
'Funktion zum ersetzen der Sonderzeichen
 
  sName = Replace(sName, "/", sChr)
  sName = Replace(sName, "\", sChr)
  sName = Replace(sName, ":", sChr)
  sName = Replace(sName, "?", sChr)
  sName = Replace(sName, Chr(34), sChr)
  sName = Replace(sName, "<", sChr)
  sName = Replace(sName, ">", sChr)
  sName = Replace(sName, "|", sChr)
End Sub

____________________________________

...vorhanden!