Outlook Termine: Wie kann man Beginn (Datum, Zeit) und Ende (Datum, Zeit) in den Betreff einer .msg-Datei schreiben

Hallo
erstmals im Forum.

Im Beitrag Outlook: Empfangsdatum auslesen und in Dateinamen schreiben

ist für das Speichern einer E-Mail als msg-Datei ein VBA-Skript abgebildet. Damit wird das Empfangsdatum der E-Mail ausgelesen und zusammen mit dem Betreff der E-Mail als Dateiname gespeichert.

Fragen:

Könnte man dieses Skript so umschreiben, dass es für Termine/Appointments funktioniert?
Könnten die hier im Thread-Titel erwähnten Angaben (Datum, Zeit) zu Beginn des Betreffs stehen?
Bei der E-Maillösung kann man den Ordner in einem Pop-Up einstellen. Wäre dies auch möglich?
Wie müsste die Skript-Zeile ferner lauten, wenn man den Ordner direkt reinschreiben möchte?

Für Hilfen bin ich dankbar.

Bitte markiere auch die Kommentare, die zur Lösung des Beitrags beigetragen haben

Content-ID: 7291640702

Url: https://administrator.de/contentid/7291640702

Ausgedruckt am: 24.11.2024 um 01:11 Uhr

2 Kommentare

Neuester Kommentar

Sub SaveSelectedObjectsWithDate()
    Dim 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 Objekte  
            For Each obj In .Selection
                ' ersetze illegale Zeichen durch underscores  
                strNewSubject = Trim(ReplaceIllegalChars(obj.Subject))
                ' wenn das Subject durch die Änderung leer istm benutze als Namen der Datei die eindeutige Outlook-EntryID  
                If strNewSubject = "" Then  
                    strNewSubject = obj.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(obj.Start, "yymmdd") & "_" & 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(obj.Start, "yymmdd") & "_" & strNewSubject & "_" & ticks & ".msg")  
                Wend
                ' speichere als MSG(Unicode-Format)  
                obj.SaveAs strNewFilePath, olMSGUnicode

            Next
        Else
            ' Kein Termin für den Export markiert  
            MsgBox "Bitte mindestens einen Termin 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

Wie müsste die Skript-Zeile ferner lauten, wenn man den Ordner direkt reinschreiben möchte?

Sub SaveSelectedObjectsWithDate()
    Dim strNewSubject As String, strNewFilePath As String, 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")  
    ' Ausgabepfad  
    OUTPUTPATH = "D:\MeinOrdner"  
    If not fso.FolderExists(OUTPUTPATH) Then
        MsgBox "Ungültiger Pfad!", vbExclamation  
        Exit Sub
    End If
    
    With ActiveExplorer
        ' wenn eine Auswahl besteht ...  
        If .Selection.Count > 0 Then
            ' verarbeite alle markierten Objekte  
            For Each obj In .Selection
                ' ersetze illegale Zeichen durch underscores  
                strNewSubject = Trim(ReplaceIllegalChars(obj.Subject))
                ' wenn das Subject durch die Änderung leer istm benutze als Namen der Datei die eindeutige Outlook-EntryID  
                If strNewSubject = "" Then  
                    strNewSubject = obj.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(obj.Start, "yymmdd") & "_" & 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(obj.Start, "yymmdd") & "_" & strNewSubject & "_" & ticks & ".msg")  
                Wend
                ' speichere als MSG(Unicode-Format)  
                obj.SaveAs strNewFilePath, olMSGUnicode

            Next
        Else
            ' Kein Termin für den Export markiert  
            MsgBox "Bitte mindestens einen Termin 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

Gruß