Because I am unable to set a rule in Outlook to run a VBA script, I tried to create a workaround.
When a certain daily email comes in with an attachment, I want to download the excel attachment and open an excel workbook and run a vba script in that excel to update information, update charts, save the file, and send the file as an email.
I am having trouble with the integration. Ideally I would like to have Outlook automatically download an excel attachment when an email comes from a specific sender with a specific subject line, and then run excel vba script.
What I am currently doing is running a rule in Outlook that files the email in a sub-folder and having excel vba connect to outlook, find the email, download the file, and run code from excel, all when an email with "Test" in the subject line shows up in the default inbox.
I know this is long winded, but there has to be a better solution! Please help Here is my code so far:
Outlook:
Private WithEvents Items As Outlook.Items
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
Dim xlApp As Object
Dim oxl As Excel.Application
Dim owb As Excel.Workbook
Dim wsheet As Excel.Worksheet
Dim asd As Object
Dim ExApp As Excel.Application
Dim ExWbk As Workbook
Dim myDestFolder As Outlook.Folder
If TypeName(item) = "MailItem" Then
Set Msg = item
If Msg.Subject = "Test" Then
Set ExApp = New Excel.Application
Set ExWbk = ExApp.Workbooks.Open("excel file i want to open and run script")
ExApp.Visible = False
ExWbk.Application.Run "Module1.fromnew"
Dim myNameSpace As Outlook.NameSpace
Dim myInbox As Outlook.Folder
Set myNameSpace = Application.GetNamespace("MAPI")
Set myInbox = myNameSpace.GetDefaultFolder(olFolderInbox)
Set myItems = myInbox.Items
Set myDestFolder = myInbox.Folders("Test")
**Msg.Move myDestFolder**
'Not working
End If
End If
ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ProgramExit
End Sub
Excel:
Sub fromnew()
Dim myd, myy As String
Dim newfile As Workbook
Dim prod As Workbook
Call Test
'Goes into Outlook and finds the email in an Outlook subfolder and downloads 'the excel attachment. I want to remove this and have outlook automatically 'download the attachment so I don't have to call test()
myd = Format(Date, "yyyymmdd")
myy = Format(Date, "yyyy")
Set prod = ActiveWorkbook
Set newfile = Workbooks.Open("xyz\ds\" & myy & "\blahblahblah" & myd)
newfile.Sheets(1).Range("A1:AA7000").Copy Destination:=prod.Sheets("Data").Range("A1")
prod.Sheets("Data").Range("A2") = 1
newfile.Close
prod.Activate
prod.SaveAs ("here is a file name")
Dim OutApp As Object
Dim OutMail As Object
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = "email#xyz.com"
.CC = ""
.BCC = ""
.Subject = "here are your things"
.Body = "Do you like beer?"
.Attachments.Add ("here is a file name")
.Send
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
prod.Close
End Sub
you did not say why you are unable to set a rule in Outlook
you may have to change a key in windows registry to enable the execution of vba in a rule
do a web search for "EnableUnsafeClientMailRules" and read info from any microsoft.com page that comes up in the search
here is a link that is current today, but may change in future
it refers to outlook2013 and outlook2016
https://support.microsoft.com/en-us/help/3191893/how-to-control-the-rule-actions-to-start-an-application-or-run-a-macro
Related
The macro this comes from starts in Outlook when a message is received with a specific subject. Excel does some calculations to the report and then I need it to send an e-mail to someone else. I have been able to get it to work completely if I start the macro manually from excel but when it starts automatically I get an error when trying to create the e-mail # "Set OutlookMail".
EDIT: "Run-time error '91': Object variable or With block variable not set" is the error I receive at "Set OutlookMail = OutlookApp.CreateItem(0)"
XL_hh_mck_weekly is the code from Outlook that triggers the excel macro hh_mck_weekly. There are several steps between but those do not involve outlook.
This is the code being used:
Sub XL_hh_mck_weekly()
Dim Item As Outlook.MailItem
Dim olOutmail As Outlook.MailItem
If xlApp Is Nothing Then Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = True
With CreateObject("Excel.Application")
.Workbooks.Open (filepath & "PERSONAL.xlsb")
.Workbooks.Open (filepath & "hhweekly.csv")
.Visible = False
' Ensure Autocalculation is on
.Calculation = -4105 ' xlCalculationAutomatic
.DisplayAlerts = False
.Run "'PERSONAL.xlsb'!hh_mck_weekly"
' Wait until calculation is done
Do Until .CalculationState = 0 ' xlDone
DoEvents
Loop
End With
Sub hh_mck_weekly(nm As String)
Dim OutlookApp As Outlook.Application
Dim OutlookMail As Object
Dim OutlookMail2 As Object
If OutlookApp Is Nothing Then Set OutlookApp = CreateObject("Outlook.Application")
Set OutlookMail = OutlookApp.CreateItem(0)
Set OutlookMail2 = OutlookApp.CreateItem(0)
' Open Need Category
If IsOpen("NeedCategory.xls") = True Then
' Get category from Mckesson
With OutlookMail
.To = address
.Subject = "Category"
.Body = "Byron, I need the category for these items. Thanks"
.Attachments.Add (filepath & "NeedCategory.xls")
.Display
.Send
End With
End If
With OutlookMail2
.To = address
.Subject = "Weekly Mckesson Report"
.Body = "Thanks"
.Attachments.Add (filepath & nm)
.Display
End With
Set OutlookMail = Nothing
Set OutlookApp = Nothing
End Sub
The code in the question does not appear to be the code in use. There is a parameter required in Sub hh_mck_weekly(nm As String).
This demonstrates how to create a mailitem in Excel code called from Outlook.
Code for Outlook
Option Explicit ' Consider this mandatory
' Tools | Options | Editor tab
' Require Variable Declaration
' If desperate declare as Variant
Sub createMailitem_InExcel()
' code for Outlook
Dim xlApp As Excel.Application
Dim filePath As String
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
On Error GoTo 0
If xlApp Is Nothing Then Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = True
With xlApp
' adjust as needed
filePath = "C:\Users\ -userid- \AppData\Roaming\Microsoft\Excel\XLSTART\"
.Workbooks.Open (filePath & "PERSONAL.xlsb")
.Run "'PERSONAL.xlsb'!test"
End With
End Sub
Code for PERSONAL.xlsb
Sub test()
' code for PERSONAL.xlsb
Dim OutlookApp As Outlook.Application
Dim OutlookMail As Outlook.MailItem
' No need to verify if already open. There can only be one Outlook instance.
Set OutlookApp = CreateObject("Outlook.Application")
Set OutlookMail = OutlookApp.CreateItem(0)
OutlookMail.Display
End Sub
I have found the code below from here https://stackoverflow.com/a/49207287/4539709
Option Explicit
Public Sub Example()
' add ref - tool -> references - > Microsoft Outlook XX.X Object Library
Dim olApp As Outlook.Application
Set olApp = New Outlook.Application
Dim Email As Outlook.MailItem
Set Email = olApp.CreateItem(0)
' add ref - tool -> references - > Microsoft Word XX.X Object Library
Dim wdDoc As Word.Document '<=========
Set wdDoc = Email.GetInspector.WordEditor
Dim Sht As Excel.Worksheet
Set Sht = ThisWorkbook.Worksheets("Sheet1")
Dim rng As Range
Set rng = Sht.Range("A4:H16").SpecialCells(xlCellTypeVisible)
rng.Copy
With Email
.To = Sht.Range("C1")
.Subject = Sht.Range("B1")
.Display
wdDoc.Range.PasteAndFormat Type:=wdFormatOriginalFormatting
End With
End Sub
I have come across an issue with the code in that after you send an email the rows remain selected as per attached. Is there anyway to clear this
Add the following line at the end Application.CutCopyMode = False
With Email
.To = Sht.Range("C1")
.Subject = Sht.Range("B1")
.Display
wdDoc.Range.PasteAndFormat Type:=wdFormatOriginalFormatting
End With
Application.CutCopyMode = False '<---
End Sub
I created a program for myself and a few of my colleagues. One of the functions of my program runs a macro that grabs data from the Excel sheet and opens a populated email in Outlook.
In order to run this macro you need to add the Object Library "Microsoft Outlook 16.0 Object Library".
Is there any way to do this automatically, so that all of my colleagues can run this macro?
Here's the code for my email generator.
' -- Drafts an email in Outlook -- '
Public Sub emailDraft()
Dim objOutlook As Outlook.Application
Dim objMail As Outlook.MailItem
Dim masterWS As Worksheet
Dim masterWB As Workbook
Dim counter As Long
Set objOutlook = Outlook.Application
Set objMail = objOutlook.CreateItem(olMailItem)
Set masterWB = Workbooks("Master.xlsm")
Set masterWS = masterWB.Worksheets("MASTER SHEET")
objMail.To = masterWS.Range("F6").Value
objMail.CC = "test#email.com"
objMail.Subject = masterWS.Range("F7").Value
objMail.Body = masterWS.Range("F8").Value
objMail.Display
End Sub
Thank you #Warcupine for your insight.
I was able to solve this by using late binding. My updated code is below.
' -- Drafts an email in Outlook -- '
Public Sub emailDraft()
Dim objOutlook As Object 'Outlook.Application
Dim objMail As Object 'Outlook.MailItem
Dim masterWS As Worksheet
Dim masterWB As Workbook
Dim counter As Long
Set objOutlook = CreateObject("Outlook.Application")
Set objMail = objOutlook.CreateItem(olMailItem)
'objOutlook.CreateItem (olMailItem)
Set wb = ThisWorkbook
Set wsMAST = wb.Worksheets("MASTER")
objMail.To = wsMAST.Range("K2").Value
objMail.CC = "test#email.com"
objMail.Subject = wsMAST.Range("k3").Value
objMail.Body = wsMAST.Range("k4").Value
objMail.Display
End Sub
I am creating emails from Excel via the VBA Outlook.Application Reference. Each email is populated with data from my excel sheet and then placed into the To/CC/BCC/Subject/Body fields.
Now, when running this code in Office 2010 it works without a hitch, but in Office 2013 the variables containing the To/CC/BCC/etc. data does not show up in the actual email when displayed.
Did this reference change in Office 2013?
Sub MailSheet()
Dim OutApp As Object
Dim outMail As Object
Dim rng As Range
' set required variables
Set Sourcewb = ActiveWorkbook
Set Property = ActiveWorkbook.Sheets("Settings").Range("B4")
Set Holidex = ActiveWorkbook.Sheets("Settings").Range("B5")
Set SendTo = ActiveWorkbook.Sheets("Settings").Range("B29")
Set SendCC = ActiveWorkbook.Sheets("Settings").Range("B30")
Set rng = Sheets("Mail").Range("A1:F80")
' set email variables
Set OutApp = CreateObject("Outlook.Application")
Set outMail = OutApp.CreateItem(0)
' some code
' get ready to mail
With outMail
.To = SendTo
.ReplyRecipients.Add ""
.CC = SendCC
.BCC = ""
.Subject = Holidex & " - Daily Email"
.HTMLBody = RangetoHTML(rng)
' display email before sending
.Display '.Send or use .Display
End With
' some code
' Clean up
Set outMail = Nothing
Set OutApp = Nothing
end Sub
Rather than creating an Outlook object, try referencing the outlook library (Tools -> References and then select Microsoft Outlook xx.x Object Library). You can then reference it as below:
Sub SendAnEmail()
Dim oOlApp As Outlook.Application: Set oOlApp = Outlook.Application
Dim oMailItem As Outlook.MailItem: Set oMailItem = oOlApp.CreateItem(olMailItem)
oMailItem.To = "myemail#test.com"
oMailItem.CC = ""
oMailItem.BCC = "myemail#test.com"
oMailItem.Subject = Sheet1.Cells(15, "D")
oMailItem.HTMLBody = "Again .. testing"
oMailItem.Display
Set oMailItem = Nothing
Set oOlApp = Nothing
End Sub
You can either add this code in your sub or call this Sub from your Sub with parameters
Not sure I can help you directly, but I do have some code I found online which I know for a fact works with Outlook 2016, will share it on here in case it helps:
Sub OutlookMail_1()
'Automate Sending Emails from Excel, using Outlook.
'Send text and also contents from the host workbook's worksheet range
' as Mail Body, and add an attachment with the mail.
'Automating using Early Binding: Add a reference to the Outlook Object Library
' in Excel (your host application) by clicking Tools-References in VBE,
' which will enable using Outlook's predefined constants.
'Once this reference is added, a new instance of
' Outlook application can be created by using the New keyword.
'variables declared as a specific object type
' ie. specific to the application which is being automated:
Dim applOL As Outlook.Application
Dim miOL As Outlook.MailItem
Dim recptOL As Outlook.Recipient
Dim ws As Worksheet
Dim name As String
Dim email As String
Dim nominees As Range
Dim number As String
'set worksheet:
Set ws = ThisWorkbook.Sheets("Sheet1")
'Create a new instance of the Outlook application.
' Set the Application object as follows:
Set applOL = New Outlook.Application
'create mail item:
Set miOL = applOL.CreateItem(olMailItem)
'Add mail recipients, either the email id or their name in your address book.
' Invalid ids will result in code error.
Set recptOL = miOL.Recipients.Add("Main recipient email")
recptOL.Type = olTo
Set recptOL = miOL.Recipients.Add("BCC Email")
recptOL.Type = olbcc
Set recptOL = miOL.Recipients.Add("BCC Email")
recptOL.Type = olbcc
Set recptOL = miOL.Recipients.Add("BCC Email")
recptOL.Type = olbcc
'with the mail item:
With miOL
'subject of the mail:
.Subject = "Subject"
'Chr(10) represents line feed/new line, & Chr(13) represents carriage return.
' Send text and also contents from
' the host workbook's worksheet range as Mail Body.
.Body = "BODY OF EMAIL"
'set importance level for the mail:
.Importance = olImportanceHigh
'add an attachment to the mail:
'send the mail:
.Display
End With
'clear the object variables:
Set applOL = Nothing
Set miOL = Nothing
Set recptOL = Nothing
End Sub
Some of the variables I set are redundant because I edited the code slightly to maintain privacy, but let me know if that helps!
If you want to use CC instead of Bcc, then just change the code to:
recptOL.Type = olcc
I'm creating an Outlook email from Excel (Office 2013). I want to paste a range of cells (C3:S52) into the email as a picture.
Below is the code I have so far. Where am I going wrong?
Sub Button193_Click()
'
' Button193_Click Macro
'
'
ActiveWindow.ScrollColumn = 2
ActiveWindow.ScrollColumn = 1
Range("C3:S52").Select
Selection.Copy
End Sub
Sub CreateMail()
Dim objOutlook As Object
Dim objMail As Object
Dim rngTo As Range
Dim rngSubject As Range
Dim rngBody As Range
Dim rngAttach As Range
Set objOutlook = CreateObject("Outlook.Application")
Set objMail = objOutlook.CreateItem(0)
With ActiveSheet
Set rngTo = .Range("E55")
Set rngSubject = .Range("E56")
Set rngBody = .Range("E57")
End With
With objMail
.To = rngTo.Value
.Subject = rngSubject.Value
.Body = rngBody.Value
.Display 'Instead of .Display, you can use .Send to send the email _
or .Save to save a copy in the drafts folder
End With
Set objOutlook = Nothing
Set objMail = Nothing
Set rngTo = Nothing
Set rngSubject = Nothing
Set rngBody = Nothing
Set rngAttach = Nothing
End Sub
Sub Button235_Click()
'
' Button235_Click Macro
'
'
ActiveWindow.ScrollColumn = 2
ActiveWindow.ScrollColumn = 1
Range("A1:M27").Select
Selection.Copy
End Sub
Sub RunThemAll()
Application.Run "Button193_Click"
Application.Run "CreateMail"
End Sub
Here's a worked example, tested in Office 2010:
'Copy range of interest
Dim r As Range
Set r = Range("B2:D5")
r.Copy
'Open a new mail item
Dim outlookApp As Outlook.Application
Set outlookApp = CreateObject("Outlook.Application")
Dim outMail As Outlook.MailItem
Set outMail = outlookApp.CreateItem(olMailItem)
'Get its Word editor
outMail.Display
Dim wordDoc As Word.Document
Set wordDoc = outMail.GetInspector.WordEditor
'To paste as picture
wordDoc.Range.PasteAndFormat wdChartPicture
'To paste as a table
'wordDoc.Range.PasteExcelTable LinkedToExcel:=False, WordFormatting:=False, RTF:=False
Result:
In the code above I used early binding to have access to autocomplete; to use this code you need to set references to the Microsoft Outlook and Microsoft Word object libraries: Tools > References... > set checkmarks like this:
Alternatively, you can forget about the references and use late binding, declaring all the Outlook and Word objects As Object instead of As Outlook.Application and As Word.Document etc.
Apparently you're having trouble implementing the above; the range pastes as a table rather than a picture in your email message. I have no explanation for why that would happen.
An alternative is then to paste as an image in Excel, and then cut and paste that image into your e-mail:
'Copy range of interest
Dim r As Range
Set r = Range("B2:D5")
r.Copy
'Paste as picture in sheet and cut immediately
Dim p As Picture
Set p = ActiveSheet.Pictures.Paste
p.Cut
'Open a new mail item
Dim outlookApp As Outlook.Application
Set outlookApp = CreateObject("Outlook.Application")
Dim outMail As Outlook.MailItem
Set outMail = outlookApp.CreateItem(olMailItem)
'Get its Word editor
outMail.Display
Dim wordDoc As Word.Document
Set wordDoc = outMail.GetInspector.WordEditor
'Paste picture
wordDoc.Range.Paste
As pointed out by WizzleWuzzle, there is also the option of using PasteSpecial instead of PasteAndFormat or Paste...
wordDoc.Range.PasteSpecial , , , , wdPasteBitmap
... but for some reason, the resulting image doesn't render as well. See how the lower table is kind of blurry:
I am providing an alternative solution to the above problem as Outlook.MailItem.GetInspector.WordEditor does not work in some organizational environments.
For security purposes, the HTMLBody, HTMLEditor, Body and WordEditor properties all are subject to address-information security prompts because the body of a message often contains the sender's or other people's e-mail addresses. And, if Group Policy does not permit then these prompts do not come on-screen. In simple words, as a developer, you are bound to change your code, because neither registry changes can be made nor group policy can be modified.
Hence, if your code suddenly stopped working after migrating to Office 365 or for any other reasons, please refer to the code below. Comments have been added for easy understanding and implementation.
If you have administrative rights then try the registry changes given at below link:
https://support.microsoft.com/en-au/help/926512/information-for-administrators-about-e-mail-security-settings-in-outlo
However, as developer, I recommend a code that's rather compatible with all versions of Excel instead of making system changes because system changes will be required on each end user's machine as well.
Code Compatible: Excel 2003, Excel 2007, Excel 2010, Excel 2013, Excel 2016, Office 365
Option Explicit
Sub Create_Email(ByVal strTo As String, ByVal strSubject As String)
Dim rngToPicture As Range
Dim outlookApp As Object
Dim Outmail As Object
Dim strTempFilePath As String
Dim strTempFileName As String
'Name it anything, doesn't matter
strTempFileName = "RangeAsPNG"
'rngToPicture is defined as NAMED RANGE in the workbook, do modify this name before use
Set rngToPicture = Range("rngToPicture")
Set outlookApp = CreateObject("Outlook.Application")
Set Outmail = outlookApp.CreateItem(olMailItem)
'Create an email
With Outmail
.To = strTo
.Subject = strSubject
'Create the range as a PNG file and store it in temp folder
Call createPNG(rngToPicture, strTempFileName)
'Embed the image in Outlook
strTempFilePath = Environ$("temp") & "\" & strTempFileName & ".png"
.Attachments.Add strTempFilePath, olByValue, 0
'Change the HTML below to add Header (Dear John) or signature (Kind Regards) using newline tag (<br />)
.HTMLBody = "<img src='cid:DashboardFile.png' style='border:0'>"
.Display
End With
Set Outmail = Nothing
Set outlookApp = Nothing
Set rngToPicture = Nothing
End Sub
Sub createPNG(ByRef rngToPicture As Range, nameFile As String)
Dim wksName As String
wksName = rngToPicture.Parent.Name
'Delete the existing PNG file of same name, if exists
On Error Resume Next
Kill Environ$("temp") & "\" & nameFile & ".png"
On Error GoTo 0
'Copy the range as picture
rngToPicture.CopyPicture
'Paste the picture in Chart area of same dimensions
With ThisWorkbook.Worksheets(wksName).ChartObjects.Add(rngToPicture.Left, rngToPicture.Top, rngToPicture.Width, rngToPicture.Height)
.Activate
.Chart.Paste
'Export the chart as PNG File to Temp folder
.Chart.Export Environ$("temp") & "\" & nameFile & ".png", "PNG"
End With
Worksheets(wksName).ChartObjects(Worksheets(wksName).ChartObjects.Count).Delete
End Sub