Outlook VBA to save a file attachment locally

mamclero

New Member
Joined
Oct 31, 2017
Messages
5
Hello, hoping someone can help me with the following - I get an email every day with an attachment I have to save down on my hard drive to build a report. Trying to automate this process, and looking online, it seems I can use something like the following code, but in those instances it seemed like I needed to create a rule to use, and the "run a script" functionality has been disabled locally, so that option isn't available to me. I know there is some other way to write a general rule to extract specific attachments, but I'm just not sure on how to actually set it up. Essentially, I get the same email every day from sampleuser@sample.com and I put those specifically in a sub folder in my inbox. For any email that goes into that folder, I'd like it save locally to c:\temp\. Bonus would be if when it saves it could move the file named the same to c:\temp\archive so I'm only looking at the most recent file in that folder (which I just build a query to that specific folder for my report). Thanks in advance!

Public Sub SaveToDisk(itm As Outlook.MailItem)
Dim objAtt As Outlook.Attachment
Dim saveFolder As String
Dim dateFormat

dateFormat = Format(Now, "yyyy-mm-dd")
'Change this path to the your folder location

saveFolder = "c:\temp"

objAtt.SaveAsFile saveFolder & "" & dateFormat & ".xls"

Set objAtt = Nothing

End Sub
 

Excel Facts

What is the fastest way to copy a formula?
If A2:A50000 contain data. Enter a formula in B2. Select B2. Double-click the Fill Handle and Excel will shoot the formula down to B50000.
Hello

You can run this manually:

Code:
' Outlook module
Sub Att()
Dim mpfInbox As Folder, obj As MailItem, i%, fn$
Const mad$ = ""                                                     ' desired mail address
Set mpfInbox = GetNamespace("MAPI").GetDefaultFolder(olFolderInbox) ' desired folder
For i = 1 To mpfInbox.Items.Count
    If mpfInbox.Items(i).Class = olMail Then
        Set obj = mpfInbox.Items.Item(i)
        If Day(obj.ReceivedTime) = Day(Now) And obj.Attachments.Count > 0 And _
        obj.SenderEmailAddress = mad Then
            fn = "c:\accounts\" & Format(Now, "yyyy-mm-dd")
            On Error Resume Next
            Name fn & ".xls" As "c:\accounts\draft\" & Format(Now, "yyyy-mm-dd") & ".xls"   ' move file
            On Error GoTo 0
            obj.Attachments.Item(1).SaveAsFile fn & ".xls"
        End If
    End If
Next
End Sub
 
Upvote 0

Forum statistics

Threads
1,213,546
Messages
6,114,255
Members
448,556
Latest member
peterhess2002

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