VBA Outlook Makro anpassen zu Speichern unter Fenster und Absender Ergänzung

Dieser Thread ist Teil einer Diskussion zu einem Artikel:  Zum News-Artikel gehen
K

Kriskr23

Neues Mitglied
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:
1703878511140.png

Hat jemand eine Idee wie man den Code anpassen muss um folgendes Layout zu bekommen?

43daa1a2-ea7a-4e1e-ac70-331961628362.png


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
 
nochEinAndreas

nochEinAndreas

Stammgast
Hallo Kriskr23,

ich bin zwar kein Experte, was Outlook VBA angeht (bewege mich eher in Excel VBA), aber ich habe mal etwas versucht:
1. Unten dein Code, mit ein paar Änderungen, um ein anderes Layout des Folder-Fensters zu erreichen: Statt dem BrowseForFolder aus der Shell.Application habe ich den FileDialog aus aus Excel.Application benutzt. Der lässt sich ganz gut anpassen:
learn.microsoft.com

FileDialog members (Office)

Provides file dialog box functionality similar to the functionality of the standard Open and Save dialog boxes found in Microsoft Office applications.
learn.microsoft.com
2. Um die Mail-Adresse zu bekommen (und an den Datei-Namen anzuhängen) heißt das Zauberwort vermutlich "SenderEmailAddress":
learn.microsoft.com

MailItem.SenderEmailAddress property (Outlook)

Office VBA reference topic
learn.microsoft.com
Damit habe ich aber zu wenig beschäftigt und deswegen nichts in deinen Code eingebaut. Das musst du selber machen.

Guten Start ins neue Jahr und Gruß,
Andreas

Code: 
Option Explicit

Sub SaveSelectedMailsWithDate()
    Dim mail As MailItem
    Dim strNewSubject As String
    Dim strNewFilePath As String
    Dim objFolder As Object
    
    ' Zusatz von Andreas:
    ' Diese Variablen waren nicht definiert
    Dim fso As Object
    Dim objShell As Object
    Dim obj As Object
    Dim ticks As String
    
    ' Zusatz von Andreas
    Dim strFolder As String
    Dim OUTPUTPATH As String
    Dim objExc As Object
    
    ' 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)
    
    ' Ersetzung von Andreas:
    ' Statt BrowseForFolder das Excel-Opjet FileDialog benutzt.
    Set objExc = CreateObject("Excel.Application")
    With objExc.FileDialog(msoFileDialogFolderPicker)
        .InitialView = msoFileDialogViewDetails
        .Title = "Ausgabe-Ordner angeben"
        If Not .Show Then Exit Sub
        strFolder = .SelectedItems(1)
    End With
    Set objExc = Nothing
    
    ' prüfe auf gültigen Pfad
    ' If fso.FolderExists(objFolder.Self.Path) Then
    ' Änderung von Andreas:
    ' Statt den Umweg über Selg.Path den String strFolder aus FileDialo benutzt
    If fso.FolderExists(strFolder) Then
        ' OUTPUTPATH = objFolder.Self.Path
        OUTPUTPATH = strFolder
    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 ist 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
 
K

Kriskr23

Neues Mitglied
Hallo Andreas,

vielen Dank für Deine schnelle Hilfe! :)

Ich habe den Code jetzt mal umgebaut, jedoch ist in einer Position vermutlich ein Fehler, den ich gerade selbst nicht wegbekomme:
1703938443744.png

Hast Du hierzu eine Idee?

Nachfolgend der Code wie ich ihn aktuell verwende.

Besten Dank vorab und Dir auch einen guten Rutsch ins neue Jahr! :)

Viele Grüße
Kristian


Code: 
Sub SaveSelectedMailsWithDate()
      
    Dim mail As MailItem
    Dim strNewSubject As String
    Dim strNewFilePath As String
    Dim objFolder As Object
    
    Dim fso As Object
    Dim objShell As Object
    Dim obj As Object
    Dim ticks As String
    
    Dim strFolder As String
    Dim OUTPUTPATH As String
    Dim objExc As Object
    
    ' max Anzahl an zu übernehmenden Zeichen des Subjects
    Const MAXSUBJECTCHARS = 30

    ' Statt BrowseForFolder das Excel-Opjet FileDialog benutzt.
    Set objExc = CreateObject("Excel.Application")
    With objExc.FileDialog(msoFileDialogFolderPicker)
        .InitialView = msoFileDialogViewDetails
        .Title = "Ausgabe-Ordner angeben"
        If Not .Show Then Exit Sub
        strFolder = .SelectedItems(1)
    End With
    Set objExc = Nothing
    
    
    ' prüfe auf gültigen Pfad
    If fso.FolderExists(strFolder) Then
        ' OUTPUTPATH = objFolder.Self.Path
        OUTPUTPATH = strFolder
    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
 
nochEinAndreas

nochEinAndreas

Stammgast
Guten Abend Kristian,

du hast ein bisschen zu viel des Guten gelöscht, nämlich die Referenz auf das FileSystemObject (fso). Das fehlt an der Stelle, an der der Fehler auftritt. Füge mal die Zeile
Code: 
' Filesystem Object erstellen
Set fso = CreateObject("Scripting.FileSystemObject")

wieder ein. Dann sollte es wieder funktionieren.

Grüße, Andreas
 
K

Kriskr23

Neues Mitglied
Hallo Andreas,

vielen Dank! Das hat mir weitergeholfen und der Absender ist mittlerweile auch im Dateiname enthalten.

Viele Grüße
Kristian
 
Du musst dich einloggen oder registrieren, um hier zu antworten.
Oben