Outlook VBA - move mail when assigned to a category - vba

I would like to move emails to a sub-folder of my inbox when I assign it a category
I found the following code from Extended Office but it does not work.
It is supposed to move mail to a subfolder with the same name as the category and create a folder if it does not exist.
I have enabled macros in Outlook's security settings and inserted some message box alerts to confirm that does in fact run.
The code is in ThisOutlookSession
Private WithEvents xInboxFld As Outlook.Folder
Private WithEvents xInboxItems As Outlook.Items
Private Sub Application_Startup()
MsgBox "Macros are working"
Set xInboxFld = Outlook.Application.Session.GetDefaultFolder(olFolderInbox)
Set xInboxItems = xInboxFld.Items
End Sub
Private Sub xInboxItems_ItemChange(ByVal Item As Object)
MsgBox "Item Changed"
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 don't know exactly why but this suddenly started working today, I had restarted Outlook several times before but after I needed to force close Outlook this morning it started working.
(I'm not even sure if it started working immediately because of the restart or if it was a short time afterwards triggered by something else)

Related

Outlook VBA - Select Sender Account when "New Email" is created

I'm using Outlook set up with a number of accounts (both POP and IMAP). When writing a new email I can obviously change which account is used to send the email by clicking the "From" button and selecting the appropriate account. However, I often forget to do this and the email then gets sent from the default account.
What I would like to be able to do is to trap the creation of the new email and display a form with radio buttons listing all the accounts so that the correct sender account can be selected before the email is drafted.
I can create the form with the list of accounts and which will return the selected account. I can also trap the creation of a new email with the Inspectors_NewInspector event but I am having problems when trying the set the Sender account.
I have tried the following code (in ThisOutlookSession) using the SendUsingAccount property but the code flags up an error saying that the property is read-only. Any ideas would be much appreciated.
Option Explicit
Private WithEvents objInspectors As Outlook.Inspectors
Private Sub Application_Startup()
Set objInspectors = Application.Inspectors
End Sub
Private Sub objInspectors_NewInspector(ByVal Inspector As Inspector)
Dim oEmail As Outlook.MailItem
If TypeName(Inspector.CurrentItem) = "MailItem" Then
Set oEmail = Inspector.CurrentItem
Set oEmail.SendUsingAccount = GetUserSelectedInput '<<<<gives error 440 - property is read-only
End If
End Sub
Private Function GetUserSelectedInput() As Account
Dim oNs As Outlook.NameSpace
Set oNs = Application.GetNamespace("MAPI")
'The following line is selecting an arbitrary account for testing purposes
'this will be replaced with the code to call a userform
'that will return the selected account
Set GetUserSelectedInput = oNs.Accounts.Item(2)
End Function
First of all, the Inspectors.NewInspector event is not the right place for accessing the mail item object. The event occurs after the new Inspector object is created but before the inspector window appears. So, I'd suggest waiting for the Inspector.Activate event which is fired when an inspector becomes the active window, either as a result of user action or through program code.
You may find the Implement a wrapper for inspectors and track item-level events in each inspector article helpful.
Second, the MailItem.SendUsingAccount property allows to set an Account object that represents the account under which the MailItem is to be sent. For example, a VBA sample code shows how to set up the property:
Sub SendUsingAccount()
Dim oAccount As Outlook.account
For Each oAccount In Application.Session.Accounts
If oAccount.AccountType = olPop3 Then
Dim oMail As Outlook.MailItem
Set oMail = Application.CreateItem(olMailItem)
oMail.Subject = "Sent using POP3 Account"
oMail.Recipients.Add ("someone#example.com")
oMail.Recipients.ResolveAll
Set oMail.SendUsingAccount = oAccount
oMail.Send
End If
Next
End Sub
I tried using the Inspector.Activate event and still had the same problem with the SendUsingAccount property being read only. I also tried using the MailIem.Open event and still the property errors as read only.
I then modified the code to Save the email before attempting to write to the SendUsingAccount property and that works, However, I'm not completely happy that it's a particularly elegant solution since it forces the email to be saved as a draft. What I can't understand is what "state" the email is in prior to the Save and whether there's another solution where the SendUsingAccount can be changed without doing the Save.
The code I'm currently using is shown below. Any comments would be welcomed.
Option Explicit
Private WithEvents objInspectors As Outlook.Inspectors
Private WithEvents objEmail As Outlook.MailItem
Public Sub test()
Set objInspectors = Application.Inspectors
End Sub
Private Sub Application_Startup()
Set objInspectors = Application.Inspectors
End Sub
Private Sub objInspectors_NewInspector(ByVal Inspector As Inspector)
If TypeOf Inspector.CurrentItem Is Outlook.MailItem Then
If Len(Inspector.CurrentItem.EntryID) = 0 Then
Set objEmail = Inspector.CurrentItem
End If
End If
End Sub
Private Sub objEmail_Open(Cancel As Boolean)
Dim objAcc As Outlook.Account
With objEmail
Set objAcc = GetUserSelectedInput()
If objAcc Is Nothing Then
Cancel = True
Else
.Save
.SendUsingAccount = objAcc
End If
End With
Set objAcc = Nothing
Set objEmail = Nothing
End Sub
Private Function GetUserSelectedInput() As Outlook.Account
Dim oNs As Outlook.NameSpace
Set oNs = Application.GetNamespace("MAPI")
'The following line is selecting an arbitrary account for testing purposes
'this will be replaced with the code to call a userform
'that will return the selected account
Set GetUserSelectedInput = oNs.Accounts.Item(3)
End Function
OK, that was silly - I was sure that I was getting a read-only error when setting SendUsingAccount property. Thanks niton for pointing out it works without it. So now I have the complete solution and it's working as required. For those that are interested, the complete code is listed below. It requires a simple form ("SelectAccount") which has a frame ("frmeOptionButtons") and two buttons ("btnOk" & "btnCancel") below the frame. The frame and form will resize depending on the number of accounts. It relies on using the form.tag property to pass a default account address when the form is opened and the selected address when OK is clicked.
The code for ThisOutlookSession is:
Option Explicit
Private WithEvents objInspectors As Outlook.Inspectors
Private WithEvents objEmail As Outlook.MailItem
Public Sub test()
Set objInspectors = Application.Inspectors
End Sub
Private Sub Application_Startup()
Set objInspectors = Application.Inspectors
End Sub
Private Sub objInspectors_NewInspector(ByVal Inspector As Inspector)
If TypeOf Inspector.CurrentItem Is Outlook.MailItem Then
If Len(Inspector.CurrentItem.EntryID) = 0 Then
Set objEmail = Inspector.CurrentItem
End If
End If
End Sub
Private Sub objEmail_Open(Cancel As Boolean)
Dim objAcc As Outlook.Account
With objEmail
Set objAcc = GetUserSelectedInput(.SendUsingAccount.SmtpAddress)
If objAcc Is Nothing Then
Cancel = True
Else
.SendUsingAccount = objAcc
End If
End With
Set objAcc = Nothing
Set objEmail = Nothing
End Sub
Private Function GetUserSelectedInput(DefaultAccount As String) As Outlook.Account
Dim objNs As Outlook.NameSpace
Dim objAcc As Outlook.Account
Dim SelectedAccount As String
With SelectAccount
.tag = LCase(DefaultAccount)
.Show
SelectedAccount = ""
On Error Resume Next 'in case form is closed
SelectedAccount = .tag
On Error GoTo 0
End With
If SelectedAccount = "" Then Exit Function
Set objNs = Application.GetNamespace("MAPI")
For Each objAcc In objNs.Accounts
If LCase(objAcc.SmtpAddress) = SelectedAccount Then
Set GetUserSelectedInput = objAcc
Exit For
End If
Next
Set objAcc = Nothing
Set objNs = Nothing
End Function
The code for the SelectAccount form is:
Option Explicit
Private Sub btnCancel_Click()
Me.tag = ""
Me.Hide
End Sub
Private Sub btnOk_Click()
Dim optButton As MSForms.OptionButton
Me.tag = ""
For Each optButton In Me.frmeOptionButtons.Controls
If optButton.value Then
Me.tag = optButton.tag
Exit For
End If
Next
Me.Hide
End Sub
Private Sub UserForm_Activate()
Dim optButton As MSForms.OptionButton
Dim NoOfBtns As Integer
Dim CaptionWidth As Long
Dim AccList() As String
Dim DefaulAccount As String
Dim i As Integer
DefaulAccount = LCase(Me.tag)
AccList = GetAccountList
NoOfBtns = UBound(AccList)
Me.btnOk.top = Me.frmeOptionButtons.top + (NoOfBtns) * 18 + 4
Me.btnCancel.top = Me.btnOk.top
Me.Height = Me.btnOk.top + Me.btnOk.Height + 36
With Me.frmeOptionButtons
.Height = NoOfBtns * 18 + 2
For Each optButton In .Controls
.Controls.Remove (optButton.Name)
Next
CaptionWidth = .Width - 4
For i = 1 To NoOfBtns
Set optButton = .Controls.Add("Forms.OptionButton.1")
With optButton
.left = 0
.top = 18 * (i - 1)
.Height = 18
.Width = CaptionWidth
.tag = LCase(AccList(i))
.Caption = AccList(i)
.value = (.tag = DefaulAccount)
End With
Next
End With
End Sub
Private Function GetAccountList() As Variant
Dim objNs As Outlook.NameSpace
Dim objAcc As Outlook.Account
Dim strAcc() As String
Dim i As Integer
Set objNs = Application.GetNamespace("MAPI")
i = 0
For Each objAcc In objNs.Accounts
i = i + 1
ReDim Preserve strAcc(i)
strAcc(i) = objAcc.SmtpAddress
Next
GetAccountList = strAcc
Set objAcc = Nothing
Set objNs = Nothing
End Function

Outlook run macro when mail arrives on a nondefault mailbox

I have multiple mailboxes set-up in my Outlook 2010. I would like a macro to run when I receive a mail on one of the non-default mailboxes.
I have coded the below and inserted the code into "ThisOutlookSession".
I have gotten it to work for the default mailbox's inbox but not my nondefault mailbox's inbox. When I try to re-open outlook 2010 having inserted the code, It tells me :
"Compile error in hidden module: ThisOutlookSession". The non-default box is called 'abc.asia'.
I am new to vba so any inputs are appreciated, thank you!
Dim WithEvents myInboxMailItem As Outlook Items
Private Sub myInboxMailItem_ItemAdd(ByVal Item As Object)
MsgBox("Item Added")
End Sub
Private Sub Initialize_Handler()
Dim fldInbox As Outlook.MapiFolder
Dim gnspNameSpace As Outlook.NameSpace
Set gnspNameSpace = Outlook.GetNameSpace("Mapi")
Set fldInbox = gnspNameSpace.Folders("abc.asia").Folders("Inbox")
Set myInboxMailtItem = fldInbox.Items
End Sub
Update Set olRecip = olNs.CreateRecipient("emal#address.com") with correct Email address.
Option Explicit
Private WithEvents Items As Outlook.Items
Private Sub Application_Startup()
Dim olNs As Outlook.NameSpace
Dim Inbox As Outlook.MAPIFolder
Dim olRecip As Recipient
Set olNs = Application.GetNamespace("MAPI")
Set olRecip = olNs.CreateRecipient("emal#address.com") '// Owner's Name or email address
Set Inbox = olNs.GetSharedDefaultFolder(olRecip, olFolderInbox)
Set Items = Inbox.Items
End Sub
Private Sub Items_ItemAdd(ByVal Item As Object)
If TypeOf Item Is Outlook.MailItem Then
Debug.Print Item.Subject
End If
End Sub

VBA Outlook userform prompt

I have a userform that is prompted when I send emails (works great. not the problem) and from there when I click the buttons on the form it moves that email to the respective folder.
What I now want is for that same userform (rather, a duplicate) to be prompted when a message in my inbox goes from unread to read. The buttons on the userform would then move that message to the respective folder.
Code to bring up userform when sending emails:
Private Sub Application_ItemSend(ByVal Item As Object, cancel As Boolean)
UserForm1.Show vbModal
cancel = False
End Sub
Code snippet for a button of the userform:
Private Sub CommandButton1_Click()
On Error GoTo error_movemessage
Dim myolapp As New Outlook.Application
Dim mynamespace As Outlook.NameSpace
Dim myinbox As Outlook.MAPIFolder
Dim mydestfolder As Outlook.MAPIFolder
Dim myitems As Outlook.Items
Dim myItem As Object
Set mynamespace = myolapp.GetNamespace("MAPI")
Set myinbox = Session.GetDefaultFolder(olFolderInbox).Parent.Folders("RetainPermanently")
Set myitems = myinbox.Items
Set mydestfolder = myinbox
Set myItem = Application.ActiveInspector.CurrentItem
myItem.Move mydestfolder
Unload Me
exit_CommandButton1_Click:
Exit Sub
error_movemessage:
MsgBox "ERROR! " & Err.Description
Resume exit_CommandButton1_Click
End Sub
I searched far and wide for pieces to this puzzle and ultimately ended up unsuccessful. Thank you in advance!
Update:
Private Sub getselecteditem_click()
Dim oApp As New Outlook.Application
Dim oExp As Outlook.Explorer
Dim oSel As Outlook.Selection
Dim oItem As Object
Set oExp = oApp.Application
Set oSel = oExp.Selection
For i = 1 To oSel.Count
Set oItem = oSel.Item(i)
If oItem.Class = olMail Then
End If
Next i
End Sub
Sub oItem_PropertyChange(ByVal Name As String)
Select Case Name
Case "UnRead"
If oItem.UnRead = False Then
UserForm2.Show vbModal
End If
End Select
End Sub
Still doesn't work however.
I realized that I've been making this much harder than it needs to be. I can simply get it to pull up the prompt whenever i load a mailitem that happens to be unread. Here is an update:
Private Sub Application_ItemLoad(ByVal Item As Object)
If Item.Class = olMail Then
If Item.UnRead Then
UserForm2.Show vbModal
End If
End If
End Sub
Firstly, if you move an item to a different folder when the message is sent, you are asking for trouble - if you want the message to be saved in a folder other than Sent Items, set the MailItem.SaveSentMessageFolder property.
To move a message when its read state changes, track the Explorer.SelectionChange event. When SelectionChange event fires, start tracking the events on multiple messages from the Explorer.Selection collection (there can be more than one, but you can get away with just the first one as a proof of concept). When MailItem.PropertyChange event fires on the Unread property, display your prompt and move the message.

How do I set a macro to launch every time an email arrives in a certain subfolder in outlook 2007?

I have a macro to export relevant field of emails in a subfolder but I need it to automatically run every time I receive a new email. In fact I only want the subject line exported, is there a script which will trigger that macro ('ExportMessagesToExcel') when an email lands in 'M_M_Asia'?
I'm in Outlook 2007.
I'll be forever grateful if anyone can help. Cheers guys.
You should be able to use the Application_NewMail (or NewMailEx) event in ThisOutlookSession module to call your own macro.
Another way is to create a rule that runs a VBA-script, but then you VBA sub needs to handle a MailItem parameter:
Option Explicit
Sub MyVBARule(poMail As MailItem)
End Sub
Or you could add 'ItemAdd' event handler, example here:
Option Explicit
Private Const ASIA_FOLDER_NAME As String = "M_M_Asia"
Private WithEvents m_outlookFolderItems As Outlook.Items
Private Sub Application_Startup()
Initialize_Handler
End Sub
Private Sub m_outlookFolderItems_ItemAdd(ByVal Item As Object)
' You have new mail in folder ASIA_FOLDER_NAME
RunExcelMacro
End Sub
Private Sub Initialize_Handler()
Dim outlookFolder As Outlook.MAPIFolder
Dim defaultInboxFolder As Outlook.MAPIFolder
Dim outlookNameSpace As Outlook.NameSpace
Set outlookNameSpace = Outlook.GetNamespace("MAPI")
Set defaultInboxFolder = outlookNameSpace.GetDefaultFolder(olFolderInbox)
Set outlookFolder = defaultInboxFolder.Folders(ASIA_FOLDER_NAME)
Set m_outlookFolderItems = outlookFolder.Items
End Sub
Public Sub RunExcelMacro()
On Error GoTo RunExcelMacro_Err
Const path As String = "C:\temp\Excel_VBA\"
Const fileName As String = "CallMeFromOutloouk.xlsm"
Const macroName As String = "CallMeFromOutlook"
Dim excelObject As Object
Dim workbookObject As Object
Set excelObject = CreateObject("Excel.Application")
On Error Resume Next
Set workbookObject = excelObject.Workbooks(fileName)
On Error GoTo RunExcelMacro_Err
If workbookObject Is Nothing Then
Set workbookObject = excelObject.Workbooks.Open(path & fileName)
End If
excelObject.Run fileName & "!" & macroName
Exit Sub
RunExcelMacro_Err:
MsgBox Err.Description
End Sub

VBA outlook new mail

I am trying to run a function every time a new mail arrives in outlook. I have been doing some searching but I am unable to find I way to fire code every time an email arrives. Is there a new mail event that I could utilize?
I added a simple MsgBox to it to be able to see if the event is firing but it did not seem to be working. I placed this code in the ThisOutlookSession module. Any adivice? Here is my code.
Public WithEvents myOlApp As Outlook.Application
Sub Initialize_handler()
Set myOlApp = CreateObject("Outlook.Application")
End Sub
Private Sub myOlApp_NewMail()
Dim myExplorers As Outlook.Explorers
Dim myFolder As Outlook.MAPIFolder
Dim x As Integer
Set myExplorers = myOlApp.Explorers
Set myFolder = myOlApp.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
If myExplorers.Count <> 0 Then
For x = 1 To myExplorers.Count
On Error GoTo skipif
If myExplorers.Item(x).CurrentFolder.Name = "Inbox" Then
MsgBox ("Test")
myExplorers.Item(x).Display
myExplorers.Item(x).Activate
Exit Sub
End If
skipif:
Next x
End If
On Error GoTo 0
myFolder.Display
End Sub
Try to put:
Private Sub Application_NewMail()
MsgBox "New mail"
End Sub
In "ThisOutlookSession"
There's a good example on MSDN showing how to display the inbox when a new mail arrives (using Outlook.Explorers). You can probably adapt it pretty readily for your own program.