Outlook VBA -- Save attachments

I need to loop through all the emails in the folder inbox/projects, and if the email has an attachment, I need to save the attachment in the folder \\OWNER-PC\Users\Owner\Documents\Clients.
rrhandle8Asked:
Who is Participating?
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

Rgonzo1971Commented:
Hi,

pls try
Sub macro()
Dim objNS As Outlook.Namespace: Set objNS = GetNamespace("MAPI")
Dim olFolder As Outlook.MAPIFolder
Set olFolder = objNS.GetDefaultFolder(olFolderInbox)
Set olFolder = olFolder.Folders("projects")
Dim Item As Object
DestFolder = "\\OWNER-PC\Users\Owner\Documents\Clients\"
For Each Item In olFolder.Items
    If TypeOf Item Is Outlook.MailItem Then
        Dim oMail As Outlook.MailItem
        Set oMail = Item
        For Each Atmt In oMail.Attachments
                Filename = DestFolder & Atmt.Filename
                Atmt.SaveAsFile Filename
        Next Atmt

    End If
Next

End Sub

Open in new window

Regards
0

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
upsfaCommented:
I used this a few years ago.

1. Show the Developer tab in Outlook
      a. File, Options, Customize Ribbon, Select Developer, select OK
2. Add new module and insert code
      a. Select Developer Tab
      b. Select Visual Basic
      c. Select Insert, Select module
      d. Paste code below into module
      e. Close VB
3. In Windows Explorer, create the folder D:\UPSData\EmailAttachments
4. To run the code, in Outlook select Macros from the developer tab, select macros, select the GetAttachments macro and select Run
 
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. (D:\UPSData\EmailAttachments)
 
    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
' Save any attachments found
        For Each Atmt In Item.Attachments
        ' This path must exist! Change folder name as necessary.
        On Error Resume Next
            FileName = "D:\UPSData\EmailAttachments\" & Atmt.FileName & " --- " & Item.EntryID & Atmt.FileName
            Atmt.SaveAsFile FileName
            i = i + 1
         Next Atmt
    Next Item
    On Error GoTo 0
' Show summary message
    If i > 0 Then
        MsgBox "I found " & i & " attached files." _
        & vbCrLf & "I have saved them into the D:\upsdata\EmailAttachments folder." _
        & 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
0
rrhandle8Author Commented:
There is no IF to go with the END IF inside the loop.
0
Ultimate Tool Kit for Technology Solution Provider

Broken down into practical pointers and step-by-step instructions, the IT Service Excellence Tool Kit delivers expert advice for technology solution providers. Get your free copy now.

upsfaCommented:
I see IFs

    If Inbox.Items.Count = 0 Then
         MsgBox "There are no messages in the Inbox.", vbInformation, _
                "Nothing Found"
         Exit Sub
     End If


    If i > 0 Then
         MsgBox "I found " & i & " attached files." _
         & vbCrLf & "I have saved them into the D:\upsdata\EmailAttachments folder." _
         & vbCrLf & vbCrLf & "Have a nice day.", vbInformation, "Finished!"
     Else
         MsgBox "I didn't find any attached files in your mail.", vbInformation, "Finished!"
     End If
0
Rgonzo1971Commented:
my first version has already been corrected (see code in my message)
0
rrhandle8Author Commented:
Rgonzo1971 -- There is an IF statement missing.
0
rrhandle8Author Commented:
Looks like I have two good solutions.  I have to left for a few minutes.  Give me some time to test out both.
0
rrhandle8Author Commented:
Both solutions worked great!  Thank you.
0
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Outlook

From novice to tech pro — start learning today.

Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.