'Fgen Sie den Inhalt dieser Textdatei im VB-Editor (Alt-F11) ins vorhandene Klassenmodul 
'"DieseOutlookSitzung" (unterhalb von "Microsoft Outlook Objekte") ein.


Private Sub Application_NewMail()
    'berprft alle ungelesenen Mails auf Attachments, speichert diese
    'auf Wunsch als Datei und entfernt sie anschlieend aus der Mail.
    ' 2000, Ralf Nebelo

    Dim objNameSpace As NameSpace
    Dim objPosteingang As MAPIFolder
    Dim objNachricht As MailItem
    Dim strMsg As String
    Dim intI As Integer
    Dim intButton As String
    Dim strBasisOrdner As String
    Dim strOrdner As String
    Dim strPfadname As String

    strBasisOrdner = "c:\"
    If Right(strBasisOrdner, 1) <> "\" Then
        strBasisOrdner = strBasisOrdner & "\"
    End If

    Set objNameSpace = Application.GetNamespace("MAPI")
    Set objPosteingang = objNameSpace.GetDefaultFolder(olFolderInbox)
    For Each objNachricht In objPosteingang.Items
        If objNachricht.UnRead = True And objNachricht.Attachments.Count > 0 Then
            strMsg = "Die Nachricht " & Chr(34) & objNachricht.Subject & Chr(34) & " von " & objNachricht.SenderName & " enthlt folgende Anhnge:" & vbCr
            For intI = 1 To objNachricht.Attachments.Count
                strMsg = strMsg & "- " & objNachricht.Attachments(intI).FileName & vbCr
            Next
            strMsg = strMsg & vbCr & "Mchten Sie diese Anhnge separat speichern und aus der Nachricht entfernen?"

            intButton = MsgBox(strMsg, vbYesNoCancel + vbQuestion, "Anhang separieren")
            If intButton = vbCancel Then
                Exit For
            ElseIf intButton = vbYes Then
                strOrdner = strBasisOrdner & Date
                If Dir(strOrdner & "\nul") = "" Then
                    MkDir strOrdner
                End If

                objNachricht.Display
                For intI = objNachricht.Attachments.Count To 1 Step -1
                    strPfadname = strOrdner & "\" & objNachricht.Attachments(intI).FileName
                    objNachricht.Attachments(intI).SaveAsFile strPfadname
                    objNachricht.Body = objNachricht.Body & vbCr & "<<" & objNachricht.Attachments(intI).FileName & ">> separiert nach: " & strOrdner
                    objNachricht.Attachments(intI).Delete
                Next

                objNachricht.Close olSave
            End If
        End If
    Next
End Sub
