Results 1 to 2 of 2

Thread: Save all attachments

  1. #1

    Angry Save all attachments

    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:\"
    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

  2. #2
    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
        Exit Sub
    End Sub
    Private Sub SaveAttachments(olItem As MailItem)
    'Graham Mayor - - 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
        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
        FileNameUnique = strFileName & Chr(46) & strExtension
        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
            FileExists = False
        End If
        Exit Function
    End Function
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes

Tags for this Thread

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts