The code below works perfectly:
Option Explicit
Dim myOlApp As New Outlook.Application
Public WithEvents myOlInspectors As Outlook.Inspectors
Private Sub Application_Startup()
Initialize_handler
End Sub
Public Sub Initialize_handler()
Set myOlInspectors = myOlApp.Inspectors
End Sub
Private Sub myOlInspectors_NewInspector(ByVal Inspector As Outlook.Inspector)
Dim msg As Outlook.MailItem
If Inspector.CurrentItem.Class = olMail Then
Set msg = Inspector.CurrentItem
If msg.Size = 0 Then
'MsgBox "New message" ' TEST LINE
msg.CC = "email#email.com"
End If
End If
End Sub
However, after a few hours of works. It suddenly stops firing (and I don't get any error).
Is there something I missunderstand about the code?
Is there something about Outlook.Inspectors, that makes it stop launching for some reason?
Your event method may fail if no item is currently open.
To add a CC recipient, you should do something like
Set myRecipient = msg.Recipients.Add("email#email.com")
myRecipient.Type = olCC
Documentation
Most probably the event is fired properly, but you have got an error in the code at runtime. The NewInspector event is not the best place for getting the CurrentItem property:
Private Sub myOlInspectors_NewInspector(ByVal Inspector As Outlook.Inspector)
Dim msg As Outlook.MailItem
If Inspector.CurrentItem.Class = olMail Then
Set msg = Inspector.CurrentItem
If msg.Size = 0 Then
'MsgBox "New message" ' TEST LINE
msg.CC = "email#email.com"
End If
End If
Especially the following line of code could raise an error at runtime:
If Inspector.CurrentItem.Class = olMail Then
Instead, consider using the first Inspector`s Activate event which is fired when an inspector becomes the active window, either as a result of user action or through program code. So, in the first Activate event you could get item's properties without a problem.
Also you may consider adding On Error statement to the code so you could be aware why the event "is not fired".
Related
I had a little macro set up with Outlook on another machine but now that I've switched computers I can't get it to work. When I try to run the last Private Sub, it doesn't recognize the name and pulls up the Macro selection box with no options listed.
I dislike having to manually mark emails in the Deleted Items folder as read, especially considering they had the amazing foresight to mark discarded drafts as unread.
Here's the code that used to work:
Dim WithEvents g_OlkFolder As Outlook.Items
Private Sub Application_Quit()
Set g_OlkFolder = Nothing
End Sub
Private Sub Application_Startup()
Set g_OlkFolder = Session.GetDefaultFolder(olFolderDeletedItems).Items
End Sub
Private Sub g_OlkFolder_ItemAdd(ByVal Item As Object)
Item.UnRead = False
Item.Save
End Sub
Here are a few things to try and check:
Put the cursor in the Application_Startup method and press F5. Then go back and try again. If this helps, the initialization has not run, and the g_OlkFolder variable is not set.
Put a breakpoint on the Item.UnRead = False line. If it doesn't stop there, your method isn't running.
Have you put your code in the ThisOutLookSession module?
Try using Application.Session property, or use GetNamespace method which I prefer
Example
Private WithEvents Items As Outlook.Items
Private Sub Application_Startup()
Dim olNs As Outlook.NameSpace
Dim DeletedFolder As Outlook.MAPIFolder
Set olNs = Application.GetNamespace("MAPI")
Set DeletedFolder = olNs.GetDefaultFolder(olFolderDeletedItems)
Set Items = DeletedFolder.Items
End Sub
Private Sub Items_ItemAdd(ByVal Item As Object)
If TypeOf Item Is Outlook.MailItem Then
' do something with Item
End If
End Sub
Or define olFolderDeletedItems or replace it with 3.
See this link for details.
Upon completely throwing away my code and starting from scratch I figured out a much simpler solution than what I was trying. Thanks for all the help anyways guys!
Sub MDAU()
Dim DI As Outlook.Items
Dim MSG As Object
Set DI = Session.GetDefaultFolder(olFolderDeletedItems).Items
Set MSG = Application.CreateItem(olMailItem)
For Each MSG In DI
MSG.UnRead = False
Next
End Sub
I have code that auto-zooms the email window pane. It worked until a few days ago after the latest update was made to MS Outlook.
'Install redemption and add "Microsoft Word Object Library" reference and "Redemption Outlook library" reference.
Option Explicit
Dim WithEvents objInspectors As Outlook.Inspectors
Dim WithEvents objOpenInspector As Outlook.Inspector
Dim WithEvents objMailItem As Outlook.MailItem
Dim WithEvents myOlExp As Outlook.Explorer
Dim sExplorer As Object
Dim Document As Object
Dim Msg
Const MsgZoom = 150
Private Sub Application_Startup()
Set objInspectors = Application.Inspectors
Set myOlExp = Application.ActiveExplorer
Set sExplorer = CreateObject("Redemption.SafeExplorer")
End Sub
Private Sub Application_Quit()
Set objOpenInspector = Nothing
Set objInspectors = Nothing
Set objMailItem = Nothing
End Sub
Private Sub objInspectors_NewInspector(ByVal Inspector As Inspector)
If Inspector.CurrentItem.Class = olMail Then
Set objMailItem = Inspector.CurrentItem
Set objOpenInspector = Inspector
End If
End Sub
Private Sub objOpenInspector_Close()
Set objMailItem = Nothing
End Sub
Private Sub objOpenInspector_Activate()
Dim wdDoc As Word.Document
Set wdDoc = objOpenInspector.WordEditor
wdDoc.Windows(1).Panes(1).View.Zoom.Percentage = MsgZoom
End Sub
Private Sub myOlExp_SelectionChange()
On Error GoTo ErrHandler:
Set Msg = Application.ActiveExplorer.Selection(1)
Application.ActiveExplorer.RemoveFromSelection (Msg)
Application.ActiveExplorer.AddToSelection (Msg)
sExplorer.Item = Application.ActiveExplorer
Set Document = sExplorer.ReadingPane.WordEditor
Document.Windows.Item(1).View.Zoom.Percentage = MsgZoom
Exit Sub
ErrHandler:
Exit Sub
End Sub
I have to click on the email, then click it again to get the auto-zoom to work. In the past, I clicked on the email once.
I am using Microsoft Outlook 2016 version 1805 (Build 9330.2087)
The code section that cause the problem is in myOlExp_SelectionChange().
Auto-zooming works in debugging mode when I add a breakpoint in myOlExp_SelectionChange() and step through the code.
Try to use the following call in the event handler before changing the Zoom level:
Application.DoEvents()
The DoEvents function yields execution so that the operating system can process other events. DoEvents passes control to the operating system. Control is returned after the operating system has finished processing the events in its queue and all keys in the SendKeys queue have been sent. DoEvents is most useful for simple things like allowing a user to cancel a process after it has started, for example a search for a file. For long-running processes, yielding the processor is better accomplished by using a Timer or delegating the task to an ActiveX EXE component. In the latter case, the task can continue completely independent of your application, and the operating system takes care of multitasking and time slicing. Any time you temporarily yield the processor within an event procedure, make sure the procedure is not executed again from a different part of your code before the first call returns; this could cause unpredictable results.
Private Sub myOlExp_SelectionChange()
DoEvents
Set Msg = Application.ActiveExplorer.Selection(1)
Application.ActiveExplorer.RemoveFromSelection (Msg)
Application.ActiveExplorer.AddToSelection (Msg)
sExplorer.Item = Application.ActiveExplorer
Set Document = sExplorer.ReadingPane.WordEditor
Document.Windows.Item(1).View.Zoom.Percentage = MsgZoom
End Sub
Also you may try to use a timer for introducing a delay before adjusting the Zoom level. You can use the SetTimer and KillTimer Windows API functions. See Outlook VBA - Run a code every half an hour for more information.
In outlook 2018 onwards, there is an option to save the zoom (please right click on the zoom percentage in the status bar)
I am trying to write a brief VBA script that will move incoming messages from my Outlook Inbox to a subfolder. This is what I currently have (assembled from various posts), but I'm not getting any result when I send test emails. If there are any other posts that would relate to this, I would appreciate it!
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
Set myInbox = GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
If TypeName(item) = "MailItem" Then
Set Msg = item
If Msg.SenderEmailAddress = "name#example.com" Then
If InStr(0, Msg.Subject, "Subject Title", vbTextCompare) > 0 Then
Msg.Move myInbox.Folders("Test").Subfolder("Destination")
End If
End If
End If
ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ProgramExit
End Sub
It looks like you didn't define and initialize the Items object properly. For example:
Public WithEvents myOlItems As Outlook.Items
Public Sub Initialize_handler()
Set myOlItems = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderContacts).Items
End Sub
Private Sub myOlItems_ItemAdd(ByVal Item As Object)
' do something here
End Sub
Be aware, the ItemAdd event is not fired when more than 16 items is added at the same time. This is a known issue in the OOM.
Try to use the NewMailEx event of the Application class instead. And I'd suggest reading the following series of articles:
Outlook NewMail event unleashed: the challenge (NewMail, NewMailEx, ItemAdd)
Outlook NewMail event: solution options
Outlook NewMail event and Extended MAPI: C# example
Outlook NewMail unleashed: writing a working solution (C# example)
Finally, is your macro enabled in Outlook? Have you checked out the Trust center settings?
Put your code in ThisOutlookSession.
Just above your code put
Public WithEvents Items As Items
When using the built-in class module ThisOutlookSession, Sub Application_Startup() initializes the handler.
I have the following code in ThisOutlookSession. It runs when an item is added to my sent email folder. It fires like it's supposed to but it keeps telling me that 'the argument isn't optional'. I've looked at a lot of examples and used it to build this one. I can't figure out what I am doing wrong. Looks like I am doing everything by the book but still my item argument in myItems_ItemAdd still comes up empty.
Private WithEvents myItems As Outlook.Items
Private Sub Application_Startup()
Set myItems = Outlook.Session.GetDefaultFolder(olFolderSentMail).Items
End Sub
Private Sub myItems_ItemAdd(ByVal Item As Object)
Dim olNS As Outlook.NameSpace
On Error GoTo ErrorHandler
Dim Msg As Outlook.MailItem
If TypeName(Item) = "MailItem" Then
Set Msg = Item
If InStr(Msg.Body, "[W]") > 0 Then
FlagWaitingForAnswerAndMove (Msg)
End If
End If
ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ProgramExit
End Sub
Did you try to debug the code? Do you get any errors?
Most probably the following condition returns false and you consider it as empty:
If TypeName(Item) = "MailItem" Then
Is that the case?
Try to remove the mentioned condition. Does it help?
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.