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 am trying to run a if statement to send an email if the sub has run and is successful.
The current code I am trying is
Private Sub SendButton_Click()
Call Populate
If Populate = True Then
Application.ScreenUpdating = False
Set OL = CreateObject("Outlook.Application")
Set EmailItem = OL.CreateItem(olMailItem)
Set Doc = ActiveDocument
Doc.Save
With EmailItem
.Subject = "New ePRF Available"
.Body = "I have completed a new e-PRF"
.To = ""
.Importance = olImportanceNormal
.attachments.Add Doc.FullName
.Send
End With
Application.ScreenUpdating = True
Set Doc = Nothing
Set OL = Nothing
Set EmailItem = Nothing
Else
Call Populate
End If
End Sub
This is something I have never really done before so am very confused! Any help would be grateful!
Thanks
Make Populate a function and have it return a boolean value, then check that value in SendButton_Click
I made a nonsense populate to show the general idea.
Option Explicit
Private Sub SendButton_Click()
If populate() Then 'Test the return
Application.ScreenUpdating = False
Set OL = CreateObject("Outlook.Application")
Set EmailItem = OL.CreateItem(olMailItem)
Set Doc = ActiveDocument
Doc.Save
With EmailItem
.Subject = "New ePRF Available"
.Body = "I have completed a new e-PRF"
.To = ""
.Importance = olImportanceNormal
.attachments.Add Doc.FullName
.Send
End With
Application.ScreenUpdating = True
Set Doc = Nothing
Set OL = Nothing
Set EmailItem = Nothing
Else
Call populate 'This is probably not what you actually want, but hard to tell without seeing populate
End If
End Sub
Function populate() As Boolean 'specify the return type
Dim returnval As Boolean
Dim x As Boolean
Dim y As Boolean
returnval = True 'Start with true, if anything is false below flip the value
x = True
y = False
'just showing the flow, you would be checking your userform values here
If Not x Then
returnval = False
ElseIf Not y Then
returnval = False
End If
populate = returnval 'return the value
End Function
The following code allows me to import .msg files into excel.
I was wondering if it is possible to create a macro in outlook that sends messages into an excel file rather than importing them.
The code I used for importing .msg files is as follows:
Sub IMPORTMSG()
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayAlerts = False
Dim i As Long
Dim inPath As String
Dim thisFile As String
' Dim Msg As MailItem
Dim ws As Worksheet
' Dim myOlApp As Outlook.Application
' Dim MyItem As Outlook.MailItem
Set myOlApp = CreateObject("Outlook.Application")
Set ws = ThisWorkbook.Worksheets("A")
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
If .Show = False Then
Exit Sub
End If
On Error Resume Next
inPath = .SelectedItems(1) & "\"
End With
thisFile = Dir(inPath & "*.msg")
i = 4
Do While thisFile <> ""
Set MyItem = myOlApp.CreateItemFromTemplate(inPath & thisFile)
If MyItem.Subject = "testheader" Then
ws.Cells(i, 1) = MyItem.Body
i = i + 1
End If
thisFile = Dir()
Loop
Set MyItem = Nothing
Set myOlApp = Nothing
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.DisplayAlerts = True
End Sub
You can create a COM addin for Outlook and have it run the code above. Or you can use Application.ActiveExplorer.Selection collection in Outlook to loop through the selected messages in Outlook instead of processing standalone MSG files.
You can develop an Outlook VBA macro where you can automate Excel and set Excel cell values. See How to automate Microsoft Excel from Visual Basic for more information.
Also you may find the Getting Started with VBA in Outlook 2010 article helpful.
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
I'm trying to import multiple .msg files into an Excel Sheet (msg body per row)but so far the only reference found was this here, so my code so far let you:
Select the folder path (where the .msg are located)
Loop through all the .msg files
But I'm unable to figure out how to achieve my objective. Thanks in advance for the response.
Code:
Sub importMsg()
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayAlerts = False
Dim i As Long
Dim inPath As String
Dim thisFile As String
Dim msg As MailItem
Dim OlApp As Object
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Main")
Set OlApp = CreateObject("Outlook.Application")
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
If .Show = False Then
Exit Sub
End If
On Error Resume Next
inPath = .SelectedItems(1) & "\"
End With
i = 1
thisFile = Dir(inPath & "*.msg")
Do While thisFile <> ""
i = i + 1
Dim MyItem As Outlook.MailItem
Set MyItem = Application.CreateItemFromTemplate(thisFile)
'Set MyItem = Application.OpenSharedItem(thisFile)
ws.Cells(i, 1).Value = MyItem.Body
'MyItem.Body
'MyItem.Subject
'MyItem.Display
thisFile = Dir
Loop
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.DisplayAlerts = True
End Sub
I found the error in the Do While Loop the variable thisFile wasn't maintaining the full path reference so I added the concatenation again and worked, code below:
Sub importMsg()
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayAlerts = False
Dim i As Long
Dim inPath As String
Dim thisFile As String
Dim Msg As MailItem
Dim ws As Worksheet
Dim myOlApp As Outlook.Application
Dim MyItem As Outlook.MailItem
Set myOlApp = CreateObject("Outlook.Application")
Set ws = ThisWorkbook.Worksheets("Main")
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
If .Show = False Then
Exit Sub
End If
On Error Resume Next
inPath = .SelectedItems(1) & "\"
End With
thisFile = Dir(inPath & "*.msg")
i = 4
Do While thisFile <> ""
Set MyItem = myOlApp.CreateItemFromTemplate(inPath & thisFile)
ws.Cells(i, 1) = MyItem.Body
i = i + 1
thisFile = Dir()
Loop
Set MyItem = Nothing
Set myOlApp = Nothing
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.DisplayAlerts = True
End Sub