I'm writing a multi-purpose code in ThisOutlookSession, one part of the code has the job to get activated by PropertyChange in CurrentItem and if Subject is equal to a specific value, it first opens a MsgBox, on VBYes it Copies a value that is stored inside a .txt file and opens a mail with an .HTMLBody with that value.
It works fine if in the MsgBox input you answer VbYes, but if you answer VbNo then the PropertyChange is activated 3 times, in this case I have to answer 3 times VbNo.
I can actually see that the appearence of the MsgBox triggers the m_inspector_activate() which makes the code think that the Subject changed another time (this is how I think it works).
I will leave a shortened part of the code to let you see what I'am talking about.
Please text me if you do not understand something.
Option Explicit
'global variable used to disable the trigger of oItem_Forward(), oItem_Reply() and oItem_ReplyAll() while myItem_PropertyChange() is working
Public disableevents As Boolean
'private variables used to display mailitem on Reply, ReplyAll or Forward
Private WithEvents oExpl As Explorer
Private WithEvents oItem As MailItem
'private variables used ad inspectors in PropertyChange and ItemSend
Private WithEvents m_Inspectors As Outlook.Inspectors
Private WithEvents m_Inspector As Outlook.Inspector
Private WithEvents myItem As Outlook.MailItem
'declaration necessary to manage the forwards, replies and replyall events, recognizes the discard
Private bDiscardEvents As Boolean
'declaration of variable that manages the forwards, replies and replyall events
Dim exception As MailItem
'sub activated by opening outlook, it sets the inspectors
Private Sub Application_Startup()
Set oExpl = Application.ActiveExplorer
Set m_Inspectors = Application.Inspectors
bDiscardEvents = False
End Sub
'sub that on change of item selection, sets and stores the value of oItem variable to later open the forward, reply or replyall
Private Sub oExpl_SelectionChange()
' the on error avoids the error in case the item is not mailitem
On Error Resume Next
Set oItem = oExpl.selection.item(1)
End Sub
'sub activated by the event of pressing "reply"
Private Sub oItem_Reply(ByVal Response As Object, Cancel As Boolean)
' disableevents variable exits sub if its true, blocks the activation if myItem_PropertyChange() is working
On Error Resume Next
If disableevents = True Then Exit Sub
Cancel = True
bDiscardEvents = True
'displays the before selected email when the button "reply" was pressed
Set exception = oItem.Reply
exception.Display
End Sub
'sub activated by the event of pressing "forward"
Private Sub oItem_Forward(ByVal Response As Object, Cancel As Boolean)
' disableevents variable exits sub if its true, blocks the activation if myItem_PropertyChange() is working
On Error Resume Next
If disableevents = True Then Exit Sub
Cancel = True
bDiscardEvents = True
'displays the before selected email when the button "forward" was pressed
Set exception = oItem.Forward
exception.Display
End Sub
'sub activated by the event of pressing "replyall"
Private Sub oItem_ReplyAll(ByVal Response As Object, Cancel As Boolean)
' disableevents variable exits sub if its true, blocks the activation if myItem_PropertyChange() is working
On Error Resume Next
If disableevents = True Then Exit Sub
Cancel = True
bDiscardEvents = True
'displays the before selected email when the button "replyall" was pressed
Set exception = oItem.ReplyAll
exception.Display
End Sub
' on NewInspector it sets the inspectors variables
Private Sub m_Inspectors_NewInspector(ByVal Inspector As Outlook.Inspector)
If TypeOf Inspector.CurrentItem Is Outlook.MailItem Then
'Handle emails only:
Set oExpl = Application.ActiveExplorer
Set m_Inspector = Inspector
bDiscardEvents = False
End If
End Sub
'on m_Inspector activation the subs sets myItem variable
Private Sub m_Inspector_Activate()
If TypeOf m_Inspector.CurrentItem Is MailItem Then
Set myItem = m_Inspector.CurrentItem
End If
End Sub
'on myItem Property Change sub starts, this subs checks for subject, if subject is equal to a specific value then opens a mail using a .txt file(with html code inside) to use it as a template
Private Sub myItem_PropertyChange(ByVal Name As String)
'variables necessary to pull data from .txt file and then put it inside .HTMLBody
Dim FilePath As String
Dim TextFile As Integer
Dim FileContent As String
'inspector, explorer and mailitem used to check for subject, open selected mail and then open the "template"
Dim exp As Explorer
Dim ite As Inspector
Dim selection As selection
Dim currentmail As MailItem
Dim selectedmail As MailItem
'active part of the code where we set the various explorer, inspector and mailitems
Set exp = Outlook.ActiveExplorer
Set ite = Outlook.ActiveInspector
On Error Resume Next
Set currentmail = ite.CurrentItem
Set selection = exp.selection
On Error Resume Next
Set selectedmail = selection.item(1)
'variable that lowercases the current item subject to make it non-case sensitive
Dim lsubject As String
lsubject = LCase(myItem.Subject)
'variable that gets user's username
Dim varia As String
varia = Environ("username")
'if cycle that checks first for ConversationIndex (to control if this is a NewMail) and if lsubject (lowercase subject) is equal to a value then opens the "template"
If Len(currentmail.ConversationIndex) = 0 Then
If lsubject = "reso" Then
If MsgBox("Vuoi aprire il template ""Reso merce non conforme""?", vbYesNo) = vbYes Then
disableevents = True
FilePath = "INSERT YOUR PATH"
TextFile = FreeFile
Open FilePath For Input As TextFile
FileContent = Input(LOF(TextFile), TextFile)
Close TextFile
currentmail.Close False
Set it = Application.CreateItem(olMailItem)
With it
.To = currentmail.To
.CC = currentmail.CC
.HTMLBody = FileContent
.Display
End With
disableevents = False
Else
GoTo endvb
End if
End If
ElseIf Len(currentmail.ConversationIndex) <> 0 Then
If lsubject = "reso" Then
If MsgBox("Vuoi aprire il template ""Reso merce non conforme""?", vbYesNo) = vbYes Then
disableevents = True
FilePath = "INSERT YOUR PATH"
TextFile = FreeFile
Open FilePath For Input As TextFile
FileContent = Input(LOF(TextFile), TextFile)
Close TextFile
currentmail.Close False
selectedmail.Display
Set it = selectedmail.ReplyAll
With it
.To = selectedmail.To
.CC = selectedmail.CC
.HTMLBody = FileContent & it.HTMLBody
.Display
End With
disableevents = False
Else
GoTo endvb
End If
End If
End If
endvb:
End Sub
Function GetCurrentItem() As Object
'function that recognizes if email is open (active inspector) or if email is only selected and previewed (explorer)
Dim objApp As Outlook.Application
Set objApp = Application
On Error Resume Next
Select Case TypeName(objApp.ActiveWindow)
Case "Explorer"
Set GetCurrentItem = objApp.ActiveExplorer.selection.item(1)
Case "Inspector"
Set GetCurrentItem = objApp.ActiveInspector.CurrentItem
End Select
Set objApp = Nothing
End Function
Private Sub Application_ItemSend(ByVal item As Object, Cancel As Boolean)
'declaration of inspector and mail item
Dim ispettore As Outlook.Inspector
Dim mails As MailItem
'APIs to recognize the presence of attachments
Const PR_ATTACH_CONTENT_ID As String = "http://schemas.microsoft.com/mapi/proptag/0x3712001F"
Const PR_ATTACHMENT_HIDDEN As String = "http://schemas.microsoft.com/mapi/proptag/0x7FFE000B"
'variables for the attachment
Dim itemcorr As Outlook.MailItem
Dim miallegati As Outlook.Attachments
' setting the activeinspector and using the function Getcurrenitem() to choose for inspector or explorer, I use the error to avoid the errors generated from appointment items
Set ispettore = Application.ActiveInspector
On Error Resume Next
Set mails = GetCurrentItem()
On Error Resume Next
'variables that make possible the non case sensitive search in the HTMLBody of the email, the UpperCase stores the HTMLBody and the LowerCase makes the first variable lowercase
Dim UpperCase As String, LowerCase As String
On Error Resume Next
UpperCase = mails.HTMLBody
On Error Resume Next
LowerCase = LCase(UpperCase)
On Error Resume Next
Dim it As Variant
On Error Resume Next
'variables needed to check only the first email and not the previously sent ones
Dim testo As String
Dim range As String
Dim numero As String
Dim textcheck As String
Dim rangealt As String
Dim textcheckalt As String
Dim numeroalt As String
Dim textcheckeng As String
Dim numeroeng As String
Dim rangeeng As String
'variable that gets user's username
Dim varia As String
varia = Environ("username")
'variable to print "allegato" or "allegati" in the msgbox
Dim msgboxvar As String
testo = mails.HTMLBody
textcheck = "<div style='border:none;border-top:solid #E1E1E1 1.0pt;padding:3.0pt 0cm 0cm 0cm'>" 'text to check when email is correctly compiled and has got the line that divide the messages
textcheckalt = "-----Messaggio originale-----" 'text to check if email is sent from phone or if not correctly compiled
textcheckeng = "-----Original Message-----" 'text to check if email is sent from phone or if not correctly compiled and is in english
numero = InStr(testo, textcheck)
numeroalt = InStr(testo, textcheckalt)
numeroeng = InStr(testo, textcheckeng)
range = Left(testo, numero)
rangealt = Left(testo, numeroalt)
rangeeng = Left(testo, numeroeng)
'variables to find the possible attachments
Dim aFound As Boolean
Dim a As Object
Set miallegati = mails.Attachments
aFound = False
'if cicle that check the presence of attachment and if yes populates the variable aFound with True value
If TypeOf item Is Outlook.MailItem Then
For Each a In item.Attachments
On Error Resume Next ' to avoid the error thrown when no items within attachments have this property
If a.PropertyAccessor.GetProperty(PR_ATTACHMENT_HIDDEN) = False Then
If Len(a.PropertyAccessor.GetProperty(PR_ATTACH_CONTENT_ID)) > 0 And InStr(Application.ActiveInspector.CurrentItem.HTMLBody, a.PropertyAccessor.GetProperty(PR_ATTACH_CONTENT_ID)) Then
Else
aFound = True
Exit For
End If
End If
On Error GoTo 0
Next a
'if cicle that checks the desired portion of text for the word "allegato" or "allegati"
If aFound = False And InStr(LCase(range), "allegato") > 0 Then
GoTo singular
ElseIf aFound = False And InStr(LCase(range), "allegati") > 0 Then
GoTo plural
ElseIf aFound = False And InStr(LCase(rangealt), "allegato") > 0 Then
GoTo singular
ElseIf aFound = False And InStr(LCase(rangeeng), "allegato") > 0 Then
GoTo singular
ElseIf aFound = False And InStr(LCase(rangealt), "allegati") > 0 Then
GoTo plural
ElseIf aFound = False And InStr(LCase(rangeeng), "allegati") > 0 Then
GoTo plural
ElseIf aFound = False And InStr(LCase(range), "allegato") = 0 And range <> "" Then
GoTo fine
ElseIf aFound = False And InStr(LCase(range), "allegati") = 0 And range <> "" Then
GoTo fine
ElseIf aFound = False And InStr(LCase(rangealt), "allegato") = 0 And range <> "" Then
GoTo fine
ElseIf aFound = False And InStr(LCase(rangealt), "allegati") = 0 And range <> "" Then
GoTo fine
ElseIf aFound = False And InStr(LCase(rangeeng), "allegato") = 0 And range <> "" Then
GoTo fine
ElseIf aFound = False And InStr(LCase(rangeeng), "allegati") = 0 And range <> "" Then
GoTo fine
ElseIf aFound = False And InStr(LCase(mails.HTMLBody), "allegato") > 0 Then
GoTo singular
ElseIf aFound = False And InStr(LCase(mails.HTMLBody), "allegati") > 0 Then
GoTo plural
Else
GoTo fine
'lines that set the variable msgboxvar for plural or singluar word in msgbox
plural: msgboxvar = "allegati"
GoTo msg
singular: msgboxvar = "allegato"
GoTo msg
'this last if checks for the whole text
LastIf: If aFound = False And InStr(LowerCase, "allegato") > 0 Or InStr(LowerCase, "allegati") > 0 Then
msgboxvar = "allegato"
'msg that signals the absence of attachments and asks if mail has to be sent, if answer is no, a word application makes it possible to attach chosen files to the email
msg: If MsgBox("Nell'email hai scritto '" & msgboxvar & "' ma non ne รจ presente alcuno, vuoi inviarla lo stesso?", vbYesNo) = vbNo Then
' user clicked cancel
Cancel = True
End If
End If
End If
End If
fine: End Sub
I have left the other sub that check for the attachment just to let you see if there are any conflicts.
First, the MailItem.PropertyChange event is fired when an explicit built-in property (for example, Subject) of an instance of the parent object is changed. The name of the property that was changed is passed as a parameter. So, you may check the property changed and process only changes in the Subject line.
Second, in the event handlers like Reply, Forward and etc. you trigger the event by calling corresponding methods in the code:
Private Sub oItem_Reply(ByVal Response As Object, Cancel As Boolean)
'...
Set exception = oItem.Reply
End Sub
Instead, you need to use the object passed as a parameter:
ByVal Response As Object
Third, in the NewInspector event handler the following code is used to get the inspector window:
Private Sub m_Inspectors_NewInspector(ByVal Inspector As Outlook.Inspector)
'...
Set m_Inspector = Inspector
End Sub
Be aware, a new inspector instance is passed as a parameter to the event handler.
You may find the Implement a wrapper for inspectors and track item-level events in each inspector article helpful.
I found this code online. It is supposed to auto populate my subject line with any attachments I provide. The code does not run.
I don't receive an error or anything that suggests its even going through the code.
Public WithEvents olInspectors As Outlook.Inspectors
Public WithEvents olMail As Outlook.MailItem
Private Sub Initialize_handlers()
Set olInspectors = Application.Inspectors
End Sub
Private Sub olInspectors_NewInspector(ByVal Inspector As Inspector)
Dim olItem As Object
Set olItem = Inspector.CurrentItem
If TypeName(olItem) = "MailItem" Then Set olMail = olItem
End Sub
Private Sub olMail_AttachmentAdd(ByVal Attachment As Attachment)
MsgBox "This is a test."
If olMail.Subject = "" Then
'If you don't want the prompt,
'Just delete the Msgbox line and its corresponding "End if".
If MsgBox("Do you want to use the attachment name as the subject", vbYesNo) = vbYes Then
olMail.Subject = Attachment.DisplayName
End If
End If
End Sub
There is nothing wrong with your code, you simply need to Initialize the Inspectors
Click on Sub Initialize_handlers() and press F5
Private Sub Initialize_handlers()
Set olInspectors = Application.Inspectors
End Sub
Or just use Application.Startup Event (Outlook), Save it and restart Outlook then it should work
Example
Public WithEvents olInspectors As Outlook.Inspectors
Public WithEvents olMail As Outlook.mailitem
Private Sub Application_Startup()
Set olInspectors = Application.Inspectors
End Sub
Private Sub Initialize_handlers()
Set olInspectors = Application.Inspectors
End Sub
Private Sub olInspectors_NewInspector(ByVal Inspector As Inspector)
Dim olItem As Object
Set olItem = Inspector.CurrentItem
If TypeName(olItem) = "MailItem" Then Set olMail = olItem
End Sub
Private Sub olMail_AttachmentAdd(ByVal Attachment As Attachment)
MsgBox "This is a test."
If olMail.Subject = "" Then
'If you don't want the prompt,
'Just delete the Msgbox line and its corresponding "End if".
If MsgBox("Do you want to use the attachment name as the subject", _
vbYesNo) = vbYes Then
olMail.Subject = Attachment.DisplayName
End If
End If
End Sub
I want the code below to run on Open of an .oft file/email.
I am getting a Runtime 91 error.
Public WithEvents myItem As Outlook.MailItem
Public EventsDisable As Boolean
Private Sub Application_ItemLoad(ByVal Item As Object)
If EventsDisable = True Then Exit Sub
Set myItem = Item
End Sub
Private Sub myItem_Open(Cancel As Boolean)
EventsDisable = True
Dim Insp As Inspector
Dim obj As Object
Set Insp = Application.ActiveInspector
Set obj = Insp.CurrentItem
obj.HTMLBody = Replace(obj.HTMLBody, "XXXX", Format(Now + 14, "MMMM dd, yyyy"))
Set obj = Nothing
Set Insp = Nothing
EventsDisable = False
End Sub
If I run the last Sub myItem_Open as a public sub manually it works perfectly.
You need to use the Inspectors.NewInspector event instead (Inspectors can be retrieved from Application.Inspectors).
UPDATE. Off the top my head
Public WithEvents myInspectors As Outlook.Inspectors
Private Sub Application_Startup()
set myInspectors = Application.Inspectors
MsgBox "Application_Startup"
End Sub
Private Sub myInspectors_NewInspector(ByVal insp As Inspector)
MsgBox "myInspectors_NewInspector"
Set obj = Insp.CurrentItem
obj.HTMLBody = Replace(obj.HTMLBody, "XXXX", Format(Now + 14, "MMMM dd, yyyy"))
Set obj = Nothing
End Sub
i have 2 menu buttons that i want added in outlook menu after help menu. i made the code to add the buttons but it just adds 2 more buttons every time i reopen outlook even if the 2 menu buttons are there already . Any help is welcomed.
Function ToolBarExists(strName As String) As Boolean
Dim tlbar As commandBar
For Each tlbar In ActiveExplorer.CommandBars
If tlbar.Name = strName Then
ToolBarExists = True
Exit For
End If
Next tlbar
End Function
Sub TBarExistsbutton1()
If ToolBarExists("button1") Then
If ActiveExplorer.CommandBars("button1").Visible = True Then
ActiveExplorer.CommandBars("button1").Visible = False
Else
ActiveExplorer.CommandBars("button1").Visible = True
End If
Else
Call a123
End If
End Sub
Sub TBarExistsbutton2()
If ToolBarExists("button2") Then
If ActiveExplorer.CommandBars("button2").Visible = True Then
ActiveExplorer.CommandBars("button2").Visible = False
Else
ActiveExplorer.CommandBars("button2").Visible = True
End If
Else
Call a1234
End If
End Sub
Sub a123()
Dim outl As Object
Dim msg As Object
Set outl = CreateObject("Outlook.Application")
Dim objBar As Office.commandBar
Dim objButton As Office.commandBarButton
Set objBar = Application.ActiveWindow.CommandBars("Menu Bar")
Set objButton = objBar.Controls.Add(msoControlButton)
With objButton
.caption = "button1"
.onAction = "macro1"
.faceId = 487
.Style = msoButtonIconAndCaption
End With
End Sub
Sub a1234()
Dim outl As Object
Dim msg As Object
Set outl = CreateObject("Outlook.Application")
Dim objBar As Office.commandBar
Dim objButton As Office.commandBarButton
Set objBar = Application.ActiveWindow.CommandBars("Menu Bar")
Set objButton = objBar.Controls.Add(msoControlButton)
With objButton
.caption = "button2"
.onAction = "macro2"
.faceId = 487
.Style = msoButtonIconAndCaption
End With
End Sub
In Outlook 2010. If Visible works for you incorporate it in a similar manner.
Option Explicit
Sub TBarExistsbutton1()
Dim cbControlCount As Long
Dim button1Found As Boolean
Dim j As Long
If ToolBarExists("Menu Bar") Then
cbControlCount = ActiveWindow.CommandBars("Menu Bar").Controls.count
Debug.Print " There are " & cbControlCount & " controls in " & "Menu Bar"
For j = 1 To cbControlCount
Debug.Print ActiveWindow.CommandBars("Menu Bar").Controls(j).Caption
If ActiveWindow.CommandBars("Menu Bar").Controls(j).Caption = "button1" Then
button1Found = True
Exit For
End If
Next j
If button1Found = False Then a123
Else
Debug.Print "Menu Bar does not exist."
a123
End If
End Sub
With a Context Menu option, managed in a class called "Tickets", I want to call a method called "TEmail" defined in the same class that manages the menu event.
I tried to define many different types of .OnAction property using instance, class, name, etc. but without success. I cannot run "TEmail" code.
Public WithEvents AppEvent As Outlook.Application
Private Sub AppEvent_ItemContextMenuDisplay(ByVal CommandBar As Office.CommandBar, ByVal Selection As Selection)
Dim objButton As Office.CommandBarButton
On Error GoTo ErrRoutine
Set objButton = CommandBar.Controls.Add(msoControlButton)
With objButton
.BeginGroup = True
.Caption = "Test-TEmail"
.FaceID = 1000
.Tag = "T-Email"
.OnAction = "TEmail"
End With
EndRoutine:
Exit Sub
ErrRoutine:
MsgBox Err.Number & " - " & Err.Description, vbOKOnly Or vbCritical, "Application_ItemContextMenuDisplay"
GoTo EndRoutine
End Sub
Public Sub TEmail()
... my code ...
End Sub
The solution is to create an event handler.
Public WithEvents AppEvent As Outlook.Application
Public WithEvents myControl As CommandBarButton
Private Sub AppEvent_ItemContextMenuDisplay(ByVal CommandBar As Office.CommandBar, _
ByVal Selection As Selection)
Dim objButton As Office.CommandBarButton
Dim oExp As Outlook.Explorer
Set oExp = Outlook.ActiveExplorer
On Error GoTo ErrRoutine
Set myControl = CommandBar.FindControl(, , "OpenForm")
If myControl Is Nothing Then
Set myControl = CommandBar.Controls.Add(msoControlButton)
With myControl
.Caption = "TEmail"
.FaceID = 59
.Style = msoButtonIconAndCaption
.Tag = "TEmail"
.Visible = True
End With
End If
' ...
End Sub
Private Sub myControl_Click(ByVal Ctrl As Office.CommandBarButton, _
CancelDefault As Boolean)
TEmail
End Sub
Public Sub TEmail()
' ...
End Sub