Outlook 2010 VBA: Mails dynamisch ablegen - komplette Ordnerstruktur erstellen

A

amn.ssy

Erfahrenes Mitglied
Hallo,

ich komme nochmal zurück auf das erstellen einer kompletten Ordnerstruktur bei der ablage der mails auf der NAS.
Es hat sich herausgestellt, daß ich wohl doch nicht auf ggf. vorhandenen Herkunfts-\Unterrordner verzichten kann.
Aktuelle sieht das im Kern so aus:
Visual Basic: 
Private Function ProcessEmail(myItem As Object, ByVal strBackupPath As String) As Variant
    'Saves the e-mail on the drive by using the provided path.
    'Returns TRUE if successful, and FALSE otherwise.

    Const PROCNAME As String = "ProcessEmail"

    On Error GoTo ErrorHandler

    Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")
    Dim obj As Object: Set obj = Application.ActiveWindow
    Dim F As Outlook.MAPIFolder
    Dim myMailItem As MailItem
    Dim strFolder As String
    Dim strSubFolder As String
    Dim strFolderDate As String
    Dim strFileDate As String
    Dim strSender As String
    Dim strReceiver As String
    Dim strSubject As String
    Dim strFinalFileName As String
    Dim strFullPath As String
    Dim vExtConst As Variant
    Dim vTemp As String
    Dim strErrorMsg As String
    
    If TypeOf myItem Is MailItem Then
         Set myMailItem = myItem
    Else
        Error 1001
    End If
    
    
  If TypeOf obj Is Outlook.Inspector Then
    Set obj = obj.CurrentItem
  Else
    Set obj = obj.Selection(1)
  End If
  Set F = obj.Parent
  If InStr(1, F.folderPath, "Posteingang") Then
    strFolder = "InBox"
    Debug.Print F.folderPath
    Debug.Print F.Name
  ElseIf InStr(1, F.folderPath, "Gesendete Elemente") Then
    strFolder = "Send"
    Debug.Print F.folderPath
    Debug.Print F.Name
  End If
  
  'strSubFolder =
     
    'Set filename
    strFolderDate = Format(myMailItem.ReceivedTime, EXM_OPT_FOLDERNAME_DATEFORMAT)
    strFileDate = Format(myMailItem.ReceivedTime, EXM_OPT_FILENAME_DATEFORMAT)
    strSender = myMailItem.SenderName
    strReceiver = myMailItem.To 'All receiver, semikolon separated string
    If InStr(strReceiver, ";") > 0 Then strReceiver = Left(strReceiver, InStr(strReceiver, ";") - 1)
    strSubject = myMailItem.Subject
    strFinalFileName = EXM_OPT_FILENAME_BUILD
    strFinalFileName = Replace(strFinalFileName, "<DATE>", strFileDate)
    strFinalFileName = Replace(strFinalFileName, "<SENDER>", strSender)
    strFinalFileName = Replace(strFinalFileName, "<RECEIVER>", strReceiver)
    strFinalFileName = Replace(strFinalFileName, "<SUBJECT>", strSubject)
    strFinalFileName = CleanString(strFinalFileName)
    If Left(strFinalFileName, 15) = "ERROR_OCCURRED:" Then
        strErrorMsg = Mid(strFinalFileName, 16, 9999)
        Error 1003
    End If
    strFinalFileName = IIf(Len(strFinalFileName) > 251, Left(strFinalFileName, 251), strFinalFileName)
    
    strBackupPath = fso.BuildPath(strBackupPath, strFolder)
        If Not fso.FolderExists(strBackupPath) Then
            fso.CreateFolder (strBackupPath)
        End If
    
    strBackupPath = fso.BuildPath(strBackupPath, strFolderDate)
        If Not fso.FolderExists(strBackupPath) Then
            fso.CreateFolder (strBackupPath)
        End If
    
    If strFolder = "InBox" Then
        strBackupPath = fso.BuildPath(strBackupPath, strSender)
    Else
        strBackupPath = fso.BuildPath(strBackupPath, strReceiver)
    End If
    
        If Not fso.FolderExists(strBackupPath) Then
            fso.CreateFolder (strBackupPath)
        End If

    strFullPath = fso.BuildPath(strBackupPath, strFinalFileName)
    
    'Save as msg or txt?
    Select Case UCase(EXM_OPT_MAILFORMAT)
        Case "MSG":
            strFullPath = strFullPath & ".msg"
            vExtConst = olMSG
        Case Else:
            strFullPath = strFullPath & ".txt"
            vExtConst = olTXT
    End Select
    'File already exists?
    If fso.FileExists(strFullPath) = True Then
        Error 1002
    End If
    
    'Save file
    myMailItem.SaveAs strFullPath, vExtConst
    
    'Return true as everything was successful
    ProcessEmail = True
...
Auf der "Platte" wird dann folgende Struktur erzeugt
Visual Basic: 
Z:\Mailarchive
    Inbox
       2014-01-29
          Mueller, Lieschen
               [09-05] [Mueller, Lieschen to Kurz, Eva] [mer gehts net guut ...].msg
Kommt diese Mail aus einem Unterordnern wie "Posteingang\Sonstiges\Prosa" würde ich die Mail gerne so ablegen
Visual Basic: 
Z:\Mailarchive
    Inbox
       Sonstiges
           Prosa
              2014-01-29
                  Mueller, Lieschen
                     [09-05] [Mueller, Lieschen to Kurz, Eva] [mer gehts net guut ...].msg
Mit F.Folderpath bekomme ich den kompletten Pfad geliefert, der dann etwas so aussieht:
Visual Basic: 
\\es.geht@jetzt.net\Posteingang\Sonstiges\Prosa
Wie kann ich damit ggf. einen Subfolder zusammenbauen oder ist das der völlig falsche Ansatz und geht geht sogar noch einfacher?
Letztlich brache ich nur das was ggf. nach Posteingang oder Gesendete Elemente kommt.
Postboxeigentümer ist ziemlich wurscht (es sei denn ich hätte mehrere PB's im Outlook - dann wirds spannend) und Posteingang\Ausgang hab ich ja bereits.

LG
opiwahn
 
Zuletzt bearbeitet:
Visual Basic: 
Dim arrPath() As String
Dim Pfad As String

Pfad ="\\es.geht@jetzt.net\Posteingang\Sonstiges\Prosa"

arrPath=Split(Pfad, "\Posteingang\")

Führ den Code mal aus, und schau dir mal an was nach dem Split in arrPath(1) steht
 
Hallo Zvoni,

danke für den Hinweis, der zumindest für die erste Ebene unterhalb von z.B. Posteingang funktioniert. Scheinbar muß ich aber alle Ebenen aufsplitten, da das makro ab der 2. Ebene auf den Bauch fällt - scheinbar kann ich eine Pfad wie \Sonstiges\Prosa nicht in einem Stück umsetzen.
Umgesetzt habe ich es bisher so:
Visual Basic: 
Set F = obj.Parent
  If InStr(1, F.folderPath, "Posteingang") Then
    strFolder = "InBox"
    strPath = F.folderPath
    arrPath = Split(strPath, "\Posteingang")
    strSubFolder = arrPath(1)
    Debug.Print strSubFolder
    
  ElseIf InStr(1, F.folderPath, "Gesendete Elemente") Then
    strFolder = "Send"
    strPath = F.folderPath
    arrPath = Split(strPath, "\Gesendete Elemente")
    strSubFolder = arrPath(1)
    Debug.Print strSubFolder
  End If
...
strBackupPath = fso.BuildPath(strBackupPath, strFolder)
        If Not fso.FolderExists(strBackupPath) Then
            fso.CreateFolder (strBackupPath)
        End If
    
    If strSubFolder <> "" Then
        strBackupPath = fso.BuildPath(strBackupPath, strSubFolder)
        If Not fso.FolderExists(strBackupPath) Then
            fso.CreateFolder (strBackupPath)
        End If
    End If
    
    strBackupPath = fso.BuildPath(strBackupPath, strFolderDate)
        If Not fso.FolderExists(strBackupPath) Then
            fso.CreateFolder (strBackupPath)
        End If
    
    If strFolder = "InBox" Then
        strBackupPath = fso.BuildPath(strBackupPath, strSender)
    Else
        strBackupPath = fso.BuildPath(strBackupPath, strReceiver)
    End If
    
        If Not fso.FolderExists(strBackupPath) Then
            fso.CreateFolder (strBackupPath)
        End If

    strFullPath = fso.BuildPath(strBackupPath, strFinalFileName)
 
Visual Basic: 
Dim tmpPath() As String
Dim arrPath() As String
Dim Pfad As String
 
Pfad ="\\es.geht@jetzt.net\Posteingang\Sonstiges\Prosa"
 
tmpPath=Split(Pfad, "\Posteingang\")
arrPath=Split(tmpPath(1),"\")

jetzt haste in arrPath(0) = "Sonstiges"
in arrPath(1) = "Prosa"
in arrPath(2), arrPath(3) usw. eventuell weitere vorhandene Ordner unterhalb von "Prosa"
 
Zuletzt bearbeitet:
Hallo Zvoni,

hab gerade versucht mir sowas zu bauen:
Visual Basic: 
  Set F = obj.Parent
  If InStr(1, F.folderPath, "Posteingang") Then
    strFolder = "InBox"
    strPath = F.folderPath
    tmpPath = Split(strPath, "\Posteingang\")
    arrPath = Split(tmpPath(1), "\")
    
        For i = LBound(arrPath) To UBound(arrPath)
            If arrPath(i) <> "" Then
                arrSubFolder(i) = arrPath(i)
            End If
        Next i
        Debug.Print arrSubFolder(i)
Aber da harkts noch ein wenig:
Die Zeile arrPath = Split(tmpPath(1), "\") wird angemeckert weil ein datenfeld erwartet wird.
Schmeiss ich die (1) raus krachts wg. Typenunverträglickeit bzw. beim debuggen hab ich gesehen, daß er erst garnicht über die Zeile raus kommt
 
Zuletzt bearbeitet:
gerade in dem Moment als ich den Deklarationsteil kopieren wollte hab ich gesehen, daß bei tmpPath die () fehlten und das ganze somit kein Array war.
Dafür ist jetzt der Idex außerhalb des gültigen Bereichs.
Gleiche Stelle - zur Schleife kommt er erst garnicht.
Visual Basic: 
Private Function ProcessEmail(myItem As Object, ByVal strBackupPath As String) As Variant
    'Saves the e-mail on the drive by using the provided path.
    'Returns TRUE if successful, and FALSE otherwise.

    Const PROCNAME As String = "ProcessEmail"

    On Error GoTo ErrorHandler

    Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")
    Dim obj As Object: Set obj = Application.ActiveWindow
    Dim F As Outlook.MAPIFolder
    Dim myMailItem As MailItem
    Dim strPath As String
    Dim tmpPath() As String
    Dim arrPath() As String
    Dim strFolder As String
    Dim arrSubFolder() As String
    Dim strFolderDate As String
    Dim strFileDate As String
    Dim strSender As String
    Dim strReceiver As String
    Dim strSubject As String
    Dim strFinalFileName As String
    Dim strFullPath As String
    Dim vExtConst As Variant
    Dim vTemp As String
    Dim strErrorMsg As String
    Dim i As Integer
    
    If TypeOf myItem Is MailItem Then
         Set myMailItem = myItem
    Else
        Error 1001
    End If
    
    
  If TypeOf obj Is Outlook.Inspector Then
    Set obj = obj.CurrentItem
  Else
    Set obj = obj.Selection(1)
  End If
  
  Set F = obj.Parent
  If InStr(1, F.folderPath, "Posteingang") Then
    strFolder = "InBox"
    strPath = F.folderPath
    tmpPath = Split(strPath, "\Posteingang\")
    arrPath = Split(tmpPath(1), "\")
    
    Debug.Print arrPath(0)
    Debug.Print arrPath(1)
    Debug.Print arrPath(2)
    
        For i = LBound(arrPath) To UBound(arrPath)
            If arrPath(i) <> "" Then
                arrSubFolder(i) = arrPath(i)
            End If
            Debug.Print arrSubFolder(i)
        Next i
        
  ElseIf InStr(1, F.folderPath, "Gesendete Elemente") Then
    strFolder = "Send"
    strPath = F.folderPath
    tmpPath = Split(strPath, "\Gesendete Elemente\")
    arrPath = Split(tmpPath(1), "\")
    arrSubFolder(0) = arrPath(0)
    Debug.Print arrSubFolder(0)
  End If
       
    'Set filename
    strFolderDate = Format(myMailItem.ReceivedTime, EXM_OPT_FOLDERNAME_DATEFORMAT)
    strFileDate = Format(myMailItem.ReceivedTime, EXM_OPT_FILENAME_DATEFORMAT)
    strSender = myMailItem.SenderName
    strReceiver = myMailItem.To 'All receiver, semikolon separated string
    If InStr(strReceiver, ";") > 0 Then strReceiver = Left(strReceiver, InStr(strReceiver, ";") - 1)
    strSubject = myMailItem.Subject
    strFinalFileName = EXM_OPT_FILENAME_BUILD
    strFinalFileName = Replace(strFinalFileName, "<DATE>", strFileDate)
    strFinalFileName = Replace(strFinalFileName, "<SENDER>", strSender)
    strFinalFileName = Replace(strFinalFileName, "<RECEIVER>", strReceiver)
    strFinalFileName = Replace(strFinalFileName, "<SUBJECT>", strSubject)
    strFinalFileName = CleanString(strFinalFileName)
    If Left(strFinalFileName, 15) = "ERROR_OCCURRED:" Then
        strErrorMsg = Mid(strFinalFileName, 16, 9999)
        Error 1003
    End If
    strFinalFileName = IIf(Len(strFinalFileName) > 251, Left(strFinalFileName, 251), strFinalFileName)
    
    strBackupPath = fso.BuildPath(strBackupPath, strFolder)
        If Not fso.FolderExists(strBackupPath) Then
            fso.CreateFolder (strBackupPath)
        End If
    
    If arrSubFolder(0) <> "" Then
        strBackupPath = fso.BuildPath(strBackupPath, arrSubFolder(0))
        If Not fso.FolderExists(strBackupPath) Then
            fso.CreateFolder (strBackupPath)
        End If
    End If
    
    strBackupPath = fso.BuildPath(strBackupPath, strFolderDate)
        If Not fso.FolderExists(strBackupPath) Then
            fso.CreateFolder (strBackupPath)
        End If
    
    If strFolder = "InBox" Then
        strBackupPath = fso.BuildPath(strBackupPath, strSender)
    Else
        strBackupPath = fso.BuildPath(strBackupPath, strReceiver)
    End If
    
        If Not fso.FolderExists(strBackupPath) Then
            fso.CreateFolder (strBackupPath)
        End If

    strFullPath = fso.BuildPath(strBackupPath, strFinalFileName)
    
    'Save as msg or txt?
    Select Case UCase(EXM_OPT_MAILFORMAT)
        Case "MSG":
            strFullPath = strFullPath & ".msg"
            vExtConst = olMSG
        Case Else:
            strFullPath = strFullPath & ".txt"
            vExtConst = olTXT
    End Select
    'File already exists?
    If fso.FileExists(strFullPath) = True Then
        Error 1002
    End If
    
    'Save file
    myMailItem.SaveAs strFullPath, vExtConst
    
    'Return true as everything was successful
    ProcessEmail = True

ExitScript:
    Exit Function
ErrorHandler:
    Select Case Err.Number
    Case 1001:  'Not an email
        ProcessEmail = EXM_013
    Case 1002:
        ProcessEmail = EXM_014
    Case 1003:
        ProcessEmail = strErrorMsg
    Case Else:
        ProcessEmail = "Error #" & Err & ": " & Error$ & " (Procedure: " & PROCNAME & ")"
    End Select
    Resume ExitScript
End Function

Für den Bereich der ausgehenden mails hab ich erst mal was reingesetzt bis dr Posteingang funktioniert. Debug.Print dient mir zur Kontrolle.
Um Zeile 96 bis 101 muß ich dann wohl auch noch ne Schleife bauen? Irgendwie muß ich das Array ja durchlaufen und für jedes vorhandene Element einen Ordner erstellen wenn er noch nicht vorhanden ist.
 
Zuletzt bearbeitet:
Zeile 46+47: Kannst du mal die Werte für strPath und tmpPath(0) und tmpPath(1) hier reinstellen?
Ich habe da ne Vermutung....
 
strPath: \\xxx.yyy@zzz.com\Posteingang\09 Other\Test
tmpPath(0):\\xxx.yyy@zzz.com
tmpPath(1):09 Other\Test

Sieht soweit richt aus ...
 
hmmm...

Nach dem zweite Split müsste dann das Ergebnis doch so aussehen:

arrPath(0) = 09 Other
arrPath(1) = Test

und Debug.Print arrPath(2) wirft dir einen ungültigen Index an den Kopf, da arrPath(2) nicht existiert. Kommentier das mal aus. Setz lieber mal einen Breakpoint auf Zeile 45 und schau dir mal die Ergebnisse im Überwachungsfenster an.

Ansonsten kann ich hier keinen Fehler sehen. LBound To UBound ist definitiv die richtige Herangehensweise.

Was Zeile 96 betrifft: Ja. Da brauchste ne Schleife

EDIT: Falls ich mal Zeit haben sollte, schau ich mal ob ich dir das ganze per API's zusammenbauen kann *gg*
Ich kann so ein Gehangel durch den Ordnerbaum nunmal auf den Tod nicht ausstehen :-)
 
Um antworten zu können musst du eingeloggt sein.

Neue Beiträge

Zurück