Guten Abend zusammen,
ich habe soeben einen Code erstellt, der über ein Makro in Outlook ausgeführt wird. Damit soll eine Mail inklusive Datum und Uhrzeit abgespeichert werden unter einem Ordner, den man selbst aussucht.
1. Frage: Leider gefällt mir das Speichern unter Layout nicht so ganz:
Dies ist das derzeit angezeigte:
Hat jemand eine Idee wie man den Code anpassen muss um folgendes Layout zu bekommen?
2. Frage: Kennt jemand eine Code Anpassung um nach dem Datum und der Uhrzeit den Absendername oder die Absendermailadresse im Betreff mit auszugeben?
Nachfolgend noch der aktuell verwendete Code.
Vielen Dank im Voraus für Eure Unterstützung! :)
Viele Grüße
Kristian
Sub SaveSelectedMailsWithDate()
Dim mail As MailItem, strNewSubject As String, strNewFilePath As String, objFolder As Object, OUTPUTPATH As String
' max Anzahl an zu übernehmenden Zeichen des Subjects
Const MAXSUBJECTCHARS = 30
' Filesystem Object erstellen
Set fso = CreateObject("Scripting.FileSystemObject")
Set objShell = CreateObject("Shell.Application")
' Ausgabeordner mit FolderBrowserDialog abfragen
Set objFolder = objShell.BrowseForFolder(0, "Ausgabe-Ordner angeben", &H10)
' prüfe auf gültigen Pfad
If fso.FolderExists(objFolder.Self.Path) Then
OUTPUTPATH = objFolder.Self.Path
Else
MsgBox "Ungültiger Pfad!", vbExclamation
Exit Sub
End If
With ActiveExplorer
' wenn eine Auswahl besteht ...
If .Selection.Count > 0 Then
' verarbeite alle markierten Mails
For Each obj In .Selection
If obj.Class = olMail Then
Set mail = obj
' ersetze illegale Zeichen durch underscores
strNewSubject = Trim(ReplaceIllegalChars(mail.Subject))
' wenn das Subject durch die Änderung leer istm benutze als Namen der Datei die eindeutige Outlook-EntryID
If strNewSubject = "" Then
strNewSubject = mail.EntryID
End If
' kürze den Betreff wenn die definierte maximale Zeichenanzahl erreicht ist
If Len(strNewSubject) > MAXSUBJECTCHARS Then
strNewSubject = Left(strNewSubject, MAXSUBJECTCHARS) & "..."
End If
' baue den neuen Pfad zusammen
strNewFilePath = fso.BuildPath(OUTPUTPATH, Format(mail.ReceivedTime, "yyyymmdd_hh.mm") & "_" & strNewSubject & ".msg")
' sollte der Name bereits im Ausgabeordner existieren, hänge die Datum-Ticks als Randomizer an den Dateinamen an
While fso.FileExists(strNewFilePath)
ticks = DateDiff("s", #1/1/1970#, Now())
strNewFilePath = fso.BuildPath(OUTPUTPATH, Format(mail.ReceivedTime, "yyyymmdd_hh.mm") & "_" & strNewSubject & "_" & ticks & ".msg")
Wend
' speichere Mail als MSG(Unicode-Format)
mail.SaveAs strNewFilePath, olMSGUnicode
End If
Next
Else
' Keine Mail für den Export markiert
MsgBox "Bitte mindestens eine E-Mail für den Export markieren!", vbExclamation
End If
End With
MsgBox "Export abgeschlossen.", vbInformation
End Sub
' Illegale Pfadzeichen ersetzen
Function ReplaceIllegalChars(strText)
Set regex = CreateObject("vbscript.regexp")
regex.Pattern = "[\\/:?<>|""*]"
regex.Global = True
ReplaceIllegalChars = regex.Replace(strText, "_")
Set regex = Nothing
End Function
ich habe soeben einen Code erstellt, der über ein Makro in Outlook ausgeführt wird. Damit soll eine Mail inklusive Datum und Uhrzeit abgespeichert werden unter einem Ordner, den man selbst aussucht.
1. Frage: Leider gefällt mir das Speichern unter Layout nicht so ganz:
Dies ist das derzeit angezeigte:
Hat jemand eine Idee wie man den Code anpassen muss um folgendes Layout zu bekommen?
2. Frage: Kennt jemand eine Code Anpassung um nach dem Datum und der Uhrzeit den Absendername oder die Absendermailadresse im Betreff mit auszugeben?
Nachfolgend noch der aktuell verwendete Code.
Vielen Dank im Voraus für Eure Unterstützung! :)
Viele Grüße
Kristian
Sub SaveSelectedMailsWithDate()
Dim mail As MailItem, strNewSubject As String, strNewFilePath As String, objFolder As Object, OUTPUTPATH As String
' max Anzahl an zu übernehmenden Zeichen des Subjects
Const MAXSUBJECTCHARS = 30
' Filesystem Object erstellen
Set fso = CreateObject("Scripting.FileSystemObject")
Set objShell = CreateObject("Shell.Application")
' Ausgabeordner mit FolderBrowserDialog abfragen
Set objFolder = objShell.BrowseForFolder(0, "Ausgabe-Ordner angeben", &H10)
' prüfe auf gültigen Pfad
If fso.FolderExists(objFolder.Self.Path) Then
OUTPUTPATH = objFolder.Self.Path
Else
MsgBox "Ungültiger Pfad!", vbExclamation
Exit Sub
End If
With ActiveExplorer
' wenn eine Auswahl besteht ...
If .Selection.Count > 0 Then
' verarbeite alle markierten Mails
For Each obj In .Selection
If obj.Class = olMail Then
Set mail = obj
' ersetze illegale Zeichen durch underscores
strNewSubject = Trim(ReplaceIllegalChars(mail.Subject))
' wenn das Subject durch die Änderung leer istm benutze als Namen der Datei die eindeutige Outlook-EntryID
If strNewSubject = "" Then
strNewSubject = mail.EntryID
End If
' kürze den Betreff wenn die definierte maximale Zeichenanzahl erreicht ist
If Len(strNewSubject) > MAXSUBJECTCHARS Then
strNewSubject = Left(strNewSubject, MAXSUBJECTCHARS) & "..."
End If
' baue den neuen Pfad zusammen
strNewFilePath = fso.BuildPath(OUTPUTPATH, Format(mail.ReceivedTime, "yyyymmdd_hh.mm") & "_" & strNewSubject & ".msg")
' sollte der Name bereits im Ausgabeordner existieren, hänge die Datum-Ticks als Randomizer an den Dateinamen an
While fso.FileExists(strNewFilePath)
ticks = DateDiff("s", #1/1/1970#, Now())
strNewFilePath = fso.BuildPath(OUTPUTPATH, Format(mail.ReceivedTime, "yyyymmdd_hh.mm") & "_" & strNewSubject & "_" & ticks & ".msg")
Wend
' speichere Mail als MSG(Unicode-Format)
mail.SaveAs strNewFilePath, olMSGUnicode
End If
Next
Else
' Keine Mail für den Export markiert
MsgBox "Bitte mindestens eine E-Mail für den Export markieren!", vbExclamation
End If
End With
MsgBox "Export abgeschlossen.", vbInformation
End Sub
' Illegale Pfadzeichen ersetzen
Function ReplaceIllegalChars(strText)
Set regex = CreateObject("vbscript.regexp")
regex.Pattern = "[\\/:?<>|""*]"
regex.Global = True
ReplaceIllegalChars = regex.Replace(strText, "_")
Set regex = Nothing
End Function