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

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

Quote:

---

Originally Posted by gmayor

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

The SaveAttachments macro that is used as a rule script may equally be called from a loop through messages in a folder e.g.

Code:

---

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

---

Quote:

---

Originally Posted by gmayor

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

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.

Code:

---

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

---