Outlook VBA Macro Saving Attachments

bamaisgreat

Well-known Member
Joined
Jan 23, 2012
Messages
834
Office Version
  1. 365
Platform
  1. Windows
I copied the code below from a site which as you may notice it saves all attachments to newly created folder in my documents. I was wanting to see if someone might could modify it so it only saves attachments from the inbox of another email account I have in my outlook - (GCerts@ggsteel.com)(Inbox). Any they are saved to this designated folder: C:\Users\jamey.epperson\OneDrive - G&G Steel\pdf-NEW (OD)\Outlook-ATTM-Copies\ggCerts-Email Account

Also the attachments that need saved are newnew unread.



VBA Code:
Option Explicit

'***********************************************************************
'* Code based on sample code from Martin Green and adapted to my needs
'* more on TheTechieGuy.com - Liron@TheTechieGuy.com
'***********************************************************************

Sub GetAttachments()
On Error Resume Next
'create the folder if it doesnt exists:
    Dim fso, ttxtfile, txtfile, WheretosaveFolder
    Dim objFolders As Object
    Set objFolders = CreateObject("WScript.Shell").SpecialFolders
 
    'MsgBox objFolders("mydocuments")
    ttxtfile = objFolders("mydocuments")
   
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set txtfile = fso.CreateFolder(ttxtfile & "\Email Attachments")
    ' Changes made by Andrew Davis (adavis@xtheta.com) on October 28th 2015
    ' ------------------------------------------------------
        ' Set fso = Nothing
    ' ------------------------------------------------------
    WheretosaveFolder = ttxtfile & "\Email Attachments"
   
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)
    ' added the option to select whic folder to export
    Set Inbox = ns.PickFolder
   
    'to handle if the use cancalled folder selection
    If Inbox Is Nothing Then
                MsgBox "You need to select a folder in order to save the attachments", vbCritical, _
               "Export - Not Found"
        Exit Sub
    End If

    ''''
   

    i = 0
' Check Inbox for messages and exit of none found
    If Inbox.Items.Count = 0 Then
        MsgBox "There are no messages in the selected folder.", vbInformation, _
               "Export - Not Found"
        Exit Sub
    End If
' Check each message for attachments
    For Each Item In Inbox.Items
' Save any attachments found
        For Each Atmt In Item.Attachments
        ' This path must exist! Change folder name as necessary.
       
        ' Changes made by Andrew Davis (adavis@xtheta.com) on October 28th 2015
        ' ------------------------------------------------------
            FileName = WheretosaveFolder & "\" & fso.GetBaseName(Atmt.FileName) & i & "." & fso.GetExtensionName(Atmt.FileName)
        ' ------------------------------------------------------
            Atmt.SaveAsFile FileName
            i = i + 1
         Next Atmt
    Next Item
' Show summary message
    If i > 0 Then
        MsgBox "There were " & i & " attached files." _
        & vbCrLf & "These have been saved to the Email Attachments folder in My Documents." _
        & vbCrLf & vbCrLf & "Thank you for using Liron Segev - TheTechieGuy's utility", vbInformation, "Export Complete"
    Else
        MsgBox "There were no attachments found in any mails.", vbInformation, "Export - Not Found"
    End If
    ' Changes made by Andrew Davis (adavis@xtheta.com) on October 28th 2015
    ' ------------------------------------------------------
        Set fso = Nothing
    ' ------------------------------------------------------
' 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
 

Excel Facts

What is =ROMAN(40) in Excel?
The Roman numeral for 40 is XL. Bill "MrExcel" Jelen's 40th book was called MrExcel XL.
Try this:
I highlighted the added lines in blue
Rich (BB code):
Option Explicit

'***********************************************************************
'* Code based on sample code from Martin Green and adapted to my needs
'* more on TheTechieGuy.com - Liron@TheTechieGuy.com
'***********************************************************************

Sub GetAttachments()
On Error Resume Next
'create the folder if it doesnt exists:
    Dim fso, ttxtfile, txtfile, WheretosaveFolder
    Dim objFolders As Object
    Set objFolders = CreateObject("WScript.Shell").SpecialFolders
 
    'MsgBox objFolders("mydocuments")
    ttxtfile = objFolders("mydocuments")
   
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set txtfile = fso.CreateFolder(ttxtfile & "\Email Attachments")
    ' Changes made by Andrew Davis (adavis@xtheta.com) on October 28th 2015
    ' ------------------------------------------------------
        ' Set fso = Nothing
    ' ------------------------------------------------------
    WheretosaveFolder = ttxtfile & "\Email Attachments"
   
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

    Dim xName  As String

    Set ns = GetNamespace("MAPI")
    'Set Inbox = ns.GetDefaultFolder(olFolderInbox)
    ' added the option to select whic folder to export
    Set Inbox = ns.PickFolder
   
    'to handle if the use cancalled folder selection
    If Inbox Is Nothing Then
                MsgBox "You need to select a folder in order to save the attachments", vbCritical, _
               "Export - Not Found"
        Exit Sub
    End If

    ''''
   

    i = 0
' Check Inbox for messages and exit of none found
    If Inbox.Items.Count = 0 Then
        MsgBox "There are no messages in the selected folder.", vbInformation, _
               "Export - Not Found"
        Exit Sub
    End If
' Check each message for attachments
    For Each Item In Inbox.Items
' Save any attachments found

      On Error Resume Next
      xName = Item.SenderEmailAddress
      On Error GoTo 0
      If xName = "GCerts@ggsteel.com" Then

        For Each Atmt In Item.Attachments
        ' This path must exist! Change folder name as necessary.
       
        ' Changes made by Andrew Davis (adavis@xtheta.com) on October 28th 2015
        ' ------------------------------------------------------
            FileName = WheretosaveFolder & "\" & fso.GetBaseName(Atmt.FileName) & i & "." & fso.GetExtensionName(Atmt.FileName)
        ' ------------------------------------------------------
            Atmt.SaveAsFile FileName
            i = i + 1
         Next Atmt

     End if
 
    Next Item
' Show summary message
    If i > 0 Then
        MsgBox "There were " & i & " attached files." _
        & vbCrLf & "These have been saved to the Email Attachments folder in My Documents." _
        & vbCrLf & vbCrLf & "Thank you for using Liron Segev - TheTechieGuy's utility", vbInformation, "Export Complete"
    Else
        MsgBox "There were no attachments found in any mails.", vbInformation, "Export - Not Found"
    End If
    ' Changes made by Andrew Davis (adavis@xtheta.com) on October 28th 2015
    ' ------------------------------------------------------
        Set fso = Nothing
    ' ------------------------------------------------------
' 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
 
Upvote 0
Thanks Dante. I wasnt able to find where the attachments are saved at. I lookedd in the attachments folder in my documents but nothing showed up.
Could you have the code save them in this folder ? C:\Users\jamey.epperson\OneDrive - G&G Steel\pdf-NEW (OD)\Outlook-ATTM-Copies\ggCerts-Email Account
 
Upvote 0
Adjust your data in these lines:
sPath = "C:\Users\jamey.epperson\OneDrive - G&G Steel\pdf-NEW (OD)\Outlook-ATTM-Copies\ggCerts-Email Account\"
eMailAdd = "GCerts@ggsteel.com"

Replace all your code for this:

VBA Code:
Sub GetAttachments()
  Dim ns As Object, Inbox As Object, Item As Object, Atmt As Object
  Dim sPath As String, xName As String, eMailAdd As String
  Dim i As Long
  
  Set ns = CreateObject("Outlook.Application").GetNamespace("MAPI")
  Set Inbox = ns.PickFolder
  
  'fit your data
  sPath = "C:\Users\jamey.epperson\OneDrive - G&G Steel\pdf-NEW (OD)\Outlook-ATTM-Copies\ggCerts-Email Account\"
  eMailAdd = "GCerts@ggsteel.com"
  
  If Inbox Is Nothing Then                      ' to handle if the use canceled folder selection
    MsgBox "You need to select a folder in order to save the attachments", vbCritical, "Export - Not Found"
    Exit Sub
  End If
  
  If Inbox.Items.Count = 0 Then                 ' Check Inbox for messages and exit of none found
    MsgBox "There are no messages in the selected folder.", vbInformation, "Export - Not Found"
    Exit Sub
  End If
  
  For Each Item In Inbox.Items
    On Error Resume Next: xName = Item.SenderEmailAddress: On Error GoTo 0
    If xName = eMailAdd Then
      For Each Atmt In Item.Attachments         ' Check each message for attachments
        Atmt.SaveAsFile sPath & Atmt.FileName
        i = i + 1
      Next Atmt
    End If
  Next Item
  
  If i > 0 Then
    MsgBox "There were " & i & " attached files." & vbCrLf & _
      "These have been saved to the folder.", vbInformation, "Export Complete"
  Else
    MsgBox "There were no attachments found in any mails.", vbInformation, "Export - Not Found"
  End If
End Sub

Try and comment.
🤗
 
Upvote 0
Dante, Sorry for bothering you with this again. I tried the code and a dialog pops up saying No attachments found in any folders. Is it possible for the macro to run automatically without a dialog popping up asking me to choose a folder when I run the macro. I think it would be more effecctive running behind the scene. Below is the code I copied and pasted from you into the module.Thanks Jamey


VBA Code:
Option Explicit

'***********************************************************************
'* Code based on sample code from Martin Green and adapted to my needs
'* more on TheTechieGuy.com - Liron@TheTechieGuy.com
'***********************************************************************

Sub GetAttachments()
  Dim ns As Object, Inbox As Object, Item As Object, Atmt As Object
  Dim sPath As String, xName As String, eMailAdd As String
  Dim i As Long
  
  Set ns = CreateObject("Outlook.Application").GetNamespace("MAPI")
  Set Inbox = ns.PickFolder
  
  'fit your data
  sPath = "C:\Users\jamey.epperson\OneDrive - G&G Steel\pdf-NEW (OD)\Outlook-ATTM-Copies\ggCerts-Email Account\"
  eMailAdd = "GCerts@ggsteel.com"
  
  If Inbox Is Nothing Then                      ' to handle if the use canceled folder selection
    MsgBox "You need to select a folder in order to save the attachments", vbCritical, "Export - Not Found"
    Exit Sub
  End If
  
  If Inbox.Items.Count = 0 Then                 ' Check Inbox for messages and exit of none found
    MsgBox "There are no messages in the selected folder.", vbInformation, "Export - Not Found"
    Exit Sub
  End If
  
  For Each Item In Inbox.Items
    On Error Resume Next: xName = Item.SenderEmailAddress: On Error GoTo 0
    If xName = eMailAdd Then
      For Each Atmt In Item.Attachments         ' Check each message for attachments
        Atmt.SaveAsFile sPath & Atmt.FileName
        i = i + 1
      Next Atmt
    End If
  Next Item
  
  If i > 0 Then
    MsgBox "There were " & i & " attached files." & vbCrLf & _
      "These have been saved to the folder.", vbInformation, "Export Complete"
  Else
    MsgBox "There were no attachments found in any mails.", vbInformation, "Export - Not Found"
  End If
End Sub
 
Upvote 0
The problem is that it is not finding files for mail: "GCerts@ggsteel.com"
You could do a test with an email in which it does have files.

But try the following. Just put the first part of the email, that is, just write: "GCerts" or another email that does have files.

The macro will work with the email inbox folder. Replace the macro with this:

VBA Code:
Sub GetAttachments()
  Dim ns As Object, itm As Object, Atmt As Object
  Dim sPath As String, xName As String, eMailAdd As String
  Dim i As Long
  
  Set ns = CreateObject("Outlook.Application").GetNamespace("MAPI").GetDefaultFolder(6)
  
  'fit your data
  sPath = "C:\Users\jamey.epperson\OneDrive - G&G Steel\pdf-NEW (OD)\Outlook-ATTM-Copies\ggCerts-Email Account\"
  eMailAdd = "GCerts"
  
  For Each itm In ns.Items
    On Error Resume Next: xName = itm.SenderEmailAddress: On Error GoTo 0
    If InStr(1, xName, eMailAdd, vbTextCompare) > 0 Then
      For Each Atmt In itm.Attachments         ' Check each message for attachments
        Atmt.SaveAsFile sPath & Atmt.FileName
        i = i + 1
      Next Atmt
    End If
  Next
  
  If i > 0 Then
    MsgBox "Files are saved: " & i, vbInformation, "Export Complete"
  Else
    MsgBox "There were no attachments found in any mails.", vbInformation, "Export - Not Found"
  End If
End Sub

😅
 
Upvote 0

Forum statistics

Threads
1,226,458
Messages
6,191,152
Members
453,643
Latest member
adamb83

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top