Outlook

Die Herausforderung
Im Outlook dieselbe Ordnerstruktur wie im Dateisystem.
Dazu braucht es eine Routine, welche das Dateisystem ab der gewünschten Stelle durchsucht und die entsprechenden Ordner in Outlook erstellt. Eine klassische Rekursion zur Durchwanderung eines Daten-Baums.
Die Prozedur zu erstellen ist eines, wirklich professionell ausprogrammieren das andere. Darauf erhebe ich keinen Anspruch. Es wurmt mich lediglich, dass es nicht möglich ist, in Outlook den Common Dialog mit dem Dateisystem aufzurufen, so muss der Ausgangsordner für die Suche eben direkt eingegeben werden (bFolder).

Option Explicit

Dim fsObject, fObject, sfObject, sFolder
Dim bFolder As String

Public Sub FolderTransfer()
' Aufruf der rekursiven Funktion CopyFolder mit den Basis-Elementen
' bFolder: Ordner im Dateisystem, dessen Struktur kopiert werden soll
' olFolder: Ornder in Outlook, wohin die Struktur kopiert werden soll

On Error Resume Next ' keine Lust für ein Error-Handling

Dim myOlApp As New Outlook.Application
Dim myNameSpace As Outlook.NameSpace
Dim olFolder As Outlook.Folder

Set myNameSpace = myOlApp.GetNamespace("MAPI")
Set olFolder = myNameSpace.PickFolder ' Aufruf des Fensters zur Zielwahl in Outlook

Set fsObject = CreateObject("Scripting.FileSystemObject")

bFolder = "C:\Data\MeinOrdner"

CopyFolder bFolder, olFolder          ' rekursive Funktion, welche die gesamte Ordnerstruktur durchläuft

MsgBox "Datei-Ordner-Struktur von " & bFolder & " nach Outlook-Ordner " & olFolder.Name & " kopiert.", vbInformation, "Ordnerstruktur synchronisieren"

Set fsObject = Nothing
Set fObject = Nothing
Set sfObject = Nothing
Set sFolder = Nothing

End Sub

Function CopyFolder(fPath, oFolder As Outlook.Folder)
' rekursive Funktion, die alle Unterordner durchläuft und die entsprechenden Unterordner in Outlook erstellt.

Dim tFolder As Outlook.Folder

Set fObject = fsObject.GetFolder(fPath) ' globale Variable
Set sfObject = fObject.SubFolders       ' globale Variable

On Error Resume Next ' keine Lust für ein Error-Handling

For Each sFolder In sfObject                        ' suche alle Unterordner des Dateisystems ab

    Set tFolder = oFolder.Folders.Add(sFolder.Name) ' füge Outlook-Ordner mit Name des Datei-Ordners hinzu

    CopyFolder sFolder.Path, tFolder                ' rekursiver Aufruf (auf Ebene des jeweiligen Unterordners)

Next

Set tFolder = Nothing

End Function

Nächste Herausforderung
Lösen und Abspeichern aller Anlagen und E-Mails in allen Unterordnern in Outlook
Es braucht dazu wiederum eine rekursive Routine, welche die gesamte Ordnerstruktur in Outlook durchläuft.
Dateinamen beginnen alle mit dem Datum im Format "JJJJ MM TT". Die verschiedenen Debug.Print-Statements dienten der Programm-Verfolgung bei der Entwicklung.

Dim nbrMessages, nbrSaved, nbrAttachments As Integer

Private Sub BrowseMail()
' Aufruf der rekursiven Prozedur BrowseSubfolders zur Suche nach eMails

Dim objInbox As Outlook.MAPIFolder
Dim objMail As MailItem
Dim objC As Integer

On Error Resume Next

MsgBox "Nicht beirren lassen durch Fehlermeldungen wie" & vbCrLf & _
"'Filesystem defekt' oder 'Festplatte voll/ schreibgeschützt':" & vbCrLf & _
"Diese Fehler entstehen, wenn eine Datei mit einer gebrochenen Verknüpfung" & _
"im RTF-Format gespeichert werden soll." & vbCrLf & _
"Die Datei wird rotzdem korrekt abgelegt.", vbExclamation, "eMail Management"

' Set objInbox = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox) ' Posteingang selbst wird nicht geprüft
Set objInbox = Application.GetNamespace("MAPI").PickFolder ' gewählter Ordner selbst wird nicht geprüft

nbrMessages = 0
nbrSaved = 0
nbrAttachments = 0

bFolder = "C:\Data\MeinOrdner" ' Stammordner im Dateisystem

Call BrowseSubfolders(objInbox, "", 0)

Set objMail = Nothing
Set objInbox = Nothing

MsgBox nbrMessages & " eMails geprüft" & vbCrLf & _
nbrSaved & " eMails gespeichert" & vbCrLf & _
nbrAttachments & " Anlagen entfernt/ gespeichert", vbInformation, "eMail Management"

End Sub

Private Sub BrowseSubfolders(cFolder As MAPIFolder, ByVal objPath As String, ByVal objLevel As Integer)
' Rekursive Prozedur zur Suche nach eMails im angegebenen cFolder (Outlook) und allen Unterordnern

Dim objSubFolder As MAPIFolder
Dim objMail As MailItem
Dim tmpPath, sPath, sFile, errStr As String
Dim aCount, i As Integer

On Error Resume Next

objLevel = objLevel + 1 ' wird nicht verwendet

For Each objSubFolder In cFolder.Folders

    tmpPath = objPath & "\" & objSubFolder

    For Each objMail In objSubFolder.Items

        nbrMessages = nbrMessages + 1

        Debug.Print nbrMessages & " Folder: " & objSubFolder.Name & " >>>Message: " & objMail.Subject & " >>>Categories: " & objMail.Categories & " >>>Attachments: " & CStr(objMail.Attachments.count)

        If Not IsCategory(objMail, "Saved") Then ' Prüfe nur, wenn Kategorie "Saved" nicht gesetzt

            ' falls der Unterordner nicht exisitert, erstell ihn
            MakeDir (bFolder & tmpPath)

            sPath = bFolder & tmpPath & "\" & Format(objMail.ReceivedTime, "yyyy mm dd") & " " & CleanFilename(objMail.SenderName)

            aCount = objMail.Attachments.count

            If aCount > 0 Then
                For i = 1 To aCount
                    If CopyAttachment(objMail.Attachments.Item(i).FileName) Then
                        sFile = " - " & CleanFilename(Trim(Left(objMail.Attachments.Item(i).FileName, 92)))
                        objMail.Attachments.Item(i).SaveAsFile sPath & sFile

                        Debug.Print " > Attachment saved: " & sPath & sFile

                    End If
                Next i
            For i = 1 To aCount

                nbrAttachments = nbrAttachments + 1

                Debug.Print " > Attachment deleted: " & objMail.Attachments.Item(1).FileName

                objMail.Attachments.Item(1).Delete ' lösche Anlage

            Next i

            nbrSaved = nbrSaved + 1

            objMail.Save

            End If

            sFile = " - " & CleanFilename(Trim(Left(objMail.Subject, 92)))
            sFile = sPath & sFile

            Debug.Print " > Message to save: " & sFile & ".rtf"

            objMail.SaveAs sFile & ".rtf", olRTF ' speichere eMail im Rich Text Format
            ' objMail.SaveAs sFile & ".msg", olMSG ' speichere eMail im Outlook-Message Format

            Debug.Print " > Message saved: " & sFile & ".rtf"

            Call SetCategory(objMail, "Saved") ' setze Kategorie "Saved", um Überprüfung im nächsten Lauf zu vermeiden

        End If

    Next objMail

    Call BrowseSubfolders(objSubFolder, tmpPath, objLevel) ' rekursiver Aufruf für Unterordner

    tmpPath = objPath & "\" & objSubFolder

Next objSubFolder

Set objMail = Nothing
Set objSubFolder = Nothing

End Sub

Public Function IsCategory(mItm As MailItem, cat As String) As Boolean
' prüft, ob die Kategorie cat im Mail-Objekt enthalten ist
On Error Resume Next

IsCategory = False

If InStr(mItm.Categories, cat) > 0 Then IsCategory = True

End Function

Public Sub SetCategory(ByRef mItm As MailItem, ByVal cat As String)
' prüft, ob schon Kategorien gesetzt sind und fügt cat hinzu
Dim tCat As String

tCat = mItm.Categories
If Len(tCat) = 0 Then
    mItm.Categories = cat
Else
    mItm.Categories = tCat & ";" & cat
End If
mItm.Save

End Sub

Public Function CleanFilename(ByVal sFilename As String) As String
' entferne unerlaubte/ unerwünschte Zeichen aus Dateinamen

sFilename = Replace(sFilename, "_", " ") ' ersetze vorbereitend alle "_" durch " "
sFilename = Replace(sFilename, Chr(9), " ") ' Tabulator
sFilename = Replace(sFilename, "%", "_")
sFilename = Replace(sFilename, "\", "_")
sFilename = Replace(sFilename, "/", "_")
sFilename = Replace(sFilename, ":", "_")
sFilename = Replace(sFilename, ";", "_")
sFilename = Replace(sFilename, "?", "_")
sFilename = Replace(sFilename, "*", "_")
sFilename = Replace(sFilename, "'", "_")
sFilename = Replace(sFilename, Chr(34), "_") ' Anführungszeichen
sFilename = Replace(sFilename, ">", "_")
sFilename = Replace(sFilename, "<", "_")
sFilename = Replace(sFilename, "|", "_")
sFilename = Replace(sFilename, " _", "_")
sFilename = Replace(sFilename, "_ ", "_")
Do While sFilename <> Replace(sFilename, "__", "_") ' ersetze aufeinanderfolgende "__" durch einen einzigen "_"
    sFilename = Replace(sFilename, "__", "_")
Loop
Do While sFilename <> Replace(sFilename, " ", " ")
    sFilename = Replace(sFilename, " ", " ")
Loop
CleanFilename = sFilename

End Function

Public Function CopyAttachment(ByVal fName As String) As Boolean

CopyAttachment = True

' Wenn eine Datei mit z.B. "2008 02 15 " beginnt, dann exisitert sie mit grösster Wahrscheinlichkeit schon und muss nicht gespeichert werden.
If Left(fName, 2) = "20" Then
    If IsNumeric(Mid(fName, 3, 2)) And IsNumeric(Mid(fName, 6, 2)) And IsNumeric(Mid(fName, 9, 2)) And Mid(fName, 5, 1) = " " _
And Mid(fName, 8, 1) = " " And Mid(fName, 11, 1) = " " Then
    CopyAttachment = False
End If
' Automatische Anlagen aus HTML-Meldungen auf Text-Systeme, Firmen-Logos etc.
ElseIf InStr(fName, "ATT00") Or InStr(fName, "TXT00") Then
    CopyAttachment = False
End If

End Function

Public Sub MakeDir(ByVal dPath As String)
' Kreiert ein Unterverzeichnis
' Falls das Unterverzeichnis schon existiert, wird ein Fehler generiert, der über 'Resume Next' abgefangen wird.
' Falls das Unterverzeichnis aus einem anderen Grund nicht erstellt werden konnte, weiss man es leider nicht...
On Error Resume Next
MkDir dPath
End Sub