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?

Screenshot 2024-06-06 145621.jpg

[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
EndSub

[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