Move email after being categorized - vba

I want to move emails, once they are categorized, into a folder with the same name as the category.
What I found so far:
Private WithEvents Explorer As Outlook.Explorer
Private WithEvents Mail As Outlook.MailItem
Private MoveToThisFolder As Outlook.MAPIFolder
Friend Sub Application_Startup()
On Error Resume Next
Set Explorer = Application.ActiveExplorer
End Sub
Private Sub Explorer_SelectionChange()
Dim obj As Object
Dim Sel As Outlook.Selection
Set Mail = Nothing
Set Sel = Explorer.Selection
If Sel.Count > 0 Then
Set obj = Sel(1)
If TypeOf obj Is Outlook.MailItem Then
Set Mail = obj
End If
End If
End Sub
Private Sub Mail_PropertyChange(ByVal Name As String)
Dim Ns As Outlook.NameSpace
Dim Inbox As Outlook.MAPIFolder
Dim Subfolder As Outlook.MAPIFolder
Dim SubfolderName As String
If Name = "Categories" Then
Set Ns = Application.GetNamespace("MAPI")
Set Inbox = Ns.GetDefaultFolder(olFolderInbox)
SubfolderName = Mail.Categories
If Len(SubfolderName) = 0 Then Exit Sub
Set Subfolder = Inbox.Folders(SubfolderName)
If Subfolder.EntryID <> Mail.Parent.EntryID Then
Set MoveToThisFolder = Subfolder
EnableTimer 500, Me
End If
End If
End Sub
Friend Sub TimerEvent()
DisableTimer
If Mail Is Nothing Then Exit Sub
If MoveToThisFolder Is Nothing Then Exit Sub
Mail.Move MoveToThisFolder
Set Mail = Nothing
Set MoveToThisFolder = Nothing
End Sub
I have some problems with respect to Friend Sub TimerEvent () because it gives me
Sub or Function not compiled correctly

At the end i figured out in this way:
Private WithEvents xInboxFld As Outlook.Folder
Private WithEvents xInboxItems As Outlook.Items
Private Sub Application_Startup()
Set xInboxFld = Outlook.Application.Session.GetDefaultFolder(olFolderInbox)
Set xInboxItems = xInboxFld.Items
End Sub
Private Sub xInboxItems_ItemChange(ByVal Item As Object)
Dim xMailItem As Outlook.MailItem
Dim xFlds As Outlook.Folders
Dim xFld As Outlook.Folder
Dim xTargetFld As Outlook.Folder
Dim xFlag As Boolean
On Error Resume Next
If Item.Class = olMail Then
Set xMailItem = Item
xFlag = False
If xMailItem.Categories <> "" Then
Set xFlds = Application.Session.GetDefaultFolder(olFolderInbox).Folders
If xFlds.Count <> 0 Then
For Each xFld In xFlds
If xFld.Name = xMailItem.Categories Then
xFlag = True
End If
Next
End If
If xFlag = False Then
Application.Session.GetDefaultFolder(olFolderInbox).Folders.Add xMailItem.Categories, olFolderInbox
End If
Set xTargetFld = Application.Session.GetDefaultFolder(olFolderInbox).Folders(xMailItem.Categories)
xMailItem.Move xTargetFld
End If
End If
End Sub
Hope it could help!!!

The error is due to missing code for DisableTimer and EnableTimer.
The category has not yet updated when the code is triggered.
EnableTimer delays the move until after the category updates.
Without a delay, there would be an error when attempting to update, due to the item having been moved.
Attribution: http://www.vboffice.net/en/developers/trigger-actions-with-categories/

Related

Run code when new email comes to any subfolder in a Shared Mailbox

I want to run code when any new email comes to a specific shared mailbox.
The event triggers when the email comes to INBOX folder.
The event does not trigger if a new email comes straight to its subfolders - like to shared#mailbox.com/Inbox/subfolder1.
What should I change so the code runs if a new email comes to any subfolder in the inbox?
The mailbox has a lot of subfolders. Moreover their structure may change.
Option Explicit
Private WithEvents mtFolder As Outlook.Folder
Private WithEvents mtItems As Outlook.Items
Private Sub mtItems_ItemAdd(ByVal Item As Object)
Debug.Print "XXX"
'my CODE
End Sub
Private Sub Application_Startup()
Dim Ns As Outlook.NameSpace
Set Ns = Application.GetNamespace("MAPI")
Dim objOwner
Set objOwner = Ns.CreateRecipient("shared#mailbox.com")
objOwner.Resolve
If objOwner.Resolved Then
Set mtFolder = Ns.GetSharedDefaultFolder(objOwner, olFolderInbox)
Set mtItems = mtFolder.Items
End If
Set Ns = Nothing
Exit Sub
eh:
End Sub
Thank you a lot for your help! Here the solution.
At first I have added Class Module named "clsFolder" with events:
Option Explicit
Private OlFldr As Folder
Public WithEvents Items As Outlook.Items
'called to set up the object
Public Sub Init(f As Folder) ', sPath As String)
Set OlFldr = f
Set Items = f.Items
End Sub
Private Sub Items_ItemAdd(ByVal Item As Object)
If TypeOf Item Is Outlook.MailItem Then
Debug.Print "eMail '" & Item.Subject & "' was added to Folder '" & OlFldr.name & _
"'. Mailbox: '" & Item.Parent.Store & "'."
'do sth with a email added...
End If
End Sub
Then in ThisOutlookSession I setup a collecion of folder for all (sub)folders in the SharedMailbox:
Option Explicit
Public colFolders As Collection '<< holds the clsFolder objects with events
Private Sub Application_Startup()
Dim Ns As Outlook.NameSpace
Dim oFolder As Outlook.Folder
Set Ns = Application.GetNamespace("MAPI")
Dim objOwner
Set objOwner = Ns.CreateRecipient("my_Shared_Mailibox")
objOwner.Resolve
If objOwner.Resolved Then
Set oFolder = Ns.GetSharedDefaultFolder(objOwner, olFolderInbox)
Set colFolders = New Collection
processFolder oFolder
End If
Set Ns = Nothing
Set oFolder = Nothing
Exit Sub
eh:
End Sub
'function to create folder objects
Function GetFolderObject(foldr As Folder)
Dim rv As New clsFolder
rv.Init foldr
Set GetFolderObject = rv
End Function
'process all subfolders
Private Sub processFolder(ByVal oParent As Outlook.MAPIFolder)
Dim oFolder As Outlook.MAPIFolder
colFolders.Add GetFolderObject(oParent)
Dim oMail As Outlook.MailItem
For Each oMail In oParent.Items
'do sth with every email if necessary
Next
If (oParent.Folders.Count > 0) Then
For Each oFolder In oParent.Folders
processFolder oFolder
Next
End If
End Sub

Remove an email from outbox and re-edit

I have VBA code to delay sending messages by five minutes.
Dim obj As Object
Dim Mail As Outlook.MailItem
Dim WkDay As Integer
Dim MinNow As Integer
Dim SendHour As Integer
Dim SendDate As Date
Dim SendNow As String
Dim UserDeferOption As Integer
Function getActiveMessage() As Outlook.MailItem
Dim insp As Outlook.Inspector
If TypeOf Application.ActiveWindow Is Outlook.Inspector Then
Set insp = Application.ActiveWindow
End If
If insp Is Nothing Then
Dim inline As Object
Set inline = Application.ActiveExplorer.ActiveInlineResponse
If inline Is Nothing Then Exit Function
Set getActiveMessage = inline
Else
Set insp = Application.ActiveInspector
If insp.CurrentItem.Class = olMail Then
Set getActiveMessage = insp.CurrentItem
Else
Exit Function
End If
End If
End Function
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
SendDate = Now()
SendHour = Hour(Now)
MinNow = Minute(Now)
Set obj = getActiveMessage()
If obj Is Nothing Then
'Do Nothing'
Else
If TypeOf obj Is Outlook.MailItem Then
Set Mail = obj
SendMin = 5
SendDate = DateAdd("n", SendMin, SendDate)
Mail.DeferredDeliveryTime = SendDate
End If
End If
Exit Sub
End Sub
I need a way to stop the item from sending. We can't delete it and start again as emails take a long time to compose and are highly detailed.
I'd like to add a button to the ribbon or context menu of Outlook 365, to re-open the email for editing and stop the deferred send.
I get
an object can't be found
Sub MoveEmail()
Dim OutboxFolder As Outlook.Folder
Set OutboxFolder = GetNamespace("MAPI").GetDefaultFolder(olFolderOutbox)
Set MoveFolder = GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Folders("Drafts")
Dim CurrentItem As Object
For Each CurrentItem In OutboxFolder.Items
CurrentItem.Move MoveFolder
Next CurrentItem
End Sub
Got it sorted, for anyone else...
Sub MoveEmail()
Dim myNamespace As Outlook.NameSpace
Set myNamespace = Application.GetNamespace("MAPI")
Set OutboxFolder = myNamespace.GetDefaultFolder(olFolderOutbox)
Set MoveFolder = myNamespace.GetDefaultFolder(olFolderDrafts)
Dim CurrentItem As Object
For Each CurrentItem In OutboxFolder.Items
CurrentItem.Move MoveFolder
Next CurrentItem
End Sub

Move Shared Mailbox Email To Folder When Category Assigned

I have a script that works on my main inbox. It will move the email to a sub folder when a category is assigned. The sub folder is the same name as the category.
How do I modify the code to reference a shared mailbox?
My code that works on main inbox:
Private WithEvents xInboxFld As Outlook.Folder
Private WithEvents xInboxItems As Outlook.Items
Private Sub Application_Startup()
Set xInboxFld = Outlook.Application.Session.GetDefaultFolder(olFolderInbox)
Set xInboxItems = xInboxFld.Items
End Sub
Private Sub xInboxItems_ItemChange(ByVal Item As Object)
Dim xMailItem As Outlook.MailItem
Dim xFlds As Outlook.Folders
Dim xFld As Outlook.Folder
Dim xTargetFld As Outlook.Folder
Dim xFlag As Boolean
On Error Resume Next
If Item.Class = olMail Then
Set xMailItem = Item
xFlag = False
If xMailItem.Categories <> "" Then
Set xFlds = Application.Session.GetDefaultFolder(olFolderInbox).Folders
If xFlds.Count <> 0 Then
For Each xFld In xFlds
If xFld.Name = xMailItem.Categories Then
xFlag = True
End If
Next
End If
If xFlag = False Then
Application.Session.GetDefaultFolder(olFolderInbox).Folders.Add xMailItem.Categories, olFolderInbox
End If
Set xTargetFld = Application.Session.GetDefaultFolder(olFolderInbox).Folders(xMailItem.Categories)
xMailItem.Move xTargetFld
End If
End If
End Sub
I was able to get it working with the below
Option Explicit
Private WithEvents SharedInboxFld As Outlook.Folder
Private WithEvents SharedInboxItems As Outlook.Items
Private Sub Application_Startup()
Set SharedInboxFld = Outlook.Application.Session.Folders.Item("Shared MailboxName").Folders("Inbox") 'use the appropriate folder name
Set SharedInboxItems = SharedInboxFld.Items
End Sub
Private Sub SharedInboxItems_ItemChange(ByVal Item As Object)
Dim xFlds As Outlook.Folders
Dim xFld As Outlook.Folder
Dim xTargetFld As Outlook.Folder
Dim xFlag As Boolean
On Error Resume Next
If Item.Class = olMail Then
xFlag = False
If Item.Categories <> "" Then
Set xFlds = SharedInboxFld.Folders
If xFlds.Count <> 0 Then
For Each xFld In xFlds
If xFld.Name = Item.Categories Then
xFlag = True
End If
Next
End If
If xFlag = False Then
SharedInboxFld.Folders.Add Item.Categories, olFolderInbox
End If
Set xTargetFld = SharedInboxFld.Folders(Item.Categories)
Item.Move xTargetFld
End If
End If
End Sub
Instead of GetDefaultFolder, call Outlook.Application.Session.CreateRecipient, and pass the returned Recipient object to GetSharedDefaultFolder.

Move Email with ItemAdd

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

Outlook program to move Attachments to SubFolder

I have written this small program in VS2010 to run on Outlook 2007.
It works for a standard read through of the Inbox, but I cannot get it to correctly point to other Folders, I am getting a "COMException was unhandled by user code" error that says "The operation failed. An object could not be found." ...
I have included a screenshot of my Outlook structure if it helps ...
Imports Microsoft.Office.Interop
Public Class ThisAddIn
Private Sub ThisAddIn_Startup() Handles Me.Startup
End Sub
Private Sub ThisAddIn_Shutdown() Handles Me.Shutdown
End Sub
Private Sub Application_Startup() Handles Application.Startup
Dim MyApp As Outlook.Application = New Outlook.Application
Dim MyNS As Outlook.NameSpace = MyApp.GetNamespace("MAPI")
Dim MyInbox As Outlook.MAPIFolder = MyNS.GetDefaultFolder(Outlook.OlDefaultFolders.olFolderInbox)
Dim MyEmails As Integer = MyInbox.Items.Count
Dim MyEMail As Outlook.MailItem
Dim MyCount As Integer
Dim MySubFolder As Outlook.MAPIFolder = MyNS.Folders("Kickabout") **<<< Error occurs here**
For MyCount = MyEmails To 1 Step -1
MyEMail = MyInbox.Items(MyCount)
If MyEMail.SenderEmailAddress = "MrX#abc.com" Then
If MyEMail.Attachments.Count > 0 Then
MySubFolder = MyNS.Folders("Kickabout\Attachments")
End If
MyEMail.Move(MySubFolder)
End If
Next
End Sub
End Class
OK, I have solved this myself ... if anybody is interested in the future, you have to be quite explicit in setting up the path & need a Function to do so, here is the code ...
Imports Microsoft.Office.Interop
Public Class ThisAddIn
Dim strFolderPath As String
Private Sub ThisAddIn_Startup() Handles Me.Startup
End Sub
Private Sub ThisAddIn_Shutdown() Handles Me.Shutdown
End Sub
Private Sub Application_Startup() Handles Application.Startup
Dim MyApp As Outlook.Application = New Outlook.Application
Dim MyNS As Outlook.NameSpace = MyApp.GetNamespace("MAPI")
Dim MyInbox As Outlook.MAPIFolder = MyNS.GetDefaultFolder(Outlook.OlDefaultFolders.olFolderInbox)
Dim MyEmails As Integer = MyInbox.Items.Count
Dim MyEMail As Outlook.MailItem
Dim MyCount As Integer
Dim MySubFolder As Outlook.Folder = GetMyFolder("Outlook (Gary)\Kickabout")
Stop
For MyCount = MyEmails To 1 Step -1
MyEMail = MyInbox.Items(MyCount)
If MyEMail.SenderEmailAddress = "MrX#abc.com" Then
If MyEMail.Attachments.Count > 0 Then
MySubFolder = GetMyFolder("Outlook (Gary)\Kickabout\Attachments")
End If
MyEMail.Move(MySubFolder)
End If
Next
End Sub
Function GetMyFolder(FolderPath)
' folder path needs to be something like
' "Public Folders\All Public Folders\Company\Sales"
Dim aFolders
Dim fldr
Dim i
Dim objNS
On Error Resume Next
strFolderPath = Replace(FolderPath, "/", "\")
aFolders = Split(FolderPath, "\")
'get the Outlook objects
' use intrinsic Application object in form script
objNS = Application.GetNamespace("MAPI")
'set the root folder
fldr = objNS.Folders(aFolders(0))
'loop through the array to get the subfolder
'loop is skipped when there is only one element in the array
For i = 1 To UBound(aFolders)
fldr = fldr.Folders(aFolders(i))
'check for errors
'If Err() <> 0 Then Exit Function
Next
GetMyFolder = fldr
' dereference objects
objNS = Nothing
End Function
End Class