Gesendete Mails speichern

Hallo zusammen,

Der nachfolgende VBA Code soll die letzten beiden E-Mails aus dem "gesendete Elemente"-Ordner in Outlook lokal speichern. Das funktioniert auch, allerdings wird die 1. Mail immer mit dem Typ "Datei" gespeichert, während die 2. Mail im korrekten Format "Outlook Element" gespeichert wird. Es sollen aber beide Dateien mit dem Format "Outlook Element" bzw. mit der Dateiendung .msg gespeichert werden. Könnt ihr mir sagen, weshalb dieses Phänomen auftritt?

Sub EMailsSpeichern()

Dim OutlookApp As Outlook.Application
Dim Namespace As Outlook.Namespace
Dim Folder As Outlook.Folder
Dim MailItem As Outlook.MailItem
Dim i As Integer
Dim SaveFolder As String

' Ordnerpfad, in dem die E-Mails gespeichert werden sollen
SaveFolder = "XXX Platzhalter XXX"

' Outlook-Instanz erstellen
Set Namespace = GetNamespace("MAPI")

' Gesendete Elemente Ordner öffnen
Set Folder = Namespace.GetDefaultFolder(olFolderSentMail)

' Die letzten beiden E-Mails speichern
For i = Folder.Items.Count To Folder.Items.Count - 2 Step -1
If i 1 Then Exit For 'Falls weniger als 2 E-Mails vorhanden sind

Set MailItem = Folder.Items(i)

' E-Mail speichern
MailItem.SaveAs SaveFolder & MailItem.Subject & ".msg", olMSG

Set MailItem = Nothing
Next i

' Aufräumen
Set Folder = Nothing
Set Namespace = Nothing
Set OutlookApp = Nothing

MsgBox "Die E-Mails wurden erfolgreich gespeichert."
End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Markus!

An dem Problem hab ich auch länger geknackt bis ich es gemerkt hab. Das Thema brachte später aber noch andere Schwächen auf:

Die Länge des gesamten Pfades inkl. Dateiname darf eine Länge von 259 Zeichen nicht überschreiten.

Für die Sonderzeichen hab ich mir zur Korrektur eine Funktion gebaut...

Function Sonderzeichenkiller(ByRef text As String) As String
    Dim Sonderzeichen As String, i As Long
    Application.Volatile
    'Zeichen, die gelöscht werden, zum speichern von Dateinamen
    Sonderzeichen1 = "!:'*#*()+>{}[]&%~?=$|" & chr(34) & chr(9) 'Chr(34)=" 'zum löschen
    Sonderzeichen2 = "/\"                        'zum ersetzen
    'keine Aktion bei "-_"
    For i = 1 To Len(Sonderzeichen1)
        text = Replace(text, Mid(Sonderzeichen1, i, 1), "")
        dopp = Mid(Sonderzeichen1, i, 1) & Mid(Sonderzeichen1, i, 1)
        Do
            text = Replace(text, dopp, Mid(Sonderzeichen1, i, 1)) 'doppelte Zeichen entfernen
        Loop While InStr(text, dopp) > 0
    Next i
    
    For i = 1 To Len(Sonderzeichen2)
        dopp = Mid(Sonderzeichen2, i, 1) & Mid(Sonderzeichen2, i, 1)
        Do
            text = Replace(text, dopp, Mid(Sonderzeichen2, i, 1)) 'doppelte Zeichen entfernen
        Loop While InStr(text, dopp) > 0
        text = Replace(text, Mid(Sonderzeichen2, i, 1), "_")
    Next i
    
    dopp = "  "                              '2 Leerzeichen
    
    Do
        text = Replace(text, dopp, " ")      'doppelte Zeichen entfernen
    Loop While InStr(text, dopp) > 0
    
    text = Replace(text, " _ ", "_")
    Sonderzeichenkiller = text
End Function

Private Sub Test_sonderzeichenkiller()

    'leitet die ausgewählte Mail im Outlook weiter
    Dim MyOutApp_sess As Object, myOlout As Object ', Application As Object
    Dim Nam As String, Ziel As Range, such As String
    Dim zl As Single, mail_nam As String
    
    Set MyOutApp_sess = GetObject("", "Outlook.Application").Session
    
    For Each account_zugriff In MyOutApp_sess.Folders
        If InStr(account_zugriff, Split(Application.UserName, ",")(0)) > 0 Then
            Set outl_name = account_zugriff
            Exit For
        End If
    Next account_zugriff
    
    Set MyOutApp = CreateObject("Outlook.Application")
    Set mynamespace = MyOutApp.GetNamespace("MAPI")
    Set myOlout = mynamespace.GetDefaultFolder(olFolderSentMail)
    
    For Each fld In myOlout.items
        zl = zl + 1
        If zl = 20 Then Exit Sub
        With fld
            Debug.Print "alt", fld.Subject
            mail_nam = Replace(.LastModificationTime & "_" & Trim(.Subject), ":", ".") & ".msg"
            mail_nam = Replace(Trim(.Subject), ":", ".") & ".msg"
            
            mail_nam = Sonderzeichenkiller(mail_nam)
'Ordn_nam als Speicherort muss noch festgelegt werden
            Nam = Ordn_nam & "/" & mail_nam      'neuer Name
            Debug.Print "neu", mail_nam
        End With
    Next
End Sub

Gruß, MCO

Beliebteste Forumthreads (12 Monate)

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Gesendete Mails speichern

2 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread