[Sonstiges] Outlook 2010 VBA: Mails dynamisch ablegen - Problem bei Multiselected

[amn.ssy]

Hallo,

wie mir gestern Nachmittag aufgefallen ist, läuft das mit dem ablegen von Mails und der dynamischen Erzeugung von Ordnern doch noch nicht so ganz rund.
Jedes Mail einzeln auswählen und per Knopfdruck ablegen funktioniert ganz wie ich es mir vorgestellt habe.
Beim Ablegen von mehreren selektierten Mails scheint es ein Problem mit dem Pfad zu geben.
Dieses drückt sich dann so aus, daß für die erste Mail die Verzeichnisse korrekt angelegt werden, für alle weiteren werden die anzulegenden Ordner als Unterordner vom ersten abgelegten Mail angesehen, was zu einer ziemlich heftigen Tiefe führen kann.

Die Ordner für diese Mails sind korrekt, jedoch an der falschen Stelle.
Beispiel für 3 Mails, alle vom gleichen Tag, von 2 Personen

InMails
  2014-01-22
    Becker, Heinz
      InMails
        2014-01-22
          Becker, Heinz
             InMails
               2014-01-22
                  Becker, Hilde

Richtig wäre (= Ergebnuis beim einzeln ablegen)

InMails
  2014-01-22
    Becker, Heinz <-- hier liegen 2 Mails drin
    Becker, Hilde  <-- und hier ein Mail

Aus dem Buch heraus würde ich sagen, irgendwo müßte eine For Each Schleife drum!?
Im übrigen ist im ursprünglichen Code ein Multiselect von bis zu 20 Items vorgesehen.

Public Sub ExportEmailToDrive()
    
    Const PROCNAME As String = "Mail2Drive"
    
    On Error GoTo ErrorHandler
    
    Dim myExplorer As Outlook.Explorer
    Dim myfolder As Outlook.MAPIFolder
    Dim myItem As Object
    Dim olSelection As Selection
    Dim strBackupPath As String
    Dim intCountAll As Integer
    Dim intCountFailures As Integer
    Dim strStatusMsg As String
    Dim vSuccess As Variant
    Dim strTemp1 As String
    Dim strTemp2 As String
    Dim strErrorMsg As String
 
    '-------------------------------------
    'Get target drive
    '-------------------------------------
    If (EXM_OPT_USEBROWSER = True) Then
        strBackupPath = GetFileDir
        If Left(strBackupPath, 15) = "ERROR_OCCURRED:" Then
            strErrorMsg = Mid(strBackupPath, 16, 9999)
            Error 5004
        End If
    Else
        strBackupPath = EXM_OPT_TARGETFOLDER
    End If
    If strBackupPath = "" Then GoTo ExitScript
    If (Not Right(strBackupPath, 1) = "\") Then strBackupPath = strBackupPath & "\"
    
    
 
    '-------------------------------------
    'Process according to what is in the focus: an opened e-mail or a folder with selected e-mails.
    'Case 2 would also work for opened e-mail, however it does not always work (for instance if
    ' an e-mail is saved on the file system and being opened from there).
    '-------------------------------------

    Set myExplorer = Application.ActiveExplorer
    Set myfolder = myExplorer.CurrentFolder
    If myfolder Is Nothing Then Error 5001
    If Not myfolder.DefaultItemType = olMailItem Then GoTo ExitScript
    
    'Stop if more than x emails selected
    If myExplorer.Selection.Count > EXM_OPT_MAX_NO Then Error 5002
      
    'No email selected at all?
    If myExplorer.Selection.Count = 0 Then Error 5003
     
    Set olSelection = myExplorer.Selection
    intCountAll = 0
    intCountFailures = 0
    For Each myItem In olSelection
        intCountAll = intCountAll + 1
        vSuccess = ProcessEmail(myItem, strBackupPath)
        If (Not vSuccess = True) Then
            Select Case intCountFailures
                Case 0: strStatusMsg = vSuccess
                Case 1: strStatusMsg = "1x " & strStatusMsg & Chr(10) & "1x " & vSuccess
                Case Else: strStatusMsg = strStatusMsg & Chr(10) & "1x " & vSuccess
            End Select
            intCountFailures = intCountFailures + 1
        End If
    Next
    If intCountFailures = 0 Then
        strStatusMsg = intCountAll & " " & EXM_004
    End If

        
    'Final Message
    If (intCountFailures = 0) Then  'No failure occurred
        MsgBox strStatusMsg & Chr(10) & Chr(10) & EXM_003 & " " & strBackupPath, 64, EXM_018
    ElseIf (intCountAll = 1) Then   'Only one email was selected and a failure occurred
        MsgBox EXM_002 & Chr(10) & vSuccess & Chr(10) & Chr(10) & EXM_003 & " " & strBackupPath, 48, EXM_017
    Else    'More than one email was selected and at least one failure occurred
        strTemp1 = Replace(EXM_020, "[NO_OF_SELECTED_ITEMS]", intCountAll)
        strTemp1 = Replace(strTemp1, "[NO_OF_SUCCESS_ITEMS]", intCountAll - intCountFailures)
        strTemp2 = Replace(EXM_019, "[NO_OF_FAILURES]", intCountFailures)
        MsgBox strTemp1 & Chr(10) & Chr(10) & strTemp2 & Chr(10) & Chr(10) & strStatusMsg _
        & Chr(10) & Chr(10) & EXM_003 & " " & strBackupPath, 48, EXM_017
    End If


ExitScript:
    Exit Sub
ErrorHandler:
    Select Case Err.Number
    Case 5001:  'Not an email
        MsgBox EXM_010, 64, EXM_007
    Case 5002:
        MsgBox Replace(EXM_008, "[LIMIT_SELECTED_ITEMS]", EXM_OPT_MAX_NO), 64, EXM_007
    Case 5003:
        MsgBox EXM_009, 64, EXM_007
    Case 5004:
        MsgBox EXM_011 & Chr(10) & Chr(10) & strErrorMsg, 48, EXM_007
    Case Else:
        MsgBox EXM_011 & Chr(10) & Chr(10) _
        & Err & " - " & Error$ & Chr(10) & Chr(10) & EXM_012, 48, EXM_007
    End Select
    Resume ExitScript
End Sub

Private Function ProcessEmail(myItem As Object, 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 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 = "InMails"
  ElseIf InStr(1, F.folderPath, "Gesendete Elemente") Then
    strFolder = "OutMails"
  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
    
    strBackupPath = fso.BuildPath(strBackupPath, strFolderDate)
        If Not fso.FolderExists(strBackupPath) Then
            fso.CreateFolder (strBackupPath)
        End If
    
    If strFolder = "InMails" 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

Grüße
opiwahn

 

[Zvoni]

Für mich sieht das eher danach aus, dass der vorherige Pfad (1. Mail) als Startpunkt für den Pfad/Ordner der nächsten Mail verwendet wird. Womit ich wieder bei meiner API wäre aus deinem anderen thread, da brauchst du das ganze nicht, weil du Pfade direkt zusammenbauen kannst, ohne darauf achten zu müssen, wo im Ordner-Baum du gerade bist.

EDIT: Jap, ich sehs gerade. strBackupPath in ProcessMail ist als ByRef im Funktionskopf, bedeutet: Alle Manipulationen an strBackupPath innerhalb von ProcessMail kommen zurück an ExportEmailToDrive. Änder das mal auf ByVal ab

Private Function ProcessEmail(myItem As Object, ByVal strBackupPath As String) As Variant

 

[amn.ssy]

Geil - 5 kleine buchstaben und so 'ne große Wirkung ...

Danke Dir.
opiwahn