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
Related
I made a code that would take an incomming email in a specific folder (First a rule is created in order to move the mail to the folder and then the script is launched).
The problem is that the rule is working (it moves the mail to the folder), but the script isn't.
The thing is that when I take the new mail and transfer it to myself (My email is also in the receivers in the rules), the script is correctly working.
Here is the beginning of the code that I believe may be wrong.
Sub Script(item As Outlook.MailItem)
Dim strMailID As String
Dim objMail As Outlook.MailItem
Dim objNamespace As Outlook.NameSpace
strMailID = item.EntryID
Set objNamespace = Application.GetNamespace("MAPI")
Set objMail = objNamespace.GetItemFromID(strMailID)
Dim objpf As MAPIFolder
If objMail.MessageClass = "IPM.Note" Then
Any help would be appreciated
You need add an event listener to the default local Inbox, it worked with Outlook 2016.
This code will add an event listener to the default local Inbox. Action will be placed upon incoming emails. You need to add actions you need in the code below:
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
' ******************
' do something here
' ******************
End If
ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ProgramExit
End Sub
After pasting the code in ThisOutlookSession module, you must restart Outlook.
I have written a brief piece of code to perform certain actions when an e-mail arrives in the mailbox, but it only seems to work for the first e-mail that arrives immediately after the code is saved, after that nothing happens for subsequent e-mails.
I have put a watch on the code, and nothing is triggered, so it is not just a subsequent error in the subsequent code.
Code is (in the session object):
Option Explicit
Private objNS As Outlook.Namespace
Private WithEvents objItems As Outlook.Items
Private sub Application_Startup()
Dim objWatchFolder as Outlook.Folder
Set objNS = Application.Getnamespace("MAPI")
Set objWatchFolder = objNS.GetDefaultFolder(olFolderInbox)
Set objItems = objWatchFolder.Items
End Sub
Private Sub objItems_ItemAdd(ByVal Item as Object)
' Do this, that, the other, passing the e-mail to other subroutines
' No problems in this code.
End Sub
Any guidance or pointers that can be given would be greatly appreciated!
Please restart your Outlook if you use the WithEvents. However, please try to the following code:
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
' ******************
' do something here
' ******************
End If
ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ProgramExit
End Sub
Reference link:How do I trigger a macro to run after a new mail is received in Outlook?
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 would like to make it so if an email comes in with a phone number in the subject line (so 10 numerical digits) then the system automatically moves it to a folder called "Texting."
User Reidacus asked a very similar question here:
Move incoming mail to folders with RegEx in a rule
But I can't get it to work for me. When the email comes in it just sits in my inbox. I am very new the VBA and (sorry), I don't have a clue what I'm doing. Do I need to install anything special into my system to get this to work?
Here is my adapted code (note: in the real code I have my real email address)
Sub filter(Item As Outlook.MailItem)
Dim ns As Outlook.NameSpace
Dim MailDest As Outlook.Folder
Set ns = Application.GetNamespace("MAPI")
Set Reg1 = CreateObject("VBScript.RegExp")
Reg1.Global = True
Reg1.Pattern = "([\d][\d][\d][\d][\d][\d][\d][\d][\d][\d])"
If Reg1.Test(Item.Subject) Then
Set MailDest = ns.Folders("firstname.lastname#email.ca").Folders("Inbox").Folders("Texting")
Item.Move MailDest
End If
End Sub
In order for your Sub Filter to run everytime a new emails comes in, you need to add an "event listener", by adding the code below to the ThisOutlookSession module (this code is taken from home, here on SO : How do I trigger a macro to run after a new mail is received in Outlook? )
In order for this code to take affect, you must Restart Outlook.
ThisOutlookSession Module Code
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")
' get 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
' Call your custom-made Filter Sub
Call filterNewMail_TenDig(item)
End If
ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ProgramExit
End Sub
Now, you only need to make the following modifications to your Module code. Using ns.GetDefaultFolder(olFolderInbox) will get you the default "Inbox" folder for the current profile (read here at MSDN link ).
Sub filterNewMail_TenDig Code
Sub filterNewMail_TenDig(item As Outlook.MailItem)
Dim ns As Outlook.NameSpace
Dim MailDest As Outlook.Folder
Set ns = Outlook.Application.GetNamespace("MAPI")
Set reg1 = CreateObject("VBScript.RegExp")
With reg1
.Global = True
.IgnoreCase = True
.Pattern = "\d{10,10}" ' Match any set of 10 digits
End With
If reg1.Test(item.Subject) Then
Set MailDest = ns.GetDefaultFolder(olFolderInbox).Folders("Texting")
item.Move MailDest
End If
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