Outlook Anlage speichern und umbenennen Betreffzeile VBA

Hallo Zusammen,

ich benötige folgende Unterstützung und möchte mich für eure Hilfe vorab bedanken. Ich nutze bereits ein Makro, welches E-Mail-Anhänge in einem vordefinierten Pfad abspeichert.

Sub Anlagen_speichern()

    'HIER DEN PFAD ÄNDERN ! ! !  
    Const fcPath As String = "C:\Users\xxx"  
    
    Dim olExplorer As Explorer
    Dim olFolder As MAPIFolder
    Dim olSelection As Selection
    Dim olitem As MailItem
    Dim lngAttCount As Long
    Dim i As Long
    Dim Anzahl As Long
    Dim fcZahl As Integer
    Dim fcName As String
    Dim fcEndung As String
    Dim dateiname As String
    
    Set olExplorer = Application.ActiveExplorer
    Set olFolder = Application.ActiveExplorer.CurrentFolder
    Anzahl = 0
    
    If Dir(fcPath, vbDirectory) <> "" Then  
        If olFolder.DefaultItemType = olMailItem Then
            Set olSelection = olExplorer.Selection
            
            'Für jede Email die Makiert ist  
            For Each olitem In olSelection
                lngAttCount = olitem.Attachments.Count
                
                'Falls es anhänge gibt  
                If lngAttCount > 0 Then
                    
                    'Für jeden Anhang  
                    For i = lngAttCount To 1 Step -1
                        
                        With olitem.Attachments.Item(i)
                            
                            'Falls Datei schon existiert einfach zahl hinter hängen  
                            If CreateObject("Scripting.FileSystemObject").FileExists(fcPath & "\" & .FileName) Then  
                                'Datei existiert schon -> Zahl hochzählen bis noch nicht existiert  
                                fcZahl = 2
                                fcName = CreateObject("Scripting.FileSystemObject").GetBaseName(fcPath & "\" & .FileName)  
                                fcEndung = CreateObject("Scripting.FileSystemObject").GetExtensionName(fcPath & "\" & .FileName)  
                                While CreateObject("Scripting.FileSystemObject").FileExists(fcPath & "\" & fcName & "(" & CStr(fcZahl) & ")." & fcEndung)  
                                    fcZahl = fcZahl + 1
                                Wend
                                dateiname = fcName & "(" & CStr(fcZahl) & ")." & fcEndung  
                            Else
                                'Datei existiert noch nicht  
                                dateiname = .FileName
                            End If
                            
                            'Datei speichern  
                            .SaveAsFile fcPath & "\" & dateiname  
                            
                        End With
                        Anzahl = Anzahl + 1
                    Next i
                    
                End If
            
            Next olitem
            
        Else
            MsgBox "In diesem Ordner befinden sich keine E-Mail-Nachrichten."  
        End If
        If Anzahl < 1 Then
            MsgBox "Keine Anlagen vorhanden"  
        Else
            If Anzahl < 2 Then
                MsgBox Anzahl & " Anlage gespeichert"  
            Else
                MsgBox Anzahl & " Anlagen gespeichert"  
            End If
        End If
    Else
        MsgBox "Der im Makro zum speichern der Anhänge eingetragene Pfad ""fcPath"" existiert nicht!"  
    End If

End Sub

Nun möchte ich, dass die Betreffzeile als Dateiname übernommen werden soll:

Beispiel:
Betreffzeile : Rechnung123456
Anhang : 000123.pdf
Gespeicherte Dateiname : Rechnung123456.pdf

Sicherlich kein Hexenwerk für euch, jedoch bin ich absoluter VBA-Laie.

Viele Grüße
Richter

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

Content-ID: 564731

Url: https://administrator.de/forum/outlook-anlage-speichern-und-umbenennen-betreffzeile-vba-564731.html

Ausgedruckt am: 23.04.2025 um 05:04 Uhr

5 Kommentare

Neuester Kommentar

dateiname = olitem.Subject & ".pdf"

wenns natürlich mehrere Anhänge sind dann musst du noch den Zähler mit einbauen

If lngAttCount > 1 Then
    dateiname = olitem.Subject & "_" & i & ".pdf"  
else
    dateiname = olitem.Subject & ".pdf"  
End if

Beachte auch das ungültige Zeichen im Subject wie : / ? usw. vor dem Speichern ersetzt werden müssen wenn das bei dir der Fall sein kann, denn sonst würde das einen Fehler wegen üngültiger Pfadzeichen triggern!
Siehe: Naming Files, Paths, and Namespaces

Vielen Dank Cabrinha für deine schnelle und tolle Antwort. Das mit dem ungültige Zeichen scheint bei mir ein Problem zu sein.

Meine Betreffzeile lt.: Rechnung: 08783457 - .

Es reicht mir auch aus, wenn die Rechnungsnummer als Dateinamen übernehmen wird. Hast du evtl. eine Idee?

Es reicht mir auch aus, wenn die Rechnungsnummer als Dateinamen übernehmen wird

Set regex = CreateObject("vbscript.regexp")  
regex.IgnoreCase = True
regex.Pattern = "\d+"  
set matches = regex.Execute(olitem.Subject)
if matches.count > 0 then
    dateiname = matches(0) & ".pdf"  
else
    msgbox "Keine Rechnungsnummer in der Mail mit dem Subject '" & olItem.Subject & "' gefunden!", vbExclamation  
    exit sub
End if