CODEWITHSUNDEEP
vbaoutlook
BrettJ
BrettJ

Reputation: 1226

Outlook Saving Attachment with Subject Name

I have a Macro that saves all attachments from emails in my inbox to the directory specified. However, I would like to save the attachments with the email subject as the filename.

This is my first Macro and first time looking at VBA so any pointers are much appreciated. 

Private Sub Outlook_VBA_Save_Attachment()
    ''Variable declarions
    Dim ns As NameSpace
    Dim inb As Folder
    Dim itm As MailItem
    Dim atch As Attachment

    ''Variables Initialization
    Set ns = Outlook.GetNamespace("MAPI")
    Set inb = ns.GetDefaultFolder(olFolderInbox)
    File_Path = "H:\Notes\"

    ''Loop Thru Each Mail Item
    For Each itm In inb.Items

    ''Loop Thru Each Attachment
        For Each atch In itm.Attachments
            If atch.Type = olByValue Then
               atch.SaveAsFile File_Path & atch.FileName
            End If
        Next atch
    Next itm

    '''''Notify the Termination of Process
    MsgBox "Attachments Extracted to: " & File_Path
End Sub

Upvotes: 2

Views: 7094

Answers (1)

Brian M Stafford
Brian M Stafford

Reputation: 8868

All you need to do is change one line:

atch.SaveAsFile File_Path & itm.Subject

To include the original file extension, you can use the FileSystemObject to grab it. The modified code would be as follows:

Private Sub Outlook_VBA_Save_Attachment()
    ''Variable declarions
    Dim ns As Namespace
    Dim inb As Folder
    Dim itm As MailItem
    Dim atch As Attachment
    Dim fso As FileSystemObject

    ''Variables Initialization
    Set ns = Outlook.GetNamespace("MAPI")
    Set inb = ns.GetDefaultFolder(olFolderInbox)
    File_Path = "H:\Notes\"
    Set fso = New FileSystemObject

    ''Loop Thru Each Mail Item
    For Each itm In inb.Items

    ''Loop Thru Each Attachment
        For Each atch In itm.Attachments
            If atch.Type = olByValue Then
               atch.SaveAsFile File_Path & itm.Subject & "." & fso.GetExtensionName(atch.Filename)
            End If
        Next atch
    Next itm

    '''''Notify the Termination of Process
    MsgBox "Attachments Extracted to: " & File_Path
End Sub

This will require a Reference to Microsoft Scripting Runtime.

Upvotes: 3

Related Questions