Save outlook attachments and rename/append files with identifier from subject line

Question

Im really new to VBA and need some help. I'm trying to write a VBA script (along with a Outlook rule) to automatically download attachments from daily emails and append the file names with the date that appears in the subject.

This is what the subject line looks like - "Email Alert for Department for 10/20/2014". I just need to isolate the rightmost 10 spaces that indicates the run date of the files.

So I found code online that works to automatically download the attachments and append by current date which does work. See below.

Public Sub saveAttachtoDisk(itm As Outlook.MailItem)
Dim objAtt As Outlook.Attachment
Dim saveFolder As String
Dim dateFormat
dateFormat = Format(Now, "yyyymmdd ")
saveFolder = "Z:\Daily Emails"
For Each objAtt In itm.Attachments
objAtt.SaveAsFile saveFolder & "\" & dateFormat & objAtt.DisplayName
Set objAtt = Nothing
Next
End Sub

I also found online that something like this should point to the date (formatted like XX/XX/XXXX and always at the end of the subject line. Subject = Right(itm.Subject, 10) but im having trouble incorporating it into the code above.

Can anyone help me? It would mean a lot

Thanks!

-Christina

L42 L42 · Accepted Answer · 2014-10-24T03:31:25

Using Rules to run a macro is good.
I used the same set up before. The problem is if you are to work on the newly received mail, the sub wouldn't trap it. If you need to save the attachment of an incoming email with Email Alert for Department for mm/dd/yyyy as subject, try using an event instead. By default, Outlook doesn't provide Items Event so you'll have to create it.

In your ThisOutlookSession (not in a module) try something like:

Option Explicit
Private WithEvents olIBoxItem As Outlook.Items

Private Sub Application_Startup()
    Dim olApp As Outlook.Application
    Dim objNS As Outlook.NameSpace
    Dim olFolder As Outlook.MAPIFolder

    Set olApp = Outlook.Application
    Set objNS = olApp.GetNamespace("MAPI")
    Set olFolder = objNS.GetDefaultFolder(olFolderInbox)
    '~~> change olFolder depending on what folder you're receiving the email
    '~~> I assumed it is Outlook's default folder Inbox
    Set olIBoxItem = olFolder.Items
End Sub

Private Sub olIBoxItem_ItemAdd(ByVal Item As Object)
    Const strSub As String = "Email Alert for Department for "
    If TypeOf Item Is Outlook.MailItem Then
        Dim nMail As Outlook.MailItem
        Set nMail = Item

        If InStr(nMail.Subject, strSub) <> 0 Then
            Const savefolder As String = "Z:\Details Mail\"
            '~~> Extract your date
            Dim dateSub As String: dateSub = Right(nMail.Subject, 10)
            '~~> Make sure there is an attachment
            If nMail.Attachments.Count > 0 Then
                Dim olAtt As Outlook.Attachment
                Set olAtt = nMail.Attachments.Item(1) '~~> if you only have 1
                Dim attFName As String, addFExt As String
                '~~> Get the filename and extension separately
                attFName = Split(olAtt.Filename, ".")(0) 
                attFExt = Split(olAtt.Filename, ".")(1)
                '~~> Reconstruct the filename
                attFName = savefolder & attFName & " " & dateSub & attFExt
                '~~> Save the attachment
                olAtt.SaveAsFile attFName
            End If
        End If
    End If
End Sub

So above routine automatically checks any received mail in the Inbox Folder.
If the subject contains the specified string. If yes, it automatically saves the attachment.
If however you have more than one attachment, you'll have to look through it and then save each one.
It may look confusing at first but you'll get the hang of it for sure. HTH.

Save outlook attachments and rename/append files with identifier from subject line

1 Answers