Outlook 2010 VBA: Mails dynamisch ablegen - komplette Ordnerstruktur erstellen

[amn.ssy]

das mit dem Überwachungsfenster sollte ich mir angewöhnen ...
Index von arrSubFolder(i) ist von vornherein außerhalb des gültigen Bereichs und daran ändert sich auch nicht wenn's in die Schleife geht

 

[Zvoni]

Ich sehe nirgends ein ReDim arrSubFolder

 

[amn.ssy]

Jetzt dachte ich schon ich hätte damit den Durchbruch erziehlt (ohne Redim, dessen korrekte Stelle ich vergeblich experimentierte) hab mir dabei aber wohl doch ins Knie geschossen:

...
Set F = obj.Parent
  If InStr(1, F.folderPath, "Posteingang") Then
    strFolder = "InBox"
    strPath = F.folderPath
    tmpPath = Split(strPath, "\Posteingang\")
    arrPath = Split(tmpPath(1), "\")
         
  ElseIf InStr(1, F.folderPath, "Gesendete Elemente") Then
    strFolder = "Send"
    strPath = F.folderPath
    tmpPath = Split(strPath, "\Gesendete Elemente\")
    arrPath = Split(tmpPath(1), "\")
  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
    
    For i = LBound(arrPath) To UBound(arrPath)
        If arrPath(i) <> "" Then
            strBackupPath = fso.BuildPath(strBackupPath, arrPath(i))
                If Not fso.FolderExists(strBackupPath) Then
                    fso.CreateFolder (strBackupPath)
                End If
        End If
    Next i
    
    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)
...

Das ergebnis ist, daß ich jetzt nur noch Mails ablegen kann, wenn Sie aus min. einem (Unter)Ordner kommen :-(

 

[amn.ssy]

Morgähn,

so nun ist's komplett
Wie "Zvoni" schon zuvor anmerkte kam ich letztlich nicht am Redim vorbei.
Warum ich's aber gleich zweimal brauche verstehe ich noch nicht so ganz:

...
Set f = obj.Parent
  If InStr(1, f.folderPath, "Posteingang") Then
    strFolder = "InBox"
    strPath = f.folderPath
    tmpPath = Split(strPath, "\Posteingang\")
    If UBound(tmpPath) > 0 Then
        ReDim arrPath(UBound(tmpPath))
        arrPath = Split(tmpPath(1), "\")
    End If
    
  ElseIf InStr(1, f.folderPath, "Gesendete Elemente") Then
    strFolder = "Send"
    strPath = f.folderPath
    tmpPath = Split(strPath, "\Gesendete Elemente\")
    If UBound(tmpPath) > 0 Then
        ReDim arrPath(UBound(tmpPath))
        arrPath = Split(tmpPath(1), "\")
    End If
  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
    
    ReDim Preserve arrPath(UBound(tmpPath))
    If UBound(arrPath) > 0 Then
        For i = LBound(arrPath) To UBound(arrPath)
            strBackupPath = fso.BuildPath(strBackupPath, arrPath(i))
                If Not fso.FolderExists(strBackupPath) Then
                    fso.CreateFolder (strBackupPath)
                End If
        Next i
    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)
...

Geändert haben sich die Zeilen: 7-10, 10-19 und 47 - 49

LG
opiwahn

 

[Zvoni]

Warum ich's aber gleich zweimal brauche verstehe ich noch nicht so ganz:

  If InStr(1, f.folderPath, "Posteingang") Then
    *schnipp*
    If UBound(tmpPath) > 0 Then
        ReDim arrPath(UBound(tmpPath))
        *schnipp*
    End If
    
  ElseIf InStr(1, f.folderPath, "Gesendete Elemente") Then
    *schnipp*
    If UBound(tmpPath) > 0 Then
        ReDim arrPath(UBound(tmpPath))
        *schnipp*
    End If
  End If
    *schnipp*

Weil du in einem If-ElseIf-Konstrukt bist, und je nach dem in welchem Teil der If-Klausel du landest ist UBound anderst. Von daher absolut logisch dass du es zweimal brauchst.
Alternative wäre mit einer Variablen zu arbeiten und dann den ReDim nach dem If-ElseIf, aber wie heisst es doch so schön: Es funktioniert jetzt, also fass es nicht mehr an.