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
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
Graham Mayor - MS MVP (Word) 2002-2019
Visit my web site for more programming tips and ready made processes
http://www.gmayor.com
Last edited by nf24eg; 04-27-2021 at 07:14 AM.
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
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.
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