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

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

Answer 1

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.