Mail Ablage automatisieren

Option Explicit

'-------------------------------------------------------------  
' Einstellungen  
'-------------------------------------------------------------  
'Email format:  
' MSG , TXT = plain text  
Private Const EXM_OPT_MAILFORMAT As String = "MSG"  
'Datums Format für File Name  
Private Const EXM_OPT_FILENAME_DATEFORMAT As String = "yyyy-mm-dd_hh-nn-ss"  
'Aufbauen des Filenamen  
Private Const EXM_OPT_FILENAME_BUILD As String = "<DATE>_<SUBJECT>"  
'festen Verzeichnisnamen nutzen  
Private Const EXM_OPT_USEBROWSER As Boolean = True
'festes Verzeichnis angeben  
Private Const EXM_OPT_TARGETFOLDER As String = "Y:\"  
'max. Anzahl der zu kopierenden Mails empfohlener Wert 10 max. 20  
Private Const EXM_OPT_MAX_NO As Integer = 10
'Email subject Einstellungen  
Private Const EXM_OPT_CLEANSUBJECT_REGEX As String = "RE:\s|Re:\s|AW:\s|FW:\s|WG:\s|SV:\s|Antwort:\s"  
'-------------------------------------------------------------  



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 = "<FREE>"  
Private Const EXM_006 As String = "<FREE>"  
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 = "<FREE>"  
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."  
'-------------------------------------------------------------  



Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long  
Private Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As Long  
Private Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long, ByVal lpBuffer As String) As Long  
Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As Long)  
Private Const BIF_RETURNONLYFSDIRS = 1
Private Const MAX_PATH = 260
Private Type BrowseInfo

    hwndOwner As Long
    pIDLRoot As Long
    pszDisplayName As Long
    lpszTitle As Long
    ulFlags As Long
    lpfnCallback As Long
    lParam As Long
    iImage As Long
End Type

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
 
    '-------------------------------------  
    'Ziellaufwerk  
    '-------------------------------------  
    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 & "\"  
    
    
 
    '-------------------------------------  
    'Ablauf um zu erkennen ob es sich um einen Ordner mit E-Mails oder eine einzelne zu kopierende handelt  
    '-------------------------------------  

    Set myExplorer = Application.ActiveExplorer
    Set myfolder = myExplorer.CurrentFolder
    If myfolder Is Nothing Then Error 5001
    If Not myfolder.DefaultItemType = olMailItem Then GoTo ExitScript
    
    'Abruch wenn mehr als die fest eingestellte Anzahl vom Mails kopiert werden  
    If myExplorer.Selection.Count > EXM_OPT_MAX_NO Then Error 5002
      
    'keine E-Mails ausgewählt  
    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

        
    'Abschlussmeldungen  
    If (intCountFailures = 0) Then  'keine Fehler  
        MsgBox strStatusMsg & Chr(10) & Chr(10) & EXM_003 & " " & strBackupPath, 64, EXM_018  
    ElseIf (intCountAll = 1) Then   'nur eine Mail ausgewählt aber es ist ein Fehler aufgetreten  
        MsgBox EXM_002 & Chr(10) & vSuccess & Chr(10) & Chr(10) & EXM_003 & " " & strBackupPath, 48, EXM_017  
    Else    'mehr als eine Mail ausgewählt aber es ist ein Fehler aufgetreten  
        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:  'keine 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
    'speichert die Mails unter dem angegebenen Pfad.  
    'liefert wahr zurück, wenn erfolgreich, ansonsten falsch.  

    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

    If TypeOf myItem Is MailItem Then
         Set myMailItem = myItem
    Else
        Error 1001
    End If

    
    strDate = Format(myMailItem.ReceivedTime, EXM_OPT_FILENAME_DATEFORMAT)
    strSender = myMailItem.SenderName
    strReceiver = myMailItem.To
    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
    
    'Speichern als msg oder text  
    Select Case UCase(EXM_OPT_MAILFORMAT)
        Case "MSG":  
            strFullPath = strFullPath & ".msg"  
            vExtConst = olMSG
        Case Else:
            strFullPath = strFullPath & ".txt"  
            vExtConst = olTXT
    End Select
    'existiert das File bereits  
    If CreateObject("Scripting.FileSystemObject").FileExists(strFullPath) = True Then  
        Error 1002
    End If
    
    'Speichern  
    myMailItem.SaveAs strFullPath, vExtConst
    
    'liefert wahr zurück wenn erfolgreich  
    ProcessEmail = True

ExitScript:
    Exit Function
ErrorHandler:
    Select Case Err.Number
    Case 1001:
        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

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

    
    objRegExp.Pattern = EXM_OPT_CLEANSUBJECT_REGEX
    strData = objRegExp.Replace(strData, "")  

    
    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, "")  
    
    
    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, "'")  
            
    
    strData = Trim(strData)
    
    
    CleanString = strData
  
  
ExitScript:
    Exit Function
ErrorHandler:
    CleanString = "ERROR_OCCURRED:" & "Error #" & Err & ": " & Error$ & " (Procedure: " & PROCNAME & ")"  
    Resume ExitScript
End Function

Private Function GetFileDir() As String
    
    Const PROCNAME As String = "GetFileDir"  

    On Error GoTo ErrorHandler

    Dim ret As String
    Dim lpIDList As Long
    Dim sPath As String
    Dim udtBI As BrowseInfo
    Dim RdStrings() As String
    Dim nNewFiles As Long

    
    With udtBI
        .lpszTitle = lstrcat(EXM_016, "")  
        .ulFlags = BIF_RETURNONLYFSDIRS
    End With

    lpIDList = SHBrowseForFolder(udtBI)
    If lpIDList = 0 Then Exit Function
       
    
    sPath = String$(MAX_PATH, 0)
    SHGetPathFromIDList lpIDList, sPath
    CoTaskMemFree lpIDList
    
    
    If (InStr(sPath, Chr$(0)) > 0) Then sPath = Left$(sPath, InStr(sPath, Chr(0)) - 1)

    
    GetFileDir = sPath

ExitScript:
    Exit Function
ErrorHandler:
    GetFileDir = "ERROR_OCCURRED:" & "Error #" & Err & ": " & Error$ & " (Procedure: " & PROCNAME & ")"  
    Resume ExitScript
End Function