Download attachment with certain Subject

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?

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

Code:

---

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

---

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

Do you have the Outlook reference set?

Attachment 31616

Appears so.

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?

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

Good good,

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

Code:

---

    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?

Code:

---

ByVal EntryIDCollection As String

---

Do you get the error on the below line:

Code:

---

arrIDs = Split(EntryIDCollection, ",")

---

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

No problem, glad it works for you.

Quote:

---

Originally Posted by georgiboy

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?

Does this work for you?

Code:

---

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
EndSub

---

or maybe this one?

Code:

---

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

---