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

[nf24eg]

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

[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. http://www.vbaexpress.com/forum/showthread.php?67053-Automatically-save-attachments-when-mail-received

[nf24eg]

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

[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.

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

[nf24eg]

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

[gmayor]

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