Outlook VBA to save a file attachment locally

Thanks Thanks:  0
Likes Likes:  0
Results 1 to 2 of 2

Thread: Outlook VBA to save a file attachment locally

  1. #1
    New Member
    Join Date
    Oct 2017
    Post Thanks / Like
    0 Post(s)
    0 Thread(s)

    Default Outlook VBA to save a file attachment locally

    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

  2. #2
    Board Regular Worf's Avatar
    Join Date
    Oct 2011
    Rio, Brazil
    Post Thanks / Like
    1 Post(s)
    0 Thread(s)

    Default Re: Outlook VBA to save a file attachment locally


    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
    End Sub
    Excel 2013 / Windows 8.1 (home)
    Excel 2013 / windows 7 (work)

User Tag List

Tags for this Thread

Like this thread? Share it with others

Like this thread? Share it with others

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts