I have code that moves an email to a folder and mark it as read when I assign a category to the email.
The code actually works, in that it does what I want it to do, with the exception of throwing this error.
When I debug it shows the following
Private WithEvents objInboxFolder As Outlook.Folder
Private WithEvents objInboxItems As Outlook.Items
'Process inbox mails
Private Sub Application_Startup()
Set objInboxFolder = Outlook.Application.Session.GetDefaultFolder(olFolderInbox)
Set objInboxItems = objInboxFolder.Items
End Sub
'Occurs when changing item
Private Sub objInboxItems_ItemChange(ByVal Item As Object)
Dim objMail As Outlook.MailItem
Dim objTargetFolder As Outlook.Folder
If TypeOf Item Is MailItem And Item.Categories <> "" Then
Set objMail = Item
'Move mails based on color category
If InStr(objMail.Categories, "Personal") > 0 Then
Set objTargetFolder = Application.Session.GetDefaultFolder(olFolderInbox).Folders("Personal")
objMail.Move objTargetFolder
Else
objMail.UnRead = False
objMail.Save
Set objTargetFolder = Application.Session.GetDefaultFolder(olFolderInbox).Folders("01 Actioned")
objMail.Move objTargetFolder
End If
End If
End Sub
Consider If TypeOf Item Is MailItem And Item.Categories <> "".
VBA evaluates every term of a Boolean expression before combining them to get the final result. It does not check TypeOf Item Is MailItem and only continue if Item is a MailItem. If Item is not a MailItem, Item.Categories will fail.
Try:
If TypeOf Item Is MailItem Then
If Item.Categories <> ""
. . . .
End If
End If
Related
I am trying to auto forward an email from a specific sender and with a specific subject to a list of new recipients.
When I create a Run a Script Rule, my script is not shown.
Add my script via VBA Editor
Rules > Manage Rules & Alerts > Run a script
Select Run a script action -> Can not Select my script (script not show)
Option Explicit
Public WithEvents objInbox As Outlook.Folder
Public WithEvents objInboxItems As Outlook.Items
Private Sub Application_Startup()
Set objInbox = Outlook.Application.Session.GetDefaultFolder(olFolderInbox)
Set objInboxItems = objInbox.Items
End Sub
Private Sub objInboxItems_ItemAdd(ByVal Item As Object)
Dim objMail As Outlook.MailItem
Dim objForward As Outlook.MailItem
Dim xStr1 As String
Dim xStr2 As String
If TypeOf Item Is MailItem Then
Set objMail = Item
If (objMail.SenderEmailAddress = "T#com") And (objMail.Subject = "ZZZZZ") Then
Set objForward = objMail.Forward
GoTo commonOutput
End If
End If
Exit Sub
commonOutput:
With objForward
.HTMLBody = xStr1 & xStr2 & Item.HTMLBody
.Display
End With
Release:
Set myFwd = Nothing
End Sub
VBA script which can be assigned to a rule should have the following signature:
Public Sub Test(item as object)
' your code
End Sub
Your existing code does almost the same without rules. It handles the ItemAdd event for the Inbox folder, so you just need to replace the Display method call with Send:
Private Sub objInboxItems_ItemAdd(ByVal Item As Object)
Dim objMail As Outlook.MailItem
Dim objForward As Outlook.MailItem
Dim xStr1 As String
Dim xStr2 As String
If TypeOf Item Is MailItem Then
Set objMail = Item
If (objMail.SenderEmailAddress = "T#com") And (objMail.Subject = "ZZZZZ") Then
Set objForward = objMail.Forward
GoTo commonOutput
End If
End If
Exit Sub
commonOutput:
With objForward
.HTMLBody = xStr1 & xStr2 & Item.HTMLBody
.Send
End With
Release:
Set myFwd = Nothing
End Sub
My code looks like this:
Public WithEvents myItem As Outlook.MailItem
Private Sub Application_ItemLoad(ByVal Item As Object)
If Item.Class = olMail Then
Set myItem = Item
End If
End Sub
Private Sub myItem_Open(Cancel As Boolean)
Dim oAccount As Outlook.Explorer
Dim oMail As MailItem
Dim Recip As Outlook.Recipient
Set oAccount = Application.ActiveExplorer
MsgBox (oAccount.CurrentFolder.Store)
If oAccount.CurrentFolder.Store = "1#2.com" Then
MsgBox ("CC needs to be added")
Set Recip = myItem.Recipients.Add("user#test.com")
Recip.Type = olBCC
Else
MsgBox ("no need to add CC")
End If
End Sub
The part responsible for adding user#test.com to the CC field is adding that address to the "To:" field instead.
i just had to add Recip.Resolve after Recip.Type = olCC. That solved the issue.
I'm Having trouble deleting Emails with same subject line but keeping the newly received Email on Outlook-vba
Does anyone have any ideas on how to do that?
You can work with Dictionary Object to Store Items.Subject while you measure the received Item.ReceivedTime with Item.ReceivedTime in your Inbox.Items
Dictionary in VBA is a collection-object:
you can store all kinds of things in it: numbers, texts, dates, arrays, ranges, variables and objects, Every item in a Dictionary gets its own unique key and
With that key you can get direct access to the item (reading/writing).
Now to Automate the process - Try working with Application.Startup Event (Outlook) And Items_ItemAdd Event (Outlook)
Items.ItemAdd Event 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.
Code Example
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)
Set Items = Inbox.Items
End Sub
Private Sub Items_ItemAdd(ByVal Item As Object)
If TypeOf Item Is Outlook.MailItem Then
RemoveDupEmails Item ' call sub
End If
End Sub
Private Sub RemoveDupEmails(ByVal Item As Object)
Dim olNs As Outlook.NameSpace
Dim Inbox As Outlook.MAPIFolder
Dim DupItem As Object
Dim Items As Outlook.Items
Dim i As Long
Set olNs = Application.GetNamespace("MAPI")
Set Inbox = olNs.GetDefaultFolder(olFolderInbox)
Set Items = Inbox.Items
Debug.Print Item.ReceivedTime ' Immediate Window
Set DupItem = CreateObject("Scripting.Dictionary")
Set Items = Inbox.Items
Items.Sort "[ReceivedTime]"
For i = Items.Count To 1 Step -1
DoEvents
If TypeOf Items(i) Is MailItem Then
Set Item = Items(i)
If Item.ReceivedTime >= Items(i).ReceivedTime Then
If DupItem.Exists(Item.Subject) Then
Debug.Print Item.Subject ' Immediate Window
'Item.Delete ' UnComment to delete Item
Else
DupItem.Add Item.Subject, 0
End If
End If
End If
Next i
Set olNs = Nothing
Set Inbox = Nothing
Set DupItem = Nothing
Set Items = Nothing
End Sub
I have been trying to get below to trigger on a shared inbox.
I can get this working fine using a script I call manually with a for loop on the Inbox.
I can also get this working using my main inbox using the Session.GetDefaultFolder(olFolderInbox).Items.
Any help on where I am going wrong?
Private WithEvents olInboxItems As Items
Private Sub Application_Startup()
Dim ns As NameSpace
Dim olInboxItems As MAPIFolder
Set ns = Application.GetNamespace("MAPI")
Set objOwner = ns.CreateRecipient("xx#xx.com")
Set olInboxItems = ns.GetSharedDefaultFolder(objOwner, olFolderInbox)
Debug.Print ns
Debug.Print objOwner
Debug.Print olInboxItems
End Sub
Private Sub olInboxItems_ItemAdd(ByVal Item As Object)
On Error Resume Next
Dim olMailItem As MailItem
Dim strAttachmentName As String
'
' Only inspect mail items
' Ignore appointments, meetings, tasks, etc.
'
If TypeOf Item Is MailItem Then
Debug.Print MailItem
Set olMailItem = Item
If olMailItem.Attachments.Count = 1 Then
strAttachmentName = olMailItem.Attachments.Item(1).FileName
olMailItem.Attachments.Item(1).SaveAsFile "C:\EmailAttachments\" + strAttachmentName
End If
End If
Set Item = Nothing
Set olMailItem = Nothing
End Sub
You declare the variable as Items, but you assign it to an instance of the MAPIFolder object.
Change that code to
Set olInboxItems = ns.GetSharedDefaultFolder(objOwner, olFolderInbox).Items
Dmitry identified the problem - Contradictory declarations.
The underlying issue is the misuse of
On Error Resume Next
" It is very important to remember that On Error Resume Next does not in any way "fix" the error. It simply instructs VBA to continue as if no error occured."
and the non-use of
Option Explicit
You might have found.
Dim olInboxItems As Items
Set olInboxItems = ns.GetSharedDefaultFolder(objOwner, olFolderInbox).Items
rather than
Dim olInboxItems As MAPIfolder
Or you could do it this way-
Private WithEvents Items As Outlook.Items
Private Sub Application_Startup()
Dim ns As NameSpace
Dim olInboxItems As MAPIFolder
Dim objOwner As Outlook.Recipient
Set ns = Application.GetNamespace("MAPI")
Set objOwner = ns.CreateRecipient("xx#xx.com")
Set olInboxItems = ns.GetSharedDefaultFolder(objOwner, olFolderInbox)
Set Items = olInboxItems.Items
'Debug.Print ns
'Debug.Print objOwner
'Debug.Print olInboxItems
End Sub
Private Sub Items_ItemAdd(ByVal Item As Object)
If TypeOf Item Is Outlook.MailItem Then
SaveAttachment Item
End If
End Sub
Private Sub SaveAttachment(olMailItem As Outlook.MailItem)
Dim strAttachmentName As String
'
' Only inspect mail items
' Ignore appointments, meetings, tasks, etc.
'
'Debug.Print MailItem
If olMailItem.Attachments.Count = 1 Then
strAttachmentName = olMailItem.Attachments.Item(1).FileName
olMailItem.Attachments.Item(1).SaveAsFile "C:\EmailAttachments\" + strAttachmentName
End If
Set olMailItem = Nothing
End Sub
I have wrote some vba in outlook that fires when a new email comes in. However I want to fire it on an old email for testing. Can anyone tell me how.
my current code is
Private Sub objInbox_ItemAdd(ByVal Item As Object)
Thanks
I've sorted it thanks.
Private Sub Application_Startup()
Set objInbox = Session.GetDefaultFolder(olFolderInbox).Items
'Call test
'MsgBox "outlook starting"
End Sub
Sub test()
MsgBox "in test"
Dim ns As NameSpace
Dim item As Object
Dim inbox As MAPIFolder
'Dim sub_folder As MAPIFolder
Set ns = GetNamespace("MAPI")
Set inbox = ns.GetDefaultFolder(olFolderInbox)
'Set sub_folder = inbox.Folders("TEST")
For Each item In inbox.Items
If TypeOf item Is MailItem Then
MsgBox "right subject"
End If
Next item
End Sub