I pieced this together for saving all Excel attachments from incoming mail to a local drive folder.
It is in the ThisOutlookSession module and I restarted Outlook.
When I send a test email meeting the criteria in the If statements, I receive >"Error 438: Object doesn't support this property or method".
I can't figure out which object doesn't support which property or method.
It is at least running up to my If statements because this only happens to emails that meet the criteria.
Option Explicit
Private WithEvents inboxItems As Outlook.Items
Private Sub Application_Startup()
Dim outlookApp As Outlook.Application
Dim objectNS As Outlook.NameSpace
Set outlookApp = Outlook.Application
Set objectNS = outlookApp.GetNamespace("MAPI")
Set inboxItems = objectNS.GetDefaultFolder(olFolderInbox).Items
End Sub
Private Sub inboxItems_ItemAdd(ByVal Item As Object)
On Error GoTo ErrorHandler
Dim Msg As Outlook.MailItem
Dim i As Integer
Dim strFolder As String
Dim mySaveName As String
Dim myExt As String
Dim OlMail As Outlook.MailItem
strFolder = "D:\Scripts\VendorProductivity\Daily files"
If TypeName(Item) = "MailItem" Then
If Item.Subject Like "*Report*" Then
If Item.Recipient = "Jane Doe" Then
If Item.Attachments.Count > 0 Then
'loop through all attachments
For i = 1 To Item.Attachments.Count
mySaveName = Item.Attachments.Item(i).FileName
myExt = Split(mySaveName, ".")(1)
'Only save files with named extensions
Select Case myExt
Case "xls", "xlsm", "xlsx"
mySaveName = strFolder & "\" & mySaveName
Item.Attachments.Item(i).SaveAsFile mySaveName
Case Else
'do nothing
End Select
Next
Item.Delete
End If
End If
End If
End If
ExitNewItem:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ExitNewItem
End Sub
MailItem does not expose a property named Recipient (singular). It exposes a property named Recipients (plural), but is is not a string property - it is a collection of Recipient objects, which expose Name and Address properties among others.
Did you mean to use the SenderName property instead?
Related
I'm attempting to move email with specific subject when received.
The mail is still in my Inbox. I've tested by sending mail from my account with specific subject.
Option Explicit
Private WithEvents inboxItems As Outlook.Items
Private Sub Application_Startup()
Dim outlookApp As Outlook.Application
Dim objectNS As Outlook.NameSpace
Set outlookApp = Outlook.Application
Set objectNS = outlookApp.GetNamespace("MAPI")
Set inboxItems = objectNS.GetDefaultFolder(olFolderInbox).Items
End Sub
Private Sub Items_ItemAdd(ByVal item As Object)
On Error GoTo ErrorHandler
Dim Msg As Outlook.MailItem
Set myInbox = GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
If TypeName(item) = "MailItem" Then
Set Msg = item
If InStr(0, Msg.Subject, "Testing Subject", vbTextCompare) > 0 Then
Set fldr = Outlook.Session.GetDefaultFolder(olFolderInbox).Folders("Testing")
Msg.Move fldr
End If
End If
ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ProgramExit
End Sub
I created this macro in ThisOutlookSession.
I think you may have an error with the naming of your Sub which means it doesn't fire
Items_ItemAdd => inboxItems_ItemAdd
As an addendum: I recently implemented a RegEx filter to incoming e-mails as I found I couldn't easily use rules to filter out some junk e-mail coming my way. This should be able to adapted to your needs (I've added the rule I think should work for you, but it's untested)
Within the 'ThisOutlookSession'
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
On Error Resume Next
Call RegExFilterRules(EntryIDCollection)
End Sub
Within a module
Sub RegExFilterRules(ItemID As String)
' Requires Reference: Microsoft Scripting Runtime
Dim ThisNamespace As Outlook.NameSpace: Set ThisNamespace = Application.GetNamespace("MAPI")
Dim Inbox As Outlook.MAPIFolder: Set Inbox = ThisNamespace.GetDefaultFolder(olFolderInbox)
Dim Junk As Outlook.MAPIFolder: Set Junk = ThisNamespace.GetDefaultFolder(olFolderJunk)
Dim oMsg As Outlook.MailItem: Set oMsg = ThisNamespace.GetItemFromID(ItemID, Inbox.StoreID)
If Not oMsg Is Nothing And oMsg.Class = olMail Then
'If FindPattern(oMsg.Subject, "^M\d+$") Then oMsg.Move Junk ' oMsg.Delete
If FindPattern(oMsg.Subject, "^Testing Subject") Then oMsg.Move Inbox.Folders("Testing")
End If
End Sub
Private Function FindPattern(Str As String, Pattern As String) As Boolean
Dim RegEx As Object: Set RegEx = CreateObject("vbscript.RegExp")
With RegEx
.Global = True
.IgnoreCase = True
.MultiLine = True
.Pattern = Pattern
FindPattern = .Test(Str)
End With
End Function
Every time I receive an email with the subject "Test", I want to:
Automatically extract all attachments and store them in its own new created folder.
Automatically copy the email inside this new folder
Automatically add a Word document inside this new folder.
The folder must be named by the date received.
The code I have copies all attachments in a pre-selected folder, but it doesn't create a personal folder for them.
Private WithEvents Items As Outlook.Items
Private Sub Application_Startup()
Dim olApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Set olApp = Outlook.Application
Set objNS = olApp.GetNamespace("MAPI")
Set Items = objNS.GetDefaultFolder(olFolderInbox).Items
End Sub
Private Sub Items_ItemAdd(ByVal item As Object)
On Error GoTo ErrorHandler
'Only act if it's a MailItem
Dim Msg As Outlook.MailItem
If TypeName(item) = "MailItem" Then
Set Msg = item
'Change variables to match need. Comment or delete any part unnecessary.
If (Msg.Subject = "Heures") And _
(Msg.Attachments.Count >= 1) Then
'Set folder to save in.
Dim olDestFldr As Outlook.MAPIFolder
Dim myAttachments As Outlook.Attachments
Dim Att As Variant
Const attPath As String = "C:\Users\NASC02\Test\"
' save attachment
Set myAttachments = item.Attachments
For Each Att In myAttachments
Att.SaveAsFile attPath & Att.FileName
Next
' mark as read
Msg.UnRead = False
End If
End If
ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ProgramExit
End Sub
The code
Set myAttachments = item.Attachments
Att = myAttachments.item(1).DisplayName
myAttachments.item(1).SaveAsFile attPath & Att
needs to be changed to
Set myAttachments = item.Attachments
for each Att in myAttachments
Att.SaveAsFile attPath & Att.FileName
next
I'm trying to forward emails from my company's Outlook to an email account outside of our company. I have been given the ok to do this.
I'd like to forward any email that contains "Excel Friday" in the subject line.
Private WithEvents Items As Outlook.Items
Private Sub Application_Startup()
Dim olApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Set olApp = Outlook.Application
Set objNS = olApp.GetNamespace("MAPI")
' default local Inbox
Set Items = objNS.GetDefaultFolder(olFolderInbox).Items
End Sub
Private Sub Items_ItemAdd(ByVal Item As Object)
On Error GoTo ErrorHandler
Dim Msg As Outlook.MailItem
If TypeName(Item) = "MailItem" Then
Set Msg = Item
If Msg.Subject = "Excel Friday" Then
Dim myMail As Outlook.MailItem
Set myMail = Msg.Reply
myMail.To = "xxxxxx#fakemail.com"
myMail.Display
End If
End If
ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ProgramExit
End Sub
I'd like to forward any email that contains "Excel Friday" in the subject line to another email address.
But in the code you check for the exact match of the subject line:
If Msg.Subject = "Excel Friday" Then
Instead you need to look for a substring. To find the position of a substring in a string, use Instr function.
If Instr(Msg.Subject, "Excel Friday") Then
Also I have noticed that you use the Reply method:
Set myMail = Msg.Reply
Use the Forward method instead:
Set myMail = Msg.Forward
And then use the Send method.
myMail.Recipients.Add "Eugene Astafiev"
myMail.Send
Be aware, the code is based on the ItemAdd event handler. This event is not fired when a large number of items are added to the folder at once (more than 16).
You can do this using a Run a Script rule
Sub ChangeSubjectForward(Item As Outlook.MailItem)
Item.Subject = "Test"
Item.Save
Set olForward = Item.Forward
olForward.Recipients.Add "Jasonfish11#domain.com"
olForward.Send
End Sub
If a vba you can run on all messages in a folder at any time.
Paste into ThisOutlookSession and run
Sub ChangeSubjectThenSend()
Dim olApp As Outlook.Application
Dim aItem As Object
Set olApp = CreateObject("Outlook.Application")
Set mail = olApp.ActiveExplorer.CurrentFolder
For Each aItem In mail.Items
aItem.Subject = "New Subject"
aItem.Save
Set olForward = aItem.Forward
olForward.Recipients.Add "Jasonfish11#domain.com"
olForward.Send
Next aItem
End Sub
source Link
Note: I wrote the following code in Outlook VBA. Basically the code is in ThisOutlookSession and I scan emails that start with "new", save the attachment in Desktop and debug.print the value in Cells(1,1). However, Outlook crashed and said "Object doesn't support this property or method" on the " Debug.Print sourceSH.Cells(1,1)" line. What is wrong?
Public WithEvents myOlItems As Outlook.Items
Private Sub Application_Startup()
Dim olApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Set olApp = Outlook.Application
Set objNS = olApp.GetNamespace("MAPI")
Dim f As Folder
Set f = Application.Session.Folders.item("me").Folders.item("Inbox")
Set myOlItems = f.Items
Call LoadForm
End Sub
Private Sub myOlItems_ItemAdd(ByVal item As Object)
On Error GoTo ErrorHandler
Dim Msg As Outlook.MailItem
Dim name As String
Dim res As String
Dim sourceWB As Workbook
Dim sourceSH As Worksheet
Dim NewFileName As String
Dim xlApp As Object
If TypeName(item) = "MailItem" Then
Set Msg = item
' do stuff with item
If Left(Msg.Subject, 3) = "New" And Msg.Attachments.Count > 0 Then
NewFileName = "C:\Desktop\" & Msg.Attachments.item(1).Filename
' save file
Msg.Attachments.item(1).SaveAsFile NewFileName
Set xlApp = CreateObject("Excel.Application")
xlApp.Application.Visible = True
Set sourceWB = xlApp.Workbooks.Open(NewFileName, True, True)
Set sourceSH = sourceWB.Worksheets(1)
Debug.Print sourceSH.Cells(1,1)
End If
End If
ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ProgramExit
End Sub
Debug.Print sourceSH.Cells(1,1)
The Print method output the message to the immediate window. You need to pass a string, not the Range object. Try to pass the Text property values to the Print method.
Debug.Print sourceSH.Cells(1,1).Text
So, the goal is that when I receive an email from a customer, containing the desired attachment, save the attachment to a location of my choosing.
This is my new code, it compiles but doesn't output the file?
Thanks in advance.
Private WithEvents Items As Outlook.Items
Private Sub Application_Startup()
Dim olApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Set olApp = Outlook.Application
Set objNS = olApp.GetNamespace("MAPI")
Set Items = objNS.GetDefaultFolder(olFolderInbox).Items
End Sub
Private Sub Application_NewMail()
Dim oInbox As MAPIFolder
Dim oItem As MailItem
Set oInbox = Application.Session.GetDefaultFolder(olFolderInbox)
Set oItem = oInbox.Items.GetLast
'Only act if it's a MailItem
Dim Msg As Outlook.MailItem
If TypeName(item) = "MailItem" Then
Set Msg = oItem
'Change variables to match need. Comment or delete any part unnecessary.
If (Msg.SenderName = "Name Of Person") And _
(Msg.Subject = "Subject to Find") And _
(Msg.Attachments.Count >= 1) Then
'Set folder to save in.
Dim olDestFldr As Outlook.MAPIFolder
Dim myAttachments As Outlook.Attachments
Dim Att As String
'location to save in. Can be root drive or mapped network drive.
Const attPath As String = "C:\"
' save attachment
Set myAttachments = item.Attachments
Att = myAttachments.item(1).DisplayName
myAttachments.item(1).SaveAsFile attPath & Att
' mark as read
Msg.UnRead = False
End If
End If
ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ProgramExit
End Sub
When you open the VBA window, you will see the object called "ThisOutlookSession", which is where you place the code.
This event is triggered automatically upon reception of a new email received:
Private Sub Application_NewMail()
Dim oInbox As MAPIFolder
Dim oItem As MailItem
Set oInbox = Application.Session.GetDefaultFolder(olFolderInbox)
Set oItem = oInbox.Items.GetLast
//MsgBox oItem.To
//Etcetera
End Sub
About your edit, I didn't really investigate why it didn't work, but you can use this, which I tested:
Dim atmt As Outlook.Attachment
Dim Att As String
Const attPath As String = "U:\"
For Each atmt In Msg.Attachments
Att = atmt.DisplayName
atmt.SaveAsFile attPath & Att
Next
Note that it may seem as if you didn't save the file, because you cannot use 'Date modified' in WinExplorer to show the latest saved attachment (I noticed just now). But you can look it up alphabetically.