Outlook VBA, öffnen großes Explorerfenster

'==========================================================================  
'Export Outlook e-mail to drive  
'--------------------------------------------------------------------------  
'Author: Michael Wöhrer  
'Editor: Jon Richter  

'Version: 0.2, 2009-01-20  
'Version: 0.3, 2012-09-14 (added Outlook 64 compatibility)  
'==========================================================================  
'Terms and conditions  
'  You can use, redistribute and/or modify this code under the terms of  
'  the SOFTWARE GUIDE LICENSE. This code is distributed in the hope that it  
'  will be useful, but WITHOUT ANY WARRANTY; without even the implied  
'  warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  
'  See the SOFTWARE GUIDE LICENSE for more details.  
'==========================================================================  

Option Explicit

'-------------------------------------------------------------  
' OPTIONS  
'-------------------------------------------------------------  
'Email format:  
' MSG = Outlook msg format (incl. attachments, embedded objects etc.)., TXT = plain text  
Private Const EXM_OPT_MAILFORMAT As String = "MSG"  
'Date format of filename  
Private Const EXM_OPT_FILENAME_DATEFORMAT As String = "yyyymmdd_hhnnss"  
'Build filename; placeholders:  for date,  for sender's name,  for receiver,  for subject  
Private Const EXM_OPT_FILENAME_BUILD As String = "<DATE> - von[<SENDER>] zu[<RECEIVER>] - <SUBJECT>"  
'Use browse folder? Set to FALSE if you don't want to use browser for selecting target folder  
Private Const EXM_OPT_USEBROWSER As Boolean = True
'Target folder (used if EXM_OPT_USEBROWSER is set to FALSE)  
Private Const EXM_OPT_TARGETFOLDER As String = "D:\Postbox\"  
'Maximum number of emails to be selected & exported. Please don't use a huge number as this will cause  
'performance and maybe other issues. Recommended is a value between 5 and 20.  
Private Const EXM_OPT_MAX_NO As Integer = 200
'Email subject prefixes (such us "RE:", "FW:" etc.) to be removed. Please note that this is a  
'RegEx expression, google for "regex" for further information. For instance "\s" means blank " ".  
Private Const EXM_OPT_CLEANSUBJECT_REGEX As String = "RE:\s|Re:\s|AW:\s|FW:\s|WG:\s|SV:\s|Antwort:\s"  
'-------------------------------------------------------------  


'-------------------------------------------------------------  
' TRANSLATIONS  
'-------------------------------------------------------------  

Private Const EXM_001 As String = "Die E-Mail wurde erfolgreich abgelegt."  
Private Const EXM_002 As String = "Die E-Mail konnte nicht abgelegt werden, Grund:"  
Private Const EXM_003 As String = "Ausgewählter Pfad:"  
Private Const EXM_004 As String = "E-Mail(s) ausgewählt und erfolgreich abgelegt."  
Private Const EXM_005 As String = ""  
Private Const EXM_006 As String = ""  
Private Const EXM_007 As String = "Script abgebrochen"  
Private Const EXM_008 As String = "Fehler aufgetreten: Sie haben mehr als [LIMIT_SELECTED_ITEMS] E-Mails ausgewählt. Die Aktion wurde beendet."  
Private Const EXM_009 As String = "Es wurde keine E-Mail ausgewählt."  
Private Const EXM_010 As String = "Es ist ein Fehler aufgetreten: es war keine Email im Fokus, so dass die Ablage nicht erfolgen konnte."  
Private Const EXM_011 As String = "Es ist ein Fehler aufgetreten:"  
Private Const EXM_012 As String = "Die Aktion wurde beendet."  
Private Const EXM_013 As String = "Ausgewähltes Outlook-Dokument ist keine E-Mail"  
Private Const EXM_014 As String = "Datei existiert bereits"  
Private Const EXM_015 As String = ""  
Private Const EXM_016 As String = "Bitte wählen Sie den Ordner zum Exportieren:"  
Private Const EXM_017 As String = "Fehler beim Exportieren aufgetreten"  
Private Const EXM_018 As String = "Export erfolgreich"  
Private Const EXM_019 As String = "Bei [NO_OF_FAILURES] E-Mail(s) ist ein Fehler aufgetreten:"  
Private Const EXM_020 As String = "[NO_OF_SELECTED_ITEMS] E-Mail(s) wurden ausgewählt und [NO_OF_SUCCESS_ITEMS] E-Mail(s) erfolgreich abgelegt."  

Public Sub ExportEmailToDrive()
   
    Const PROCNAME As String = "ExportEmailToDrive"  
   
    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 myMailItem As MailItem
    Dim strDate 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 strAnswerInputBox As String
    
    If TypeOf myItem Is MailItem Then
         Set myMailItem = myItem
    Else
        Error 1001
    End If

    'Set filename  
    strDate = Format(myMailItem.SentOn, 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>", strDate)  
    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)
    strFullPath = 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 CreateObject("Scripting.FileSystemObject").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


Private Function CleanString(strData As String) As String

    Const PROCNAME As String = "CleanString"  

    On Error GoTo ErrorHandler

    'Instantiate RegEx  
    Dim objRegExp As Object
    Set objRegExp = CreateObject("VBScript.RegExp")  
    objRegExp.Global = True

    'Cut out strings we don't like  
    objRegExp.Pattern = EXM_OPT_CLEANSUBJECT_REGEX
    strData = objRegExp.Replace(strData, "")  

    'Replace and cut out invalid strings.  
    strData = Replace(strData, Chr(9), "_")  
    strData = Replace(strData, Chr(10), "_")  
    strData = Replace(strData, Chr(13), "_")  
    objRegExp.Pattern = "[/*]"  
    strData = objRegExp.Replace(strData, "-")  
    objRegExp.Pattern = "[""]"  
    strData = objRegExp.Replace(strData, "'")  
    objRegExp.Pattern = "[:?<>|]"  
    strData = objRegExp.Replace(strData, "")  
   
    'Replace multiple chars by 1 char  
    objRegExp.Pattern = "s+"  
    strData = objRegExp.Replace(strData, " ")  
    objRegExp.Pattern = "_+"  
    strData = objRegExp.Replace(strData, "_")  
    objRegExp.Pattern = "-+"  
    strData = objRegExp.Replace(strData, "-")  
    objRegExp.Pattern = "'+"  
    strData = objRegExp.Replace(strData, "'")  
           
    'Trim  
    strData = Trim(strData)
   
    'Return result  
    CleanString = strData
 
 
ExitScript:
    Exit Function
ErrorHandler:
    CleanString = "ERROR_OCCURRED:" & "Error #" & Err & ": " & Error$ & " (Procedure: " & PROCNAME & ")"  
    Resume ExitScript
End Function
Private Function GetFileDir() As String
'Änderung zum Standardcode. Hiermit wird ein einfaches Windowsfenster in einem vorgegebenen Startordner geöffnet.  

Const WINDOW_HANDLE = 0
Const NO_OPTIONS = 0
Dim sPath
Dim objShell
Dim objFolder
Dim objFolderItem

On Error Resume Next

Set objShell = CreateObject("Shell.Application")  
Set objFolder = objShell.BrowseForFolder(WINDOW_HANDLE, "Select folder:", NO_OPTIONS, "D:\Postbox") ' Hier den gewünschten Startordner angeben!  
Set objFolderItem = objFolder.Self
sPath = objFolderItem.Path
   
GetFileDir = sPath
End Function

Private Function GetFileDir(Optional ByVal RootFolder = 17) As String
   
    Const PROCNAME As String = "GetFileDir"  

    On Error GoTo ErrorHandler

    Dim AppShell As Object
    Dim BrowseDir As Object

    Set AppShell = CreateObject("Shell.Application")  
    Set BrowseDir = AppShell.BrowseForFolder(0, "Ordner auswählen", &H1000, RootFolder)  

    If Not BrowseDir Is Nothing Then
        GetFileDir = BrowseDir.Items().Item().Path
    End If
    
ExitScript:
    Exit Function
ErrorHandler:
    GetFileDir = "ERROR_OCCURRED:" & "Error #" & Err & ": " & Error$ & " (Procedure: " & PROCNAME & ")"  
    Resume ExitScript
End Function