<< | Zurück

E-Mail Anhänge speichern

E-Mails mit Anhänge im Outlook markieren, das makro ausführen. Für jedes Email wird einen Ordner erstellt darin jeweils die Anhänge und das E-Mails in Textdatei. Der Unterordnername ist der Sender und Datum / Zeit. Der Hauptordner wird anfangs ausgewählt über einen Browser Dialog.

VBA Makro einfach über den VBA Editor in einem neuen Modul kopieren. Schaltfläche im Outlook hinzufügen.

Darstellun soll jeder nach seinen Wünschen anpassen bezüglich Zielort Einträge der Anhänge im E-Mails. In der Final Version wird neu als Titel der Speicherort angezeigt danach für jeden Anhang einen Eintrag mit Link zur Datei (Anhang).

Bild1

Bild2

Makro installieren

Einfach den VBA Editor öffnen und mit rechte Maustaste links im Verzeichnisstruktur auf Projekt klicken. Im Kontextmenu, Modul hinzufügen. Den Code unten in das neue Modul kopieren. Schaltfläche im Outlook hinzufügen.

Darstellun soll jeder nach seinen Wünschen anpassen bezüglich Titel und Zielort Einträge der Anhänge im Email.

Makro für Outlook 2016 und 2019 getestet.

Final Version 1.0.0.2

Download Outlook Makro final 1.0.0.2 TXT

Download Outlook Makro final 1.0.0.2 ZIP

Public zaehler As Integer Public Sub SaveAttachments() Dim objOL As Outlook.Application Dim objMsg As Outlook.MailItem 'Object Dim objAttachments As Outlook.Attachments Dim objSelection As Outlook.Selection Dim i As Long Dim lngCount As Long Dim strFile As String Dim strFolderpath As String Dim strDeletedFiles As String Const olTXT = 0 'um den mailtext in text datei zu speichern '----------------------folder browsing Steuerelement Dim AppShell As Object Dim BrowseDir As Variant Set AppShell = CreateObject("Shell.Application") Set BrowseDir = AppShell.BrowseForFolder(0, "Ordner auswählen für Ihre Anhänge.", &H1000, 17) On Error Resume Next Ordnername = BrowseDir.Items().Item().Path UserForm1.TextBox5 = Ordnername '-----------------doppel backslash entfernen C:\\ = C:\ Dim StrText2 As String StrText2 = Ordnername 'StrText2 = Replace("\\", "\") 'um c:\\ doppel backslash zu entfernen '''''''''''''''vb.net StrText2 = Replace(StrText2, "\\", "\") ''''''''''''''''''''''''''''''vba Ordnername = StrText2 '-----------------doppel backslash entfernen C:\\ = C:\ ende '----------------------folder browsing Steuerelement ' Get the path to your My Documents folder 'strFolderpath = CreateObject("WScript.Shell").SpecialFolders(16) strFolderpath = Ordnername & "" On Error Resume Next ' Instantiate an Outlook Application object. Set objOL = CreateObject("Outlook.Application") ' Get the collection of selected objects. Set objSelection = objOL.ActiveExplorer.Selection ' Set the Attachment folder. 'strFolderpath = strFolderpath & "Attachments" ' Check each selected item for attachments. If attachments exist, ' save them to the strFolderPath folder and strip them from the item. For Each objMsg In objSelection 'jedes markierte email loop ' This code only strips attachments from mail items. ' If objMsg.class=olMail Then ' Get the Attachments collection of the item. Set objAttachments = objMsg.Attachments lngCount = objAttachments.Count strDeletedFiles = "" '------------------------Ein Ordner pro email----------------------------- '----------------------------Ordner vorher erstellen und mit email name Dim neuerOrdner As String Dim Datumzeit As String zaehler = zaehler + 1 Datumzeit = Format(Now, "ddMMyyyy_HHmmss") 'neuerOrdner = strFolderpath & objAttachments.Item(i).DisplayName 'neuerOrdner = strFolderpath & objMsg.SenderName & " (" & objMsg.SenderEmailAddress & ")" 'neuerOrdner = strFolderpath & "" & objMsg.SenderName 'neuerOrdner = strFolderpath & "" & objMsg.SenderName & "_" & Datumzeit 'mit datum und zeit am schluss '''''was 'neuerOrdner = strFolderpath & "\" & objMsg.SenderName & "_" & Datumzeit 'mit datum und zeit am schluss '''privat ''''''''''achtung neuerOrdner = strFolderpath & "\" & objMsg.SenderName & "_" & Datumzeit & "_" & zaehler 'mit datum und zeit am schluss '''privat MkDir (neuerOrdner) 'strFile = neuerOrdner '& "\" & objAttachments.Item(i).FileName 'achtung vorher | strFile wird nur für email body Text verendet 'strFile = neuerOrdner & "\" & objAttachments.Item(i).FileName 'achtung strFile wird nur für email body Text verendet '----------------------------Ordner vorher erstellen und mit email name ende '------------------------Ein Ordner pro email----------------------------- ende objMsg.SaveAs neuerOrdner & "\" & objMsg.SenderName & ".txt", olTXT 'um den mailtext in text datei zu speichern If lngCount > 0 Then 'jeder markierter Anhang loop ' We need to use a count down loop for removing items ' from a collection. Otherwise, the loop counter gets ' confused and only every other item is removed. For i = lngCount To 1 Step -1 'strFile wird nur für body Text, text in email ' Save attachment before deleting from item. ' Get the file name. strFile = objAttachments.Item(i).FileName ' Combine with the path to the Temp folder. 'strFile = strFolderpath & strFile 'achrung vorher strFile = strFolderpath & "\" & strFile strFile = neuerOrdner & "\" & objAttachments.Item(i).FileName 'achtung strFile wird nur für email body Text verendet 'objAttachments.Item(i).SaveAsFile strFile 'objAttachments.Item(i).SaveAsFile neuerOrdner & "" & objAttachments.Item(i).FileName 'objAttachments.Item(i).SaveAsFile neuerOrdner & "" & objAttachments.Item(i).FileName ' Save the attachment as a file. 'objAttachments.Item(i).SaveAsFile strFile objAttachments.Item(i).SaveAsFile neuerOrdner & "\" & objAttachments.Item(i).FileName ''''''''''''''''''privat '-------------------------------------------------------- '---------------------------------------Anhänge löschen ' Delete the attachment. 'objAttachments.Item(i).Delete '---------------------------------------Anhänge löschen ende '----------------------------------------------------------- '-------------------------------------------------------------------------- '--doppel backlslash entfernen C:\\ = C:\ wenn Root gewählt wird z. B C:\ '------------------------------------------------------------------------- Dim StrText3 As String StrText3 = strFile 'StrText2 = Replace("\\", "\") 'um c:\\ doppel backslash entfernen ''vb.net StrText3 = Replace(StrText3, "\\", "\") ''''''''''''''''''''''''''''''vba strFile = StrText3 '------------------------------------------------------------------------------- '--doppel backlslash entfernen C:\\ = C:\ ende wenn Root gewählt wird z. B C:\ '------------------------------------------------------------------------------- 'write the save as path to a string to add to the message 'check for html and use html tags in link If objMsg.BodyFormat <> olFormatHTML Then strDeletedFiles = strDeletedFiles & vbCrLf & "<file://" & strFile & ">" Else strDeletedFiles = strDeletedFiles & "<br>" & "<a href='file://" & _ strFile & "'>" & strFile & "</a>" End If 'Use the MsgBox command to troubleshoot. Remove it from the final code. 'MsgBox strDeletedFiles Next i ' Adds the filename string to the message body and save it ' Check for HTML body If objMsg.BodyFormat <> olFormatHTML Then 'objMsg.Body = vbCrLf & "The file(s) were saved to " & strDeletedFiles & vbCrLf & objMsg.Body 'objMsg.Body = vbCrLf & "Die Datei(en) wurden hier abgelegt " & strDeletedFiles & vbCrLf & objMsg.Body objMsg.Body = vbCrLf & "Die Datei(en) wurden hier abgelegt --> " & neuerOrdner & strDeletedFiles & vbCrLf & objMsg.Body Else 'objMsg.HTMLBody = "<p>" & "The file(s) were saved to " & strDeletedFiles & "</p>" & objMsg.HTMLBody 'objMsg.HTMLBody = "<p>" & "Die Datei(en) wurden hier abgelegt " & strDeletedFiles & "</p>" & objMsg.HTMLBody objMsg.HTMLBody = "<p>" & "Die Datei(en) wurden hier abgelegt --> " & neuerOrdner & strDeletedFiles & "</p>" & objMsg.HTMLBody End If objMsg.Save End If Next ExitSub: Set objAttachments = Nothing Set objMsg = Nothing Set objSelection = Nothing Set objOL = Nothing End Sub