Outlook Anhänge speichern
06.04.2020 19:01:26
Noureddine
ich habe ein Outlook Makro aus dem Internet, der mir alle Anhänge speichert.
Der Code funktioniert auch hervorragend und ich verstehe Ihn auch soweit. Allerdings ist mein Ziel, nicht alle Anhänge zu speichern, sonder nur die Anlagen-Anhänge (also keine Bilder aus der Signatur oder ähnliches).
Kann mir hier wer weiterhelfen?
Danke vorab.
Private Sub CommandButton1_Click()
Dim olOlApp As Outlook.Application
Dim olMail As Outlook.MailItem
Dim olAtts As Outlook.Attachments
Dim olSel As Outlook.Selection
Dim i As Integer, iCount As Integer
Dim strFile As String
Dim strFolder As String
'Outlook Application Objekt instanziieren
Set olOlApp = CreateObject("Outlook.Application")
'Sammlung der ausgewählten Objekte (E-Mail) ermitteln
Set olSel = olOlApp.ActiveExplorer.Selection
'Ordner-Pfad festlegen, wo der E-Mail Anhang gespeichert werden soll
strFolder = "\\MyPath\"
'Jedes ausgewählte Objekt (E-Mail) prüfen, ob es ein Anhang hat. Wenn Anhang vorhanden, dann _
unter Ordnerpfad speichern
For Each olMail In olSel
'Die Anhänge des ausgewählten Objekts (E-Mail) ermitteln
Set olAtts = olMail.Attachments
iCount = olAtts.Count
If iCount > 0 Then
'Wir verwenden hier einen rückwerts gerichteten Zähler
For i = iCount To 1 Step -1
'Speichern von Anhängen
'Dateuname ermitteln
strFile = olAtts.Item(i).FileName
'Kombiniere Ablagepfad mit dem Dateinamen
strFile = strFolder & strFile
'Anhang als Datei speichern
olAtts.Item(i).SaveAsFile strFile
Next i
End If
Next
Exit Sub:
Set olAtts = Nothing
Set olMail = Nothing
Set olSel = Nothing
Set olOlApp = Nothing
End Sub