Private Const EXM_OPT_MAILFORMAT As String = "msg"
Private Const EXM_OPT_FILENAME_DATEFORMAT As String = "yyyy-mm-dd hh.nn.ss "
receiver, for subject
Private Const EXM_OPT_FILENAME_BUILD As String = " - "
Private Const EXM_OPT_USEBROWSER As Boolean = True
Ordnerauswahlfenster
Private Const EXM_OPT_TARGETFOLDER As String = "C:\"
will cause
Private Const EXM_OPT_MAX_NO As Integer = 3000
_
. Argumente für Gänsefüsschen "RE:\s|Re:\s|AW:\s|FW:\s|WG:\s|SV:\s|Antwort:\s"
Private Const EXM_OPT_CLEANSUBJECT_REGEX As String = ""
_
0
Private Const finalmessage As Integer = 1
Private Const loeschen As Boolean = 0
Private Const explorer_oeffnen As Boolean = False
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 DateiSpeichernAlsName As String
Declare Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" _
(lpofn As OPENFILENAME) As Long
Declare Function FindWindow Lib "User32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" _
(ByVal lpModuleName As String) As Long
Public A$
Public Const HandCursor = 32649&
Public Const OFN_EXTENSIONDIFFERENT = &H400&
Public Const OFN_PATHMUSTEXIST = &H800
Public NeuProfil As String
Type OPENFILENAME
lStructSize As Long
hwndOwner As Long
hInstance As Long
lpstrFilter As String
lpstrCustomFilter As String
nMaxCustomFilter As Long
nFilterIndex As Long
lpstrFile As String
nMaxFile As Long
lpstrFileTitle As String
nMaxFileTitle As Long
lpstrInitialDir As String
lpstrTitle As String
flags As Long
nFileOffset As Integer
nFilextension As Integer
lpstrDefExt As String
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type
Public Sub ExportEmailToDrive2()
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 vSuccess2 As Variant
Dim strTemp1 As String
Dim strTemp2 As String
Dim strErrorMsg As String
If (EXM_OPT_USEBROWSER = True) Then
strBackupPath = getfiledir(EXM_OPT_TARGETFOLDER, EXM_OPT_MAILFORMAT)
_
Funktion auf getfiledir, die das Fenster für Ordnerwahl öffnet
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 & "\"
mails.
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)
_
gibt Wert 1 zurück
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 (finalmessage = 1) Then
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
End If
If (loeschen = True) Then
On Error Resume Next
Dim objFolder As Outlook.MAPIFolder, objInbox As Outlook.MAPIFolder
Dim objNS As Outlook.NameSpace, objItem As Outlook.MailItem
Set objNS = Application.GetNamespace("MAPI")
Set objInbox = objNS.GetDefaultFolder(olFolderInbox)
Set objFolder = objInbox.Parent.Folders("Gelöschte Elemente")
If objFolder Is Nothing Then
MsgBox "DATEI WURDE ABGELEGT!", vbOKOnly + vbExclamation, "FILE SAVED"
End If
If Application.ActiveExplorer.Selection.Count = 0 Then
Exit Sub
End If
For Each objItem In Application.ActiveExplorer.Selection
objItem.UnRead = False
If objFolder.DefaultItemType = olMailItem Then
If objItem.Class = olMail Then
objItem.Move objFolder
End If
End If
Next
Set objItem = Nothing
Set objFolder = Nothing
Set objInbox = Nothing
Set objNS = Nothing
End If
If (explorer_oeffnen = True) Then
Shell "explorer.exe " & EXM_OPT_TARGETFOLDER, vbNormalFocus
Else
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
Private 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 success As Variant
Dim intI 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, "", StrDate)
strFinalFileName = Replace(strFinalFileName, "", strSender)
strFinalFileName = Replace(strFinalFileName, "", strReceiver)
strFinalFileName = Replace(strFinalFileName, "", StrSubject)
strFinalFileName = CleanString(strFinalFileName)
If Left(strFinalFileName, 15) = "ERROR_OCCURRED:" Then
strErrorMsg = Mid(strFinalFileName, 16, 9999)
Error 1003
End If
strFinalFileName = IIf(Len(strFinalFileName) > 100, Left(strFinalFileName, 100), _
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
strFinalFileName = Left(strFullPath, InStrRev(strFullPath, ".") - 1)
intI = 0
Do While CreateObject("Scripting.FileSystemObject").FileExists(strFullPath) = True
intI = intI + 1
strFullPath = strFinalFileName & "(" & Format(intI, "0") & ")" & ".msg"
Loop
myMailItem.SaveAs strFullPath, vExtConst
_
= Pfad&Name; vExtConst=Dateityp
success = AttributeSetzen(strFullPath, strSender, strReceiver, StrSubject)
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(saveAspath As String, DateiEndung As String) As String
Const PROCNAME As String = "GetFileDir"
On Error GoTo ErrorHandler
Dim DateiName As String
Dim FilterName As String
Dim SpeichernAls As OPENFILENAME
Dim ExistiertDatei
Dim i As Integer
DateiName = "Pls press only the SAVE button"
FilterName = "outlook"
DateiEndung = "*." & DateiEndung
With SpeichernAls
.lStructSize = Len(SpeichernAls)
.hwndOwner = FindWindow("XLMAIN", "Outlook")
.hInstance = GetModuleHandle("Outlook.EXE")
.lpstrFilter = FilterName & DateiEndung & vbNullChar & DateiEndung & vbNullChar & _
vbNullChar
.lpstrCustomFilter = vbNullString
.nFilterIndex = 1
DateiName = Replace(DateiName, ":", "")
.lpstrFile = DateiName & Space(255) & vbNullChar
.nMaxFile = Len(.lpstrFile)
.lpstrFileTitle = Len(.lpstrFileTitle)
.lpstrInitialDir = saveAspath
.lpstrTitle = "Email speichern"
.flags = OFN_EXTENSIONDIFFERENT
End With
If GetSaveFileName(SpeichernAls) = 0 Then
_
als übergabewert ist Abbruchbedingung
getfiledir = ""
GoTo ErrorHandler
End If
getfiledir = SpeichernAls.lpstrFile
getfiledir = Left(getfiledir, InStr(1, getfiledir, "Pls press only the SAVE button") - 1)
DateiEndung
ExitScript:
Exit Function
ErrorHandler:
getfiledir = "ERROR_OCCURRED:" & "Error #" & Err & ": " & Error$ & " (Procedure: " & _
PROCNAME & ")"
Resume ExitScript
End Function
Private Function AttributeSetzen(DateiPfad As String, Sender As String, Empfaenger As String, _
_
Betreff As String)
Const PROCNAME As String = "AttributeSetzen"
Dim objFilePropReader As Object
Dim objDocProp As Object
On Error Resume Next
Set objFilePropReader = CreateObject("DSOFile.OleDocumentProperties")
objFilePropReader.Open DateiPfad
Set objDocProp = objFilePropReader.summaryproperties
Debug.Print objDocProp.Title
With objDocProp
.Author = Sender
.Keywords = Empfaenger
.Title = Betreff
End With
objFilePropReader.Save
objFilePropReader.Close
Set objDocProp = Nothing
AttributeSetzen = 1
End Function
Moin Zusammen,
vlcht hat jemand eine Idee und Zeit / Interesse mir bei dieser Aufgabe behilflich zu sein.
Ich benutze folgendes Makro in Outlook zum abspeichern von E-Mails auf der Festplatte. Hier selektiere ich eine oder mehrere E-Mails und lege diese mittels Auswahl über Dialogmenue in einem ausgesuchten Pfad ab.
Die Ordnerstruktur ist dabei wie folgt:
C:\OrdnerA\Fall1
C:\OrdnerA\Fall2
C:\OrdnerA\Fall3
C:\OrdnerB\Fall1
C:\OrdnerB\Fall2
C:\OrdnerB\Fall3
etc jeder Übergeordnete Ordner enthält bis zu 300 Unterordner
d.h. ich muss im Prinzip für jede Email im Dialog den richtigen Übergeordneten Ordner selektieren und diese dem richtigen Unterordner(Fall)
zusortieren,. Bei 300 Emails eine richtige qual und zeitraubend.
Die Emails enthalten im Betreff jedoch immer eine zuordenbare Zeichenfolge nach der auch die Unterordner benannt sind.
Jetzt wäre es klasse wenn beim speichern von mehreren Emails:
1) ich angeben könnte das der Pfad im OrdnerA befindet
2) die Variable ( #????#### ) im Betreff der E-Mail befindet
3) pfad aus 1) + Variable ( #????#### ) = speicherort auf der Festplatte
Das soll für jede E-mail im einzelnen erfolgen.
Meint Ihr sowas ist irgendwie möglich ? Option Explicit
Private Const EXM_OPT_MAILFORMAT As String = "msg"
Private Const EXM_OPT_FILENAME_DATEFORMAT As String = "yyyy-mm-dd hh.nn.ss "
receiver, for subject
Private Const EXM_OPT_FILENAME_BUILD As String = " - "
Private Const EXM_OPT_USEBROWSER As Boolean = True
Ordnerauswahlfenster
Private Const EXM_OPT_TARGETFOLDER As String = "C:\"
will cause
Private Const EXM_OPT_MAX_NO As Integer = 3000
_
. Argumente für Gänsefüsschen "RE:\s|Re:\s|AW:\s|FW:\s|WG:\s|SV:\s|Antwort:\s"
Private Const EXM_OPT_CLEANSUBJECT_REGEX As String = ""
_
0
Private Const finalmessage As Integer = 1
Private Const loeschen As Boolean = 0
Private Const explorer_oeffnen As Boolean = False
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 DateiSpeichernAlsName As String
Declare Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" _
(lpofn As OPENFILENAME) As Long
Declare Function FindWindow Lib "User32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" _
(ByVal lpModuleName As String) As Long
Public A$
Public Const HandCursor = 32649&
Public Const OFN_EXTENSIONDIFFERENT = &H400&
Public Const OFN_PATHMUSTEXIST = &H800
Public NeuProfil As String
Type OPENFILENAME
lStructSize As Long
hwndOwner As Long
hInstance As Long
lpstrFilter As String
lpstrCustomFilter As String
nMaxCustomFilter As Long
nFilterIndex As Long
lpstrFile As String
nMaxFile As Long
lpstrFileTitle As String
nMaxFileTitle As Long
lpstrInitialDir As String
lpstrTitle As String
flags As Long
nFileOffset As Integer
nFilextension As Integer
lpstrDefExt As String
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type
Public Sub ExportEmailToDrive2()
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 vSuccess2 As Variant
Dim strTemp1 As String
Dim strTemp2 As String
Dim strErrorMsg As String
If (EXM_OPT_USEBROWSER = True) Then
strBackupPath = getfiledir(EXM_OPT_TARGETFOLDER, EXM_OPT_MAILFORMAT)
_
Funktion auf getfiledir, die das Fenster für Ordnerwahl öffnet
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 & "\"
mails.
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)
_
gibt Wert 1 zurück
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 (finalmessage = 1) Then
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
End If
If (loeschen = True) Then
On Error Resume Next
Dim objFolder As Outlook.MAPIFolder, objInbox As Outlook.MAPIFolder
Dim objNS As Outlook.NameSpace, objItem As Outlook.MailItem
Set objNS = Application.GetNamespace("MAPI")
Set objInbox = objNS.GetDefaultFolder(olFolderInbox)
Set objFolder = objInbox.Parent.Folders("Gelöschte Elemente")
If objFolder Is Nothing Then
MsgBox "DATEI WURDE ABGELEGT!", vbOKOnly + vbExclamation, "FILE SAVED"
End If
If Application.ActiveExplorer.Selection.Count = 0 Then
Exit Sub
End If
For Each objItem In Application.ActiveExplorer.Selection
objItem.UnRead = False
If objFolder.DefaultItemType = olMailItem Then
If objItem.Class = olMail Then
objItem.Move objFolder
End If
End If
Next
Set objItem = Nothing
Set objFolder = Nothing
Set objInbox = Nothing
Set objNS = Nothing
End If
If (explorer_oeffnen = True) Then
Shell "explorer.exe " & EXM_OPT_TARGETFOLDER, vbNormalFocus
Else
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
Private 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 success As Variant
Dim intI 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, "", StrDate)
strFinalFileName = Replace(strFinalFileName, "", strSender)
strFinalFileName = Replace(strFinalFileName, "", strReceiver)
strFinalFileName = Replace(strFinalFileName, "", StrSubject)
strFinalFileName = CleanString(strFinalFileName)
If Left(strFinalFileName, 15) = "ERROR_OCCURRED:" Then
strErrorMsg = Mid(strFinalFileName, 16, 9999)
Error 1003
End If
strFinalFileName = IIf(Len(strFinalFileName) > 100, Left(strFinalFileName, 100), _
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
strFinalFileName = Left(strFullPath, InStrRev(strFullPath, ".") - 1)
intI = 0
Do While CreateObject("Scripting.FileSystemObject").FileExists(strFullPath) = True
intI = intI + 1
strFullPath = strFinalFileName & "(" & Format(intI, "0") & ")" & ".msg"
Loop
myMailItem.SaveAs strFullPath, vExtConst
_
= Pfad&Name; vExtConst=Dateityp
success = AttributeSetzen(strFullPath, strSender, strReceiver, StrSubject)
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(saveAspath As String, DateiEndung As String) As String
Const PROCNAME As String = "GetFileDir"
On Error GoTo ErrorHandler
Dim DateiName As String
Dim FilterName As String
Dim SpeichernAls As OPENFILENAME
Dim ExistiertDatei
Dim i As Integer
DateiName = "Pls press only the SAVE button"
FilterName = "outlook"
DateiEndung = "*." & DateiEndung
With SpeichernAls
.lStructSize = Len(SpeichernAls)
.hwndOwner = FindWindow("XLMAIN", "Outlook")
.hInstance = GetModuleHandle("Outlook.EXE")
.lpstrFilter = FilterName & DateiEndung & vbNullChar & DateiEndung & vbNullChar & _
vbNullChar
.lpstrCustomFilter = vbNullString
.nFilterIndex = 1
DateiName = Replace(DateiName, ":", "")
.lpstrFile = DateiName & Space(255) & vbNullChar
.nMaxFile = Len(.lpstrFile)
.lpstrFileTitle = Len(.lpstrFileTitle)
.lpstrInitialDir = saveAspath
.lpstrTitle = "Email speichern"
.flags = OFN_EXTENSIONDIFFERENT
End With
If GetSaveFileName(SpeichernAls) = 0 Then
_
als übergabewert ist Abbruchbedingung
getfiledir = ""
GoTo ErrorHandler
End If
getfiledir = SpeichernAls.lpstrFile
getfiledir = Left(getfiledir, InStr(1, getfiledir, "Pls press only the SAVE button") - 1)
DateiEndung
ExitScript:
Exit Function
ErrorHandler:
getfiledir = "ERROR_OCCURRED:" & "Error #" & Err & ": " & Error$ & " (Procedure: " & _
PROCNAME & ")"
Resume ExitScript
End Function
Private Function AttributeSetzen(DateiPfad As String, Sender As String, Empfaenger As String, _
_
Betreff As String)
Const PROCNAME As String = "AttributeSetzen"
Dim objFilePropReader As Object
Dim objDocProp As Object
On Error Resume Next
Set objFilePropReader = CreateObject("DSOFile.OleDocumentProperties")
objFilePropReader.Open DateiPfad
Set objDocProp = objFilePropReader.summaryproperties
Debug.Print objDocProp.Title
With objDocProp
.Author = Sender
.Keywords = Empfaenger
.Title = Betreff
End With
objFilePropReader.Save
objFilePropReader.Close
Set objDocProp = Nothing
AttributeSetzen = 1
End Function