Download attachment with certain Subject

[ry94080]

Hello,

I was hoping to automatically download the attachment for emails that start with "Master Patching Schedule...". An example, is "Master Patching Schedule - June Cycle".

Also I'm not sure what event makes the most sense to put this functionality in?

[georgiboy]

You can try using the below in the 'ThisOutlookSession' module:


Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
Dim arrIDs() As String, strSPth As String, strSTxt As String, i As Integer
Dim olItm As Object, olMl As Outlook.MailItem, olAtch As Outlook.Attachment

strSTxt = "Master Patching Schedule" ' Text to find in subject
strSPth = "C:\Users\jbloggs\Desktop\test\" ' Place to save the attachment
arrIDs = Split(EntryIDCollection, ",")

For i = LBound(arrIDs) To UBound(arrIDs)
Set olItm = Application.Session.GetItemFromID(arrIDs(i))
If TypeOf olItm Is MailItem Then
Set olMl = olItm
If InStr(olMl.Subject, strSTxt) > 0 Then
For Each olAtch In olMl.Attachments
olAtch.SaveAsFile strSPth & olAtch.FileName
Next olAtch
End If
End If
Next i

Set olAtch = Nothing
Set olMl = Nothing
Set olItm = Nothing
End Sub

[ry94080]

Thanks so much! However, i'm getting a "Variable no defined" error on the EntryIDCollection variable.

[georgiboy]

Do you have the Outlook reference set?

31616

[ry94080]

Appears so.

[georgiboy]

Hmm, I am not completely sure, I generally code in Excel and not Outlook.

Do you have the macro inside the 'ThisOutlookSession' module?

I am doing this with Outlook 365, what wersion are you using?

[ry94080]

Yes within the "ThisOutlookSession" module and also using 365.

[georgiboy]

Good good,

And you have not amended anything in the code other than the below two lines?

strSTxt = "Master Patching Schedule" ' Text to find in subject
strSPth = "C:\Users\jbloggs\Desktop\test\" ' Place to save the attachment

Also you haven't removed the ByVal part from the below line?

ByVal EntryIDCollection As String

[georgiboy]

Do you get the error on the below line:

arrIDs = Split(EntryIDCollection, ",")

[ry94080]

My fault. I tried to put the code in my own sub. Works now! Thanks for your help!!!!

[georgiboy]

No problem, glad it works for you.

[ry94080]

No problem, glad it works for you.

This code works perfectly when I have my outlook application opened and it detects that an email has arrived. However, if the application is closed and i open it, it does not detect. Any ideas how to handle this? Is there another event i can use?

[Aussiebear]

Does this work for you?



Private WithEvents Items As Outlook.ItemsPrivate Sub Application_Startup()
Dim olNs As Outlook.NameSpace
Dim Inbox As Outlook.MAPIFolder
Set olNs = Application.GetNamespace("MAPI")
Set Inbox = olNs.GetDefaultFolder(olFolderInbox)
Dim Filter As String
Filter = "@SQL=" & Chr(34) & "urn:schemas:httpmail:fromemail" & _
Chr(34) & " Like '%Da.Te@union.de%' And " & _
Chr(34) & "urn:schemas:httpmail:hasattachment" & _
Chr(34) & "=1"
Set Items = Inbox.Items.Restrict(Filter)
End Sub



Private Sub Items_ItemAdd(ByVal Item As Object)
If TypeOf Item Is Outlook.MailItem Then
Dim FilePath As String
FilePath = "C:\Temp\" <--- change to suit
Dim AtmtName As String
Dim Atmt As attachment
For Each Atmt In Item.Attachments
AtmtName = FilePath & Atmt.filename
Atmt.SaveAsFile AtmtName
Next
End If
End Sub

[Aussiebear]

or maybe this one?



Public WithEvents objInboxItems As Outlook.Items

Private Sub Application_Startup()
Set objInboxItems = Session.GetDefaultFolder(olFolderInbox).Items
End Sub

Private Sub objInboxItems_ItemAdd(ByVal Item As Object)
Dim objMail As Outlook.MailItem
Dim strSenderAddress As String
Dim strSenderDomain As String
Dim objAttachment As Attachment
Dim strFolderPath As String
Dim strFileName As String
Dim strDesiredSender As String
Dim strDesiredDomain As String
strFolderPath = Environ("USERPROFILE") & "\Documents\"
'strDesiredDomain = "gmail.com" <-- change to suit
strDesiredSender = "user@gmail.com" <-- Change to suit
If Item.Class = olMail Then
Set objMail = Item
'Get sender domain
strSenderAddress = objMail.SenderEmailAddress
strSenderDomain = Right(strSenderAddress, Len(strSenderAddress) - InStr(strSenderAddress, "@"))
'Use either strSenderDomain or strSenderAddress Depending on Filter Desired
'If strSenderDomain = strDesiredDomain Then
If strSenderAddress = strDesiredSender Then
If objMail.Attachments.Count > 0 Then
For Each objAttachment In objMail.Attachments
'Save in format "Subject - Attachmentname"
'strFileName = objMail.Subject & " " & Chr(45) & " " & objAttachment.FileName
'objAttachment.SaveAsFile strFolderPath & strFileName
'Save in format exactly as attachment name
objAttachment.SaveAsFile strFolderPath & objAttachment.FileName
objMail.Delete 'Delete after saving attachment
Next
End If
End If
End If
EndSub