Outlook VBA to save a file attachment locally

[mamclero]

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

 

[Worf]

Hello

You can run this manually:

' 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