Option
Explicit
Private
Const
EXM_OPT_MAILFORMAT
As
String
=
"MSG"
Private
Const
EXM_OPT_FILENAME_DATEFORMAT
As
String
=
"yyyy-mm-dd_hh-nn-ss"
Private
Const
EXM_OPT_FILENAME_BUILD
As
String
=
"<DATE>_<SUBJECT>"
Private
Const
EXM_OPT_USEBROWSER
As
Boolean
=
True
Private
Const
EXM_OPT_ROOTFOLDER
As
String
= "G:\"
Private
Const
EXM_OPT_TARGETFOLDER
As
String
= "D:\"
Private
Const
EXM_OPT_MAX_NO
As
Integer
= 10
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."
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
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 & "
\"
Set
myExplorer = Application.ActiveExplorer
Set
myfolder = myExplorer.CurrentFolder
If
myfolder
Is
Nothing
Then
Error
5001
If
Not
myfolder.DefaultItemType = olMailItem
Then
GoTo
ExitScript
If
myExplorer.Selection.Count > EXM_OPT_MAX_NO
Then
Error
5002
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
If
(intCountFailures = 0)
Then
MsgBox strStatusMsg & Chr(10) & Chr(10) & EXM_003 &
" "
& strBackupPath, 64, EXM_018
ElseIf
(intCountAll = 1)
Then
MsgBox EXM_002 & Chr(10) & vSuccess & Chr(10) & Chr(10) & EXM_003 &
" "
& strBackupPath, 48, EXM_017
Else
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:
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
Public
Function
ProcessEmail(myItem
As
Object
, strBackupPath
As
String
)
As
Variant
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
Eingang
As
String
Eingang =
"E"
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
Select
Case
UCase(EXM_OPT_MAILFORMAT)
Case
"MSG"
:
strFullPath = strFullPath &
".msg"
vExtConst = olMSG
Case
Else
:
strFullPath = strFullPath &
".txt"
vExtConst = olTXT
End
Select
If
CreateObject(
"Scripting.FileSystemObject"
).FileExists(strFullPath) =
True
Then
Error
1002
End
If
myMailItem.SaveAs strFullPath, vExtConst
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
fso
As
Object
Set
fso = CreateObject(
"Scripting.FileSystemObject"
)
If
Not
fso.FolderExists(EXM_OPT_ROOTFOLDER)
Then
MsgBox
"Das Verzeichnis '"
& EXM_OPT_ROOTFOLDER &
"' existiert nicht!"
, vbExclamation
Set
fso =
Nothing
Exit
Function
End
If
Set
fso =
Nothing
GetFileDir = VerzeichnisSuchen(
"Bitte wählen Sie ein Ausgabeverzeichnis"
, EXM_OPT_ROOTFOLDER)
ExitScript:
Exit
Function
ErrorHandler:
GetFileDir =
"ERROR_OCCURRED:"
&
"Error #"
& Err &
": "
&
Error
$ &
" (Procedure: "
& PROCNAME &
")"
Resume
ExitScript
End
Function