VBA to automatically extract email attachments and save them into a specific file

VSM

New member
Joined
Feb 13, 2018
Messages
19
Reaction score
0
Points
0
Excel Version(s)
O365
Hello,

I am fairly new to VBA in Excel. Can you please provide help with an issue I am having? I have found and slightly modified a VBA macro that automatically extracts xls. or xlsx. email attachments from any unread email in my inbox and saves the attachment to a folder on my hard drive. The macro works great but I require it to go a bit more granular.

Can you please show me how I can make the macro extract the attachments from emails that are in a subfolder and not from my inbox?

Ideally I would have like to have used a VBA script in Outlook, but I am limited by our IT policy here. This is why I have chosen to run this macro through Excel and not use a script in Outlook.

Also, because I cannot use script within Outlook, is there any way to have this macro activated every time a new email comes into the subfolder? Could this be achieved through an ItemAdd VBA in Outlook? Or is there a way to achieve this through Excel? (I wasn't sure if I should make a separate thread for this question or not)

Thank you for any help you can provide.

Below is the macro I am currently using:

Code:
Sub GetAttachments()
' This Outlook macro checks a the Outlook Inbox for messages
' with attached files (of any type) and saves them to disk.
' NOTE: make sure the specified save folder exists before
' running the macro.
    On Error GoTo GetAttachments_err
' Declare variables
    Dim ns As Namespace
    Dim Inbox As MAPIFolder
    Dim Item As Object
    Dim Atmt As Attachment
    Dim FileName As String
    Dim i As Integer
    Set ns = GetNamespace("MAPI")
    Set Inbox = ns.GetDefaultFolder(olFolderInbox)
    i = 0
' Check Inbox for messages and exit of none found
    If Inbox.Items.Count = 0 Then
        MsgBox "There are no messages in the Inbox.", vbInformation, _
               "Nothing Found"
        Exit Sub
    End If
' Check each message for attachments
    For Each Item In Inbox.Items
        If Item.UnRead = True Then 'Add this for checking unread emails
            ' Save any attachments found
                    For Each Atmt In Item.Attachments
                        If (Right(Atmt.FileName, 4) = "xlsx") Or (Right(Atmt.FileName, 4) = ".xls") Then
                        ' This path must exist! Change folder name as necessary.
                            FileName = "S:\Maintenance\Test\" & _
                                Format(Item.CreationTime, "yyyymmdd_hhnnss_") & Atmt.FileName
                            Atmt.SaveAsFile FileName
                            Item.UnRead = False 'Mark email item as read
                            i = i + 1
                        End If
                Next Atmt
        End If
    Next Item
' Show summary message
    If i > 0 Then
        MsgBox "I found " & i & " attached files." _
        & vbCrLf & "I have saved them into the S:\Maintenance\Test." _
        & vbCrLf & vbCrLf & "Have a nice day.", vbInformation, "Finished!"
    Else
        MsgBox "I didn't find any attached files in your mail.", vbInformation, "Finished!"
    End If
' Clear memory
GetAttachments_exit:
    Set Atmt = Nothing
    Set Item = Nothing
    Set ns = Nothing
    Exit Sub
' Handle errors
GetAttachments_err:
    MsgBox "An unexpected error has occurred." _
        & vbCrLf & "Please note and report the following information." _
        & vbCrLf & "Macro Name: GetAttachments" _
        & vbCrLf & "Error Number: " & Err.Number _
        & vbCrLf & "Error Description: " & Err.Description _
        , vbCritical, "Error!"
    Resume GetAttachments_exit
End Sub
 
I guess that I would do it in 2 steps.

1. Create a New Rule in Outlook to move the files. e.g. If Ken in Subject, move to Ken folder/subfolder.
2. Set the folder/subfolder but depends Exchange or GMail server?
 
Thank you for your response.

I was hoping to just add a few lines of code to the macro. I will set a rule in outlook to send the emails to the subfolder. But I would like to have the macro code pull the email attachments from the emails in the subfolder and not the inbox, as my current VBA macro automatically pulls the attachments from emails in my inbox.

Thanks
 
As I said, it depends on if you are using Microsoft Exchange or another smpt server like Gmail uses, IMAP. There is a macro for Outlook to get the path for the current Outlook folder. But, you said you can't run an Outlook macro. Ergo, why I asked which smpt server you are using so I could make a good guess.

Once that is settled, yes, a few modified lines of code and you are set.
 
My apologies for any misunderstanding, I am fairly new to this. I am on Microsoft Exchange.
 
You can use this to test. If still stuck for how to set the folder without the dialog, post back.

Code:
Sub PickFolder()  'Early Binding: Tools > References > Microsoft Outlook xx.0 Object Library > OK
  Dim OL As Outlook.Application, ot As Outlook.TaskItem
  Dim objRecipient As Outlook.Recipient, objAction As Outlook.Action
  'Dim objFolder As Outlook.MAPIFolder
  Dim objFolder As Outlook.Folder 'For Gmail Task's folder
  Dim objSheet As Worksheet
  Dim i As Long, S As String, ws As Worksheet, a
  
'******************* INPUT ******************************************************************
  Set ws = Sheet3
'******************* END INPUT **************************************************************
  
  Set OL = CreateObject("Outlook.Application")
  'Set objFolder = OL.GetNamespace("MAPI").GetDefaultFolder(olFolderTasks) 'olFolderTasks=13
  Set objFolder = OL.GetNamespace("MAPI").PickFolder
  Debug.Print objFolder.Name
End Sub
 
Hi Kenneth, I have ran the macro and the folder selection box pops up. Can you please explain how I can integrate this into my current macro and have it automatically choose the subfolder? I am very sorry for my ignorance, I am fairly new to all of this.
 
It has been awhile since I did that. This should fix you up. You can use the previous routine to get the string to the path for this function using the FolderPath property rather than Name. Or, just replace the folderpath string with your email and folder path if you know it.

Code:
Sub SetFolder()  'Early Binding: Tools > References > Microsoft Outlook xx.0 Object Library > OK  Dim OL As Outlook.Application
  Dim objRecipient As Outlook.Recipient, objAction As Outlook.Action
  'Dim objFolder As Outlook.MAPIFolder
  Dim objFolder As Outlook.Folder 'For Gmail Task's folder
  
  Set OL = CreateObject("Outlook.Application")
  
  'Set objFolder = OL.GetNamespace("MAPI").GetDefaultFolder(olFolderTasks) 'olFolderTasks=13
  'Set objFolder = OL.GetNamespace("MAPI").PickFolder
  'Debug.Print objFolder.Name, objFolder.FolderPath


  Set objFolder = GetFolderPath("\\ken@gmail.com\Puppy\Pics", OL)
  Debug.Print objFolder.Name, objFolder.FolderPath
End Sub


'Similar to, http://www.slipstick.com/developer/working-vba-nondefault-outlook-folders/#GetFolderPath
''Early Binding: Tools > References > Microsoft Outlook xx.0 Object Library > OK
Function GetFolderPath(ByVal FolderPath As String, oApp As Outlook.Application) As Outlook.Folder
    Dim oFolder As Outlook.Folder
    Dim FoldersArray As Variant
    Dim i As Integer
     
    On Error GoTo GetFolderPath_Error
    If Left(FolderPath, 2) = "\\" Then
        FolderPath = Right(FolderPath, Len(FolderPath) - 2)
    End If
    'Convert folderpath to array
   FoldersArray = Split(FolderPath, "\")
    'Set oFolder = Application.Session.Folders.Item(FoldersArray(0))
   Set oFolder = oApp.Session.Folders.Item(FoldersArray(0))
    If Not oFolder Is Nothing Then
        For i = 1 To UBound(FoldersArray, 1)
            Dim SubFolders As Outlook.Folders
            Set SubFolders = oFolder.Folders
            Set oFolder = SubFolders.Item(FoldersArray(i))
            If oFolder Is Nothing Then
                Set GetFolderPath = Nothing
            End If
        Next
    End If
    'Return the oFolder
   Set GetFolderPath = oFolder
    Exit Function
     
GetFolderPath_Error:
    Set GetFolderPath = Nothing
    Exit Function
End Function
 
Thank you very much for your help.

Have a great day!
 
Back
Top