Consulting

Results 1 to 6 of 6

Thread: Saving Attachment from Multiple Emails As MSG Files In Bulk In Outlook

  1. #1

    Saving Attachment from Multiple Emails As MSG Files In Bulk In Outlook

    Hello, I'm tying to save the attachments from multiple emails as a MSG file on a local folder
    I found one but it saves the messages it self including the attachments
    can a VBA code do this ?
    Thank you

  2. #2
    Your message doesn't appear to make sense, however I have posted code several times on this forum that demonstrates how to save attachments e.g. http://www.vbaexpress.com/forum/show...-mail-received
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

  3. #3
    Quote Originally Posted by gmayor View Post
    Your message doesn't appear to make sense, however I have posted code several times on this forum that demonstrates how to save attachments e.g.
    I don't know why my message doesn't appear to make sense, however the link you directed me is about the newly or the up coming messages, while I'm looking for the attachments in the messages in a PST file on local machine

    Thank you for your time and efforts

    Best regards

    Last edited by nf24eg; 04-27-2021 at 07:14 AM.

  4. #4
    The SaveAttachments macro that is used as a rule script may equally be called from a loop through messages in a folder e.g.
    Sub ProcessFolder()'An Outlook macro by Graham Mayor
    Dim olNS As Outlook.NameSpace
    Dim olMailFolder As Outlook.MAPIFolder
    Dim olItems As Outlook.items
    Dim olMailItem As Outlook.MailItem
    
        On Error GoTo err_Handler
        Set olNS = GetNamespace("MAPI")
        Set olMailFolder = olNS.PickFolder
        Set olItems = olMailFolder.items
         For Each olMailItem In olItems
            SaveAttachments olMailItem
            DoEvents
        Next olMailItem
    err_Handler:
        Set olNS = Nothing
        Set olMailFolder = Nothing
        Set olItems = Nothing
        Set olMailItem = Nothing
    lbl_Exit:
        Exit Sub
    End Sub
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

  5. #5
    Quote Originally Posted by gmayor View Post
    The SaveAttachments macro that is used as a rule script may equally be called from a loop through messages in a folder e.g.
    I'm sure I do it wrong because it gives compile error
    I tried to add it as a module, or insert it under "thisoutlooksession", but still give Compile error
    I tried through adding a rule to apply on messages with attachments + run Script (Run script wasn't there and I added it through the registry) but Run Script not found the macro to run.

    and I'm not sure it will run on all the email addresses which on the Outlook or it will give me the ability to choose the folders to apply on

    hopefully you can direct me the right way to make it work
    Thank you

  6. #6
    Did you copy all parts of the original code and not just he main macro?
    The macro goes in an ordinary module and not ThisOutlookSession and you need all the parts called by the main macro i.e. as follows. The code includes 2 main macros - one to test with a selected message, the other to process a folder.

    Option Explicit
    'Graham Mayor - https://www.gmayor.com - Last updated - 29 Apr 2021 
    
    Sub ProcessAttachment() 'test with selected message
    '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
    
    Sub ProcessFolder() 'process a selected folder
    'An Outlook macro by Graham Mayor
    Dim olNS As Outlook.NameSpace
    Dim olMailFolder As Outlook.MAPIFolder
    Dim olItems As Outlook.items
    Dim olMailItem As Outlook.MailItem
    Dim i As Long
        On Error GoTo err_Handler
        Set olNS = GetNamespace("MAPI")
        Set olMailFolder = olNS.PickFolder
        Set olItems = olMailFolder.items
        i = 0
        For Each olMailItem In olItems
            SaveAttachments olMailItem
            DoEvents
        Next olMailItem
        MsgBox "Processing complete!", vbInformation
    err_Handler:
        Set olNS = Nothing
        Set olMailFolder = Nothing
        Set olItems = Nothing
        Set olMailItem = Nothing
    lbl_Exit:
        Exit Sub
    End Sub
    
    Private Sub SaveAttachments(olItem As MailItem)
    'Graham Mayor - http://www.gmayor.com - Last updated - 26 May 2017
    Dim olAttach As Attachment
    Dim strFname As String
    Dim strExt As String
    Dim j As Long
    Const strSaveFldr As String = "C:\Path\Attachments\" 'change as required
    
        CreateFolders strSaveFldr
        On Error Resume Next
        If olItem.Attachments.Count > 0 Then
            For j = 1 To olItem.Attachments.Count
                Set olAttach = olItem.Attachments(j)
                If Not olAttach.FileName Like "image*.*" Then
                    strFname = olAttach.FileName
                    strExt = Right(strFname, Len(strFname) - InStrRev(strFname, Chr(46)))
                    strFname = FileNameUnique(strSaveFldr, strFname, strExt)
                    olAttach.SaveAsFile strSaveFldr & strFname
                End If
            Next j
            olItem.Save
        End If
    lbl_Exit:
        Set olAttach = Nothing
        Set olItem = 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
    
    Private Function FolderExists(fldr) As Boolean
    'An Outlook macro by Graham Mayor
    Dim FSO As Object
        Set FSO = CreateObject("Scripting.FileSystemObject")
        If (FSO.FolderExists(fldr)) Then
            FolderExists = True
        Else
            FolderExists = False
        End If
    lbl_Exit:
        Exit Function
    End Function
    
    Private Function CreateFolders(strPath As String)
    'An Outlook macro by Graham Mayor
    Dim strTempPath As String
    Dim lngPath As Long
    Dim VPath As Variant
        VPath = Split(strPath, "\")
        strPath = VPath(0) & "\"
        For lngPath = 1 To UBound(VPath)
            strPath = strPath & VPath(lngPath) & "\"
            If Not FolderExists(strPath) Then MkDir strPath
        Next lngPath
    lbl_Exit:
        Exit Function
    End Function
    
    
    Private Function CleanFileName(strFileName As String) As String
    Dim arrInvalid() As String
    Dim lng_Index As Long
        'Define illegal characters (by ASCII CharNum)
        arrInvalid = Split("9|10|11|13|34|42|47|58|60|62|63|92|124", "|")
        'Remove any illegal filename characters
        CleanFileName = strFileName
        For lng_Index = 0 To UBound(arrInvalid)
            CleanFileName = Replace(CleanFileName, Chr(arrInvalid(lng_Index)), Chr(95))
        Next lng_Index
    lbl_Exit:
        Exit Function
    End Function
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

Posting Permissions

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