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 send emails that I don't get any reply to. I need to keep track of this to send a follow-up email.
I want a macro that does the following:
Before sending an email, I set a reminder with the follow-up flag. This way, I can choose a custom time to follow up on this specific email.
If the sent email is marked with a follow-up flag it is automatically marked with category "blue".
If I get a reply before the timer I set, the task is cleared and the blue category is cleared.
If I don't get a reply before the timer runs out, the category changes to red and I get a notification reminder from Outlook.
This way I can sort my "sent" folder to the two categories to see what emails need follow up. Moreover, I get a reminder each time people don't respond in time.
The below code clears the follow-up flag if I received a reply within the set time.
I don't know how to assign a category to the sent item and to clear it.
Public WithEvents objInboxItems As Outlook.Items
Private Sub Application_Startup()
Set objInboxItems = Application.Session.GetDefaultFolder(olFolderInbox).Items
End Sub
'If receive the reply, clear the flag and remove the reminder
Private Sub objInboxItems_ItemAdd(ByVal Item As Object)
Dim objSentItems As Outlook.Items
Dim objVariant As Variant
Dim i As Long
Dim strSubject As String
Dim dSendTime As String
Set objSentItems = Outlook.Application.Session.GetDefaultFolder(olFolderSentMail).Items
If Item.Class = olMail Then
For i = 1 To objSentItems.Count
If objSentItems.Item(i).Class = olMail Then
Set objVariant = objSentItems.Item(i)
strSubject = LCase(objVariant.Subject)
dSendTime = objVariant.SentOn
If LCase(Item.Subject) = "re: " & strSubject Or InStr(LCase(Item.Subject), strSubject) > 0 Then
If Item.SentOn > dSendTime Then
With objVariant
.ClearTaskFlag
.ReminderSet = False
.Save
End With
End If
End If
End If
Next i
End If
End Sub
This is a class I used some time ago. Maybe you can grab some ideas
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "ThisOutlookSession"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Option Explicit
'Categorize Sent Items
'Place in ThisOutlookSession
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
On Error Resume Next
Dim insp As Outlook.Inspector
Dim stringCatReference() As Variant
stringCatReference = Array("CAM-", "CGI-", "COS-", "CON-", "HEXA-", "ITH-", "KALL-")
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 Sub
Else
Set insp = Application.ActiveInspector
If insp.CurrentItem.Class = olMail Then
Else
Exit Sub
End If
End If
If TypeOf Item Is Outlook.MailItem And IsInArray(Item.Subject, stringCatReference) = 0 Then
Set Item = Application.ActiveInspector.CurrentItem
Item.ShowCategoriesDialog
Item.Save
End If
End Sub
Function IsInArray(stringToBeFound As String, arr As Variant) As Boolean
Dim xInt As Integer
For xInt = 0 To UBound(arr)
IsInArray = InStr(stringToBeFound, arr(xInt)) > 0
If IsInArray = True Then Exit For
Next xInt
End Function
I want Outlook to perform an action on email from a certain email address.
In the ThisOutlookSession I have:
Private Sub Application_NewMail() 'This triggers when a new email is recieved
Call TestSub
End Sub
In a module I have:
Public Sub TestSub()
Dim Msg As Outlook.MailItem
Dim FromEmailAddress As String
FromEmailAddress = Msg.SenderEmailAddress
If FromEmailAddress = "Test#example.com" Then
MsgBox ("Hello")
End If
End Sub
I get
Run-time error '91':
Object variable or With block variable not set
on FromEmailAddress = Msg.SenderEmailAddress.
I have tried many variations on my code and exhausted the powers of Google.
Its also good to check if the Sender is SMTP or GetExchangeUser
Dim Email_Address As String
If Item.SenderEmailType = "SMTP" Then
Email_Address = Item.SenderEmailAddress
Else
If Item.SenderEmailType = "EX" Then
Email_Address = Item.Sender.GetExchangeUser.PrimarySmtpAddress
End If
End If
You can use the following code:
Dim oInbox As Outlook.Folder
Dim oItem As Object
Dim Msg As MailItem
Set oInbox = ActiveExplorer.Session.DefaultStore.GetRootFolder().Folders("Inbox")
For Each oItem In oInbox.Items
If TypeOf oItem Is MailItem Then
Set Msg = oItem
FromEmailAddress = Msg.SenderEmailAddress
Else
Debug.Print "Skipping " & TypeName(oItem)
End If
Next
I would like to find a string in an email, and delete all text before it. It is much the opposite of this:
Option Explicit
Sub DeleteAfterText()
' Deletes all text after endStr.
Dim currMail As mailitem
Dim msgStr As String
Dim endStr As String
Dim endStrStart As Long
Dim endStrLen As Long
Set currMail = ActiveInspector.CurrentItem
endStr = "Text"
endStrLen = Len(endStr)
msgStr = currMail.HTMLBody
endStrStart = InStr(msgStr, endStr)
If endStrStart > 0 Then
currMail.HTMLBody = Left(msgStr, endStrStart + endStrLen)
End If
End Sub
Example taken from this stack overflow page: Find Text in an email and delete all text after this in Outlook 2010
Thanks for your help.
The key line would be something like this:
currMail.body = Right(msgStr, Len(msgStr) - (endStrStart - 1))
Adding a bit more to the original code:
Option Explicit
Sub DeleteBeforeText_not_olFormatHTML()
Dim currMail As mailItem
Dim msgStr As String
Dim endStr As String
Dim endStrStart As Long
Dim endStrLen As Long
Set currMail = ActiveInspector.currentItem
endStr = "Text"
endStrLen = Len(endStr)
If currMail.BodyFormat = olFormatHTML Then
currMail.BodyFormat = olFormatRichText
End If
msgStr = currMail.body
endStrStart = InStr(msgStr, endStr)
If endStrStart > 0 Then
currMail.body = Right(msgStr, Len(msgStr) - (endStrStart - 1))
End If
End Sub
I have VBA code that auto forwards all emails to an external account. I can't get the macro to show up in the Macro menu when I click F5 to run it.
Sub AutoForwardAllSentItemsss(Item As Outlook.MailItem)
Dim strMsg As String
Dim autoFwd As Outlook.MailItem
Set autoFwd = Item.forward
autoFwd.Recipients.Add "test#test.com"
autoFwd.Send
Set autoFwd = Nothing
End Sub
Set up a rule with a run a script option. You will see it when you choose a script.
If that is not what you are asking then.
Sub ManuForwardAllSelectedItemsss_V1()
Dim Item As Object
Dim iSend As Long
For iSend = 1 To ActiveExplorer.Selection.Count
If TypeOf Item Is mailItem Then
Set Item = ActiveExplorer.Selection(iSend)
AutoForwardAllSentItemsss Item
End If
Next
Set Item = Nothing
MsgBox "Done"
End Sub
or
Sub ManuForwardAllSelectedItemsss_V2()
Dim manuFwd As Outlook.mailItem
Dim Item As mailItem
Dim iSend As Long
For iSend = 1 To ActiveExplorer.Selection.Count
Set Item = ActiveExplorer.Selection(iSend)
If TypeOf Item Is mailItem Then
Set manuFwd = Item.Forward
manuFwd.Recipients.Add "test#test.com"
manuFwd.Send
End If
Next
Set Item = Nothing
Set manuFwd = Nothing
End Sub