VBA saving email attachments from outlook to matched subfolders on harddrive

logs10

New Member
Joined
Sep 10, 2014
Messages
8
Hi all,

First off, I am a first time poster but long-time lurker here on the forums. Thank you to everyone who takes time out of their day to help out on these forums. It is much appreciated.

To my question, I currently have a macro set up in an excel workbook that, when run, it allows the user to select a folder within outlook (which contains many, many emails with attachments) that loops through all emails within the folder and copies and saves all attachments to another specified non-outlook folder on a shared drive. The code can be viewed below.

My question comes in the form of, how one would go about building in logic to search the attachment filename for a wildcard and match it to a folder with the same wildcard. Once matched, the attachment would be copied and saved in the respective folder. The intuition is that the destination folder would already be setup beforehand, so that all the macro does is search the filename for a wildcard inside the destination folder name, and then moves the attachment after the match.

Also as an added bonus, it would be nice to have the macro run on non-read emails, and if an attachment is copied, then it would mark the email as read. Again, not a necessity, but it would be nice. Thanks all in advance.


This code was originally written by Jimmy Pena @ http://www.jpsoftwaretech.com/.





Sub GetAttachments()
Call SaveAllAttachments("S:\All\Data", False)
End Sub

Sub SaveAllAttachments(ByVal folderName As String, _
ByVal StripAttachments As Boolean)
' save all attachments from all emails in a folder to a folder on the hard disk
' optionally delete the attachments as well

' check if folder exists, if not then create it
' if folder cannot be created, exit
If Not FolderExists(folderName) Then
On Error Resume Next
MkDir folderName
If Err <> 0 Then Exit Sub
On Error GoTo 0
End If

' check that folderName ends with "\"
If Right$(folderName, 1) <> "\" Then
folderName = folderName & "\"
End If

' get default Inbox items collection
Dim olFldr As Outlook.MAPIFolder
Dim itms As Outlook.Items
Set olFldr = Outlook.GetNamespace("MAPI").PickFolder
If olFldr Is Nothing Then Exit Sub
Set itms = olFldr.Items

' create subset of items collection
Dim newItems As Outlook.Items
Set newItems = itms.Restrict("[Attachment] > 0")

' if there are no messages with attachments, exit
If newItems.Count = 0 Then
RmDir folderName
Exit Sub
End If

' loop through items subset, save all attachments to disk folder
Dim Msg As Outlook.MailItem
Dim MsgAttach As Outlook.Attachments
Dim attachmentNumber As Integer
For Each Msg In newItems
Set MsgAttach = Msg.Attachments
For attachmentNumber = MsgAttach.Count To 1 Step -1
MsgAttach.Item(attachmentNumber).SaveAsFile _
folderName & Format(Msg.ReceivedTime, "mmddyyyy_") & MsgAttach.Item(attachmentNumber).Filename
' delete attachment (optional)
If StripAttachments Then
MsgAttach.Item(attachmentNumber).Delete
End If
Next attachmentNumber
Next Msg

End Sub

Private Function GetDefaultFolder(outlookFolder As OlDefaultFolders) As _
Outlook.MAPIFolder
' returns MAPIFolder object from default folder list to calling program

Dim olApp As Outlook.Application
Dim olNS As Outlook.Namespace
Set olApp = Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")

Set GetDefaultFolder = olNS.GetDefaultFolder(outlookFolder)

End Function

Function FolderExists(ByVal strPath As String) As Boolean
On Error Resume Next
FolderExists = ((GetAttr(strPath) And vbDirectory) = vbDirectory)
End Function
 

Some videos you may like

Excel Facts

Can you AutoAverage in Excel?
There is a drop-down next to the AutoSum symbol. Open the drop-down to choose AVERAGE, COUNT, MAX, or MIN

John_w

MrExcel MVP
Joined
Oct 15, 2007
Messages
6,431
You could use the Instr function to see if the attachment filename property contains a specific string, or the Like operator which allows wildcards. For finding a wildcarded folder name, use a Dir function loop if you only want to search one level of subfolder below a base folder (you also need the GetAttr function as shown in the code to distinguish between folders and normal files), or a recursive FileSystemObject procedure if you want to search subfolders within subfolders. Again, use Instr or the Like operator to test if a folder name matches the wildcarded folder name.

The macro should already run on non-read emails. To mark the email as Read if an attachment is copied, add inside the For attachmentNumber loop:
Code:
Msg.UnRead = False

PS please use CODE tags to preserve indentation which makes the code easier to read:

[CODE]
VBA code here
[/CODE]
 

logs10

New Member
Joined
Sep 10, 2014
Messages
8
John_w,

Thanks for the response. I'll look into using these methods and get back if I have a question. I apologize for not using the code tags, I have reposed the code below for easier interpretation for others.

Code:
Sub GetAttachments()
  Call SaveAllAttachments("S:\All\Data", False)
End Sub


Sub SaveAllAttachments(ByVal folderName As String, _
      ByVal StripAttachments As Boolean)
' save all attachments from all emails in a folder to a folder on the hard disk
' optionally delete the attachments as well
 
' check if folder exists, if not then create it
' if folder cannot be created, exit
If Not FolderExists(folderName) Then
  On Error Resume Next
  MkDir folderName
  If Err <> 0 Then Exit Sub
  On Error GoTo 0
End If
 
' check that folderName ends with "\"
If Right$(folderName, 1) <> "\" Then
  folderName = folderName & "\"
End If
 
' get default Inbox items collection
Dim olFldr As Outlook.MAPIFolder
Dim itms As Outlook.Items
Set olFldr = Outlook.GetNamespace("MAPI").PickFolder
If olFldr Is Nothing Then Exit Sub
Set itms = olFldr.Items
 
' create subset of items collection
Dim newItems As Outlook.Items
Set newItems = itms.Restrict("[Attachment] > 0")
 
' if there are no messages with attachments, exit
If newItems.Count = 0 Then
  RmDir folderName
  Exit Sub
End If
 
' loop through items subset, save all attachments to disk folder
Dim Msg As Outlook.MailItem
Dim MsgAttach As Outlook.Attachments
Dim attachmentNumber As Integer
For Each Msg In newItems
  Set MsgAttach = Msg.Attachments
  For attachmentNumber = MsgAttach.Count To 1 Step -1
    MsgAttach.Item(attachmentNumber).SaveAsFile _
    folderName & Format(Msg.ReceivedTime, "mmddyyyy_") & MsgAttach.Item(attachmentNumber).Filename
    ' delete attachment (optional)
    If StripAttachments Then
      MsgAttach.Item(attachmentNumber).Delete
    End If
  Next attachmentNumber
Next Msg
 
End Sub
 
Private Function GetDefaultFolder(outlookFolder As OlDefaultFolders) As _
      Outlook.MAPIFolder
' returns MAPIFolder object from default folder list to calling program
 
Dim olApp As Outlook.Application
Dim olNS As Outlook.Namespace
Set olApp = Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")
 
Set GetDefaultFolder = olNS.GetDefaultFolder(outlookFolder)
 
End Function
 
Function FolderExists(ByVal strPath As String) As Boolean
' from http://allenbrowne.com
    On Error Resume Next
    FolderExists = ((GetAttr(strPath) And vbDirectory) = vbDirectory)
End Function
 

logs10

New Member
Joined
Sep 10, 2014
Messages
8
I'm having trouble setting up the logic for the test. Since the attachment names won't always be completely reliable when trying to match to folder names, I only want to use the first 4 characters of the attachment to try and match to the folder name (first 4 characters or a wildcard to match any part of the foldername text string), as these characters should remain the same. If there is a match, I want the file to be saved in the matching folder.

Anyone else want to try and give this a go?
 

John_w

MrExcel MVP
Joined
Oct 15, 2007
Messages
6,431

ADVERTISEMENT

Try this.
Code:
Option Explicit
Option Compare Text

Sub GetAttachments()
    SaveAllAttachments "S:\All\Data\", False
End Sub

Private Sub SaveAllAttachments(ByVal folderName As String, ByVal StripAttachments As Boolean)

    ' save all attachments from all emails in a folder to a folder on the hard disk
    ' optionally delete the attachments as well
    
    ' check if folder exists, if not then create it
    ' if folder cannot be created, exit
    If Not FolderExists(folderName) Then
        On Error Resume Next
        MkDir folderName
        If Err <> 0 Then Exit Sub
        On Error GoTo 0
    End If
    
    ' check that folderName ends with "\"
    If Right$(folderName, 1) <> "\" Then
        folderName = folderName & "\"
    End If
    
    ' get default Inbox items collection
    Dim olFldr As Outlook.MAPIFolder
    Dim itms As Outlook.Items
    Set olFldr = Outlook.GetNamespace("MAPI").PickFolder
    If olFldr Is Nothing Then Exit Sub
    Set itms = olFldr.Items
    
    ' create subset of items collection
    Dim newItems As Outlook.Items
    Set newItems = itms.Restrict("[Attachment] > 0")
    
    ' if there are no messages with attachments, exit
    If newItems.Count = 0 Then
        'RmDir folderName
        Exit Sub
    End If
    
    ' loop through items subset, save all attachments to disk folder
    Dim Msg As Outlook.MailItem
    Dim MsgAttach As Outlook.Attachment
    Dim matchingFolder As String
    For Each Msg In newItems
        For Each MsgAttach In Msg.Attachments
            matchingFolder = Find_First_Matching_Subfolder(folderName, "*" & Left(MsgAttach.fileName, 4) & "*")
            If matchingFolder <> "" Then
                MsgAttach.SaveAsFile matchingFolder & Format(Msg.ReceivedTime, "mmddyyyy_") & MsgAttach.fileName
            Else
                MsgBox "No matching subfolder found in " & folderName & " for *" & Left(MsgAttach.fileName, 4) & "*" & vbNewLine & _
                    MsgAttach.fileName & " not saved"
            End If
            Msg.UnRead = False          'mark email as read
            ' delete attachment (optional)
            If StripAttachments Then
                MsgAttach.Delete
            End If
        Next
    Next Msg
    
End Sub
    
Private Function GetDefaultFolder(outlookFolder As OlDefaultFolders) As Outlook.MAPIFolder
    ' returns MAPIFolder object from default folder list to calling program
    
    Dim olApp As Outlook.Application
    Dim olNS As Outlook.NameSpace
    Set olApp = Outlook.Application
    Set olNS = olApp.GetNamespace("MAPI")
    
    Set GetDefaultFolder = olNS.GetDefaultFolder(outlookFolder)
    
End Function
    
Private Function FolderExists(ByVal strPath As String) As Boolean
    On Error Resume Next
    FolderExists = ((GetAttr(strPath) And vbDirectory) = vbDirectory)
End Function


Private Function Find_First_Matching_Subfolder(baseFolder As String, matchSubfolder As String) As String

    Dim fileName As String
    
    If Right(baseFolder, 1) <> "\" Then baseFolder = baseFolder & "\"
    
    Find_First_Matching_Subfolder = ""
    fileName = Dir(baseFolder, vbDirectory)
    Do While fileName <> "" And Find_First_Matching_Subfolder = ""
        'Make sure it's a directory
        If GetAttr(baseFolder & fileName) And vbDirectory = vbDirectory Then
            If fileName Like matchSubfolder Then Find_First_Matching_Subfolder = baseFolder & fileName & "\"
        End If
        fileName = Dir
    Loop

End Function
It matches the first 4 characters of the attachment file name anywhere in the subfolder name. A message is displayed if a match isn't found. Note the use of Option Compare Text; this makes the Like operator case-insensitive.
 

logs10

New Member
Joined
Sep 10, 2014
Messages
8
John_w,

Sorry for the late response. I've been caught up in a whirlwind of other stuff this week. I just tested your code this morning and it works like a charm. I should definitely be able to work this with. I appreciate all of you help! :)
 

logs10

New Member
Joined
Sep 10, 2014
Messages
8

ADVERTISEMENT

Hey John,

I have one other request. I am trying to create the subset of items in the inbox where it searches messages only with attachments AND after a given date. In this case, I am trying to only search emails that were received in the last 14 days. The code runs, however, it doesn't seem to be working properly. I'm assuming the outlook items restrict filter by date I created is wrong. Any thoughts?


Rich (BB code):
Sub GetAttachments()
  Call SaveAllAttachments("S:\All\Data", False)
End Sub


Sub SaveAllAttachments(ByVal folderName As String, _
      ByVal StripAttachments As Boolean)
' save all attachments from all emails in a folder to a folder on the hard disk
' optionally delete the attachments as well
 
' check if folder exists, if not then create it
' if folder cannot be created, exit
If Not FolderExists(folderName) Then
  On Error Resume Next
  MkDir folderName
  If Err <> 0 Then Exit Sub
  On Error GoTo 0
End If
 
' check that folderName ends with "\"
If Right$(folderName, 1) <> "\" Then
  folderName = folderName & "\"
End If
 
' get default Inbox items collection
Dim olFldr As Outlook.MAPIFolder
Dim itms As Outlook.Items


Set olFldr = Outlook.GetNamespace("MAPI").PickFolder
If olFldr Is Nothing Then Exit Sub
Set itms = olFldr.Items
 
' create subset of items collection
Dim newItems As Outlook.Items
Dim dateItems As Outlook.Items
Dim dtDate As Date
Dim strDate As String


Const DayAge = 2


dtDate = DateAdd("D", -DayAge, Now())
strDate = Format(dtDate, "ddddd h:nn AMPM")


Set dateItems = itms.Restrict("[ReceivedTime] >= '" & strDate & "'")
Set newItems = itms.Restrict("[Attachment] > 0")




 
' if there are no messages with attachments, exit
If dateItems.Count = 0 Then
  RmDir folderName
  Exit Sub
End If




'only bring in specified number of emails to look at
If newItems.Count = 0 Then
  Exit Sub
End If


 
' loop through items subset, save all attachments to disk folder
Dim Msg As Outlook.MailItem
Dim MsgAttach As Outlook.Attachments
Dim attachmentNumber As Integer
For Each Msg In newItems
  Set MsgAttach = Msg.Attachments
  For attachmentNumber = MsgAttach.Count To 1 Step -1
    MsgAttach.Item(attachmentNumber).SaveAsFile _
    folderName & Format(Msg.ReceivedTime, "mmddyyyy_") & MsgAttach.Item(attachmentNumber).Filename
    ' delete attachment (optional)
    If StripAttachments Then
      MsgAttach.Item(attachmentNumber).Delete
    End If
  Next attachmentNumber
Next Msg
 
End Sub
 
Private Function GetDefaultFolder(outlookFolder As OlDefaultFolders) As _
      Outlook.MAPIFolder
' returns MAPIFolder object from default folder list to calling program
 
Dim olApp As Outlook.Application
Dim olNS As Outlook.Namespace
Set olApp = Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")
 
Set GetDefaultFolder = olNS.GetDefaultFolder(outlookFolder)
 
End Function
 
Function FolderExists(ByVal strPath As String) As Boolean
' from http://allenbrowne.com
    On Error Resume Next
    FolderExists = ((GetAttr(strPath) And vbDirectory) = vbDirectory)
End Function

Again, thanks for your help.
 

John_w

MrExcel MVP
Joined
Oct 15, 2007
Messages
6,431
In what way isn't it working properly?

Just a guess, but try changing the 2nd Restrict to:
Code:
Set newItems = dateItems.Restrict("[Attachment] > 0")
 

logs10

New Member
Joined
Sep 10, 2014
Messages
8
I figured it out, but now that I think about it, your suggestion should have worked as well.

I changed the attachment loop based off the the new variable dateItems instead of the previous newItems.

Before

Code:
Dim Msg As Outlook.MailItem
Dim MsgAttach As Outlook.Attachments
Dim attachmentNumber As Integer
For Each Msg In newItems  
      Set MsgAttach = Msg.Attachments  
      For attachmentNumber = MsgAttach.Count To 1 Step -1    
      MsgAttach.Item(attachmentNumber).SaveAsFile _    
      folderName & Format(Msg.ReceivedTime, "mmddyyyy_") & MsgAttach.Item(attachmentNumber).Filename    
  Next attachmentNumber
Next Msg



After

Code:
Dim Msg As Outlook.MailItem
Dim MsgAttach As Outlook.Attachments
Dim attachmentNumber As Integer
For Each Msg In dateItems
  Set MsgAttach = Msg.Attachments
  For attachmentNumber = MsgAttach.Count To 1 Step -1
    MsgAttach.Item(attachmentNumber).SaveAsFile _
        folderName & Format(Msg.ReceivedTime, "mmddyyyy_") & MsgAttach.Item(attachmentNumber).fileName
  Next attachmentNumber
Next Msg

Thanks!
 
Last edited:

HermanT

New Member
Joined
Mar 15, 2016
Messages
1
Hello,
Thanks al lot for this piece of code.
I tried it, but get aerror on the line:
Set newItems = itms.Restrict("[Attachment] > 0")

Run-time error -2147352567 (80020009)
Unknow property:attachment
I am trying the code before you added the date.
Please tel me what is wrong.
 

Watch MrExcel Video

Forum statistics

Threads
1,109,353
Messages
5,528,199
Members
409,807
Latest member
nicky736

This Week's Hot Topics

  • Change military grades into rank
    Afternoon all Need help with formula that will change military rank (i.e. 1, 2, 3 into Amn, A1C, SrA). Running IF formula that does not work...
  • VBA COUNTIF SOLUTION
    Hi The following are the errors spread across the several columns from E to Q ie. 13 columns across several sheets with more than 500 rows per...
  • INSERT ROW WITH SPECIFIS TEXT IN A COLUMN
    Hi All! How can identify that that the row to be inserted has to be inserted before 1st row with specific text in column F. If I record the...
  • Auto-Create a monthly Sign in sheet for preschool students
    The image below is what each page looks like. Above is space for the "Child Name" "Month" "Class" School days are obviously Monday-Friday but...
  • VBA vlookup multiple results
    Hi folks, Hopefully someone out there can help. I have a list to vlookup which works (ish). the lookup only picks up the first instance of the...
  • Extract values for earliest/latest times
    I am trying to put together a formula to get the earliest start time, the latest end time from column A for each person in Column B-F without the...
Top