How to automatically save attachment from specific sender? - vba

Question

I would like to automatically save attachments from a specific sender in a predetermined folder.
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
If Item.Class = olMail Then
Set objMail = Item
'Get sender domain
strSenderAddress = objMail.SenderEmailAddress
'strSenderDomain = Right(strSenderAddress, Len(strSenderAddress) - InStr(strSenderAddress, "#"))
'Change to the specific domain as per your needs
If strSenderAddress = "Da.Te#union.de" Then
If objMail.Attachments.Count > 0 Then
For Each objAttachment In objMail.Attachments
'Change the folder path where you want to save attachments
strFolderPath = "U:\Test"
strFileName = objMail.Subject & " " & Chr(45) & " " & objAttachment.FileName
objAttachment.SaveAsFile strFolderPath & strFileName
Next
End If
End If
End If
End Sub
This code is from here, with minor modifications.

Answer 1

How about the following... Remember to restart Outlook
Private WithEvents Items As Outlook.Items
Private 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\"
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
Items.ItemAdd Event (Outlook) Occurs when one or more items are added to the specified collection. This event does not run when a large number of items are added to the folder at once. This event is not available in Microsoft Visual Basic Scripting Edition (VBScript).
Items.Restrict method is an alternative to using the Find method or FindNext method to iterate over specific items within a collection. The Find or FindNext methods are faster than filtering if there are a small number of items. The Restrict method is significantly faster if there is a large number of items in the collection, especially if only a few items in a large collection are expected to be found.
Filtering Items Using a String Comparison that DASL filters support includes equivalence, prefix, phrase, and substring matching. Note that when you filter on the Subject property, prefixes such as "RE: " and "FW: " are ignored.

Answer 2

I don't think anything was wrong with your posted code, I too was looking to use that code but not to filter by domain, but specific sender. I tweaked the code a bit for my needs and made it easier to tweak for a new user by moving the 3 fields needing to be modified to the top. I also commented out the part that saved the attachment prefixed with "Subject - Attachmentname" so it saves it purely as "Attachmentname".
My issue was I hadn't enabled Macros in the Trust Center and I had it in a separate Module but it must be under "ThisOutlookSession".
I also added a line to delete the message after saving attachment.
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"
strDesiredSender = "user#gmail.com"
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
End Sub