Save all attachments

[Tarje_089]

Dear All,

I hope you are doing well.
I have a short enquiry regarding a macro to save all attachments from an e-mail.
Fortunately I already got one to save all of them, BUT not the attachments from attached mails.
Is there the possibility to integrate this query also into the macro?


Sub Anlage_verschieben()
Dim strPath As String
Dim objMail As MailItem
Dim intAnlagen As Integer, i As Integer
On Error Resume Next
'Pfad zu meinem Ordner
strPath = "L:\"
'Schleife
For Each objMail In Outlook.ActiveExplorer.Selection
With objMail
'Mails auf vorh. Anlagen prüfen
intAnlagen = .Attachments.Count
If intAnlagen > 0 Then
For i = 1 To intAnlagen
'Anlagen im vordefinierten Verzeichnis sichern
.Attachments.Item(i).SaveAsFile strPath & "\" & Format(.ReceivedTime, "yyyy-mm-dd_hh-mm_") & " " & .Attachments.Item(i).FileName
Next i
End If
End With
Next objMail
End Sub


I would be very thankful if anyone has the clue for my issue.

Thank you in advance and best regards
T

[gmayor]

I have posted the bulk of the following here previously, but to address your additional requirement, you would have to save the attached message and then extract the attachments from it. Use the parts of it that you require.


Option Explicit

Sub ProcessSelectedMessage()
'An Outlook macro by Graham Mayor
Dim olMsg As MailItem
On Error Resume Next
Set olMsg = ActiveExplorer.Selection.Item(1)
SaveAttachments olMsg
lbl_Exit:
Exit Sub
End Sub

Private Sub SaveAttachments(olItem As MailItem)
'Graham Mayor - http://www.gmayor.com - Last updated - 26 Jun 2017
Dim olAttach As Attachment
Dim strFname As String
Dim strExt As String
Dim i As Long, j As Long
Dim olMsg As MailItem
Const strSaveFldr As String = "D:\Path\Attachments\" - the folder to save the attachments

On Error GoTo lbl_Exit
If olItem.Attachments.Count > 0 Then
For j = 1 To olItem.Attachments.Count
Set olAttach = olItem.Attachments(j)
If Not olAttach.fileName Like "image*.*"
strFname = olAttach.fileName
strExt = Right(strFname, Len(strFname) - InStrRev(strFname, Chr(46)))
Select Case LCase(strExt)
Case "msg" 'The attachment is a message so save it
olAttach.SaveAsFile Environ("TEMP") & Chr(92) & strFname
'then open it
Set olMsg = Session.OpenSharedItem(Environ("TEMP") & Chr(92) & strFname)
'and if it has attachments save them
If olMsg.Attachments.Count > 0 Then
For i = 1 To olMsg.Attachments.Count
If Not olMsg.Attachments(i).fileName Like "image*.*" Then
strFname = olMsg.Attachments(i).fileName
strExt = Right(strFname, Len(strFname) - InStrRev(strFname, Chr(46)))
strFname = FileNameUnique(strSaveFldr, strFname, strExt)
olMsg.Attachments(i).SaveAsFile strSaveFldr & strFname
End If
Next i
End If
Case Else
strFname = FileNameUnique(strSaveFldr, strFname, strExt)
olAttach.SaveAsFile strSaveFldr & strFname
End Select
End If
Next j
End If
lbl_Exit:
Set olAttach = Nothing
Set olItem = Nothing
Set olMsg = Nothing
Exit Sub
End Sub

Private Function FileNameUnique(strPath As String, _
strFileName As String, _
strExtension As String) As String
'An Outlook macro by Graham Mayor
Dim lngF As Long
Dim lngName As Long
lngF = 1
lngName = Len(strFileName) - (Len(strExtension) + 1)
strFileName = Left(strFileName, lngName)
Do While FileExists(strPath & strFileName & Chr(46) & strExtension) = True
strFileName = Left(strFileName, lngName) & "(" & lngF & ")"
lngF = lngF + 1
Loop
FileNameUnique = strFileName & Chr(46) & strExtension
lbl_Exit:
Exit Function
End Function

Private Function FileExists(filespec) As Boolean
'An Outlook macro by Graham Mayor
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FileExists(filespec) Then
FileExists = True
Else
FileExists = False
End If
lbl_Exit:
Exit Function
End Function