I have created Excel file and want to attach the same in outlook email without saving excel file. I am able to attach the file once it is saved in folder and but I don't want to save it anywhere. Please assist.
Dim wkb As Workbook
Dim wkb1 As Worksheet
Set wkb = Workbooks.Add
Set wkb1 = Worksheets(1)
wkb1.Name = "Training Tracker"
Dim OutApp As Object
Dim OutMail As Object
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = Sheet5.Range("B2").Value
wkb.Activate
.Attachments.Add (ActiveWorkbook)
.Display
End With
You'll need to have a saved copy somewhere to send it. What you can do is save a copy of it to your temp folder. This folder is cleared down by the OS regularly and won't intervene with the users folder (works on windows not mac)
Dim wkb As Workbook
Dim wkb1 As Worksheet
Set wkb = Workbooks.Add
Set wkb1 = Worksheets(1)
wkb1.Name = "Training Tracker"
Dim OutApp As Object
Dim OutMail As Object
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = Sheet5.Range("B2").Value
wkb.Activate
wkb.SaveCopyAs Environ("temp") & "\TempFileName.xls"
.Attachments.Add (Environ("temp") & "\TempFileName.xls")
.Display
End With
Related
I had already code for attaching the excel workbook. I just need code for attaching an email item into the email.. please assist
Try below code (change the sheet name and range as per your requirements)
Sub Mail()
Dim r As Range
Set r = Worksheets("to_Mail").Range("A1:AD69")
r.Copy
Dim OutApp As Object
Dim outMail As Object
Set OutApp = CreateObject("Outlook.Application")
Set outMail = OutApp.CreateItem(0)
On Error Resume Next
With outMail
.HTMLBody = activeMailMessage.HTMLBody
.To = ""
.CC = ""
.BCC = ""
.Subject = "Report Complete"
Dim wordDoc As Word.document
Set wordDoc = outMail.GetInspector.WordEditor
wordDoc.Range.PasteAndFormat wdChartPicture
outMail.send
End With
End Sub
I have a code in Excel that copy a table to a new Email:
Option Explicit
Public Sub TESTEMAIL()
Const olMailItem As Long = 0
Dim StrFile, signature As String
Dim OutApp As Outlook.Application
Dim Outmail As Outlook.MailItem
Set OutApp = CreateObject("Outlook.Application")
Set Outmail = OutApp.CreateItem(olMailItem)
Dim myRecipient As Object
Set OutApp = CreateObject("Outlook.Application")
Set Outmail = OutApp.CreateItem(olMailItem)
Set OutApp = Nothing
Outmail.Display
Dim wordDoc As Word.Document
Set wordDoc = Outmail.GetInspector.WordEditor
Range("A1:E10").Copy
Dim p1 As Picture
Set p1 = ActiveSheet.Pictures.Paste
p1.Cut
With wordDoc.Application.Selection
.Start = Len(Outmail.Body) ' error n° 91
.End = .Start
.PasteSpecial wdPasteBitmap ' Error n° 4605 or Error n°91
End With
End Sub
The code returns an error every first time I use it after starting the computer:
Error Code 91 "Object variable or With block variable not set"
It is most of the time when Outlook wasn't opened before or when no new email was opened before.
Sometimes I also get the error code 4605, saying that the document is locked against modifications.
The 2 Errors are coming at the end and are marked in the code. (error can happen on 2 different lines)
Sometimes everything worked but only when a new email was opened in Outlook before, (event if Outlook is closed).
Any clue why that might be and how to solve the problem?
Is this what you are trying to do?
Example
Option Explicit
Public Sub TESTEMAIL()
Dim OutApp As Outlook.Application
Set OutApp = CreateObject("Outlook.Application")
Dim Outmail As Outlook.MailItem
Set Outmail = OutApp.CreateItem(olMailItem)
Dim wordDoc As Word.Document
Set wordDoc = Outmail.GetInspector.WordEditor
Dim Sht As Excel.Worksheet
Set Sht = ActiveWorkbook.Sheets("Sheet1")
Dim rng As Range
Set rng = Sht.Range("A1:E10")
rng.CopyPicture Appearance:=xlScreen, Format:=xlPicture
With Outmail
.To = "0m3r#email.com"
.CC = ""
.BCC = ""
.Subject = "Hello"
.Display
wordDoc.Paragraphs(1).Range.PasteSpecial Link:=False, _
DataType:=wdPasteBitmap, _
Placement:=wdFloatOverText, _
DisplayAsIcon:=False
wordDoc.Paragraphs(1).SpaceAfter = 20 ' add space to 12 points
wordDoc.Range.InsertBefore "Hello 0m3r" & vbCr
wordDoc.Paragraphs(1).SpaceAfter = 20 ' add space to 12 points
End With
End Sub
Make sure to Reference to Microsoft Word & Outlook xx.x Object Library
MSDN Paragraphs.SpaceAfter property (Word)
MSDN Range.PasteAndFormat method (Word)
MSDN PasteAndFormat Method
MSDN WdPasteDataType enumeration (Word)
I am trying to paste multiple Excel ranges as images in Outlook mail using VBA. I am using the answer to this question (Pasting an Excel range into an email as a picture) to paste a range of excel as image in mail but as soon as I paste another range, it overwrites the previous image. Is there anyway to change the cursor position in Outlook mail using wordeditor. I tried using collapse before pasting the image but it did not help. Also how do I add the text to it as using Outmail.body to edit anything gets overwritten too by the image pasted afterwards.
This is the code I am using:
Sub Sendmail()
Dim r as range
Set r = Range("C2:O13)
r.copy
dim outlookapp as Outlook.Application
set outlookapp = CreateObject("Outlook.Application")
dim outMail As Outlook.Mailitem
Set outMail = outlookApp.CreateItem(olMailItem)
With outMail
.Display
.CC = "xyz#abc.com"
.Subject = "Test"
.Body = "Dear" & "Macro" & vbnewline
end with
outmail.Display
'Opening wordeditor
dim worddoc as Word.Document
Set worddoc = Outmail.GetInspector.WordEditor
worddoc.range.PasteandFormat wdChartPicture
'Adding new line after pasting image
worddoc.range.Insertafter vbNewline
' Adding second image
dim s as range
set s= Range(P2:Z30)
s.copy
worddoc.range.PasteandFormat wdChartPicture
You could refer to the below code:
Option Explicit
Public Sub Example()
Dim rng As Range
Dim olApp As Object
Dim Email As Object
Dim Sht As Excel.Worksheet
Dim wdDoc As Word.Document
Set Sht = ActiveWorkbook.Sheets("Dashboard")
Set rng = Sht.Range("B4:L17")
rng.CopyPicture Appearance:=xlScreen, Format:=xlPicture
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set olApp = CreateObject("Outlook.Application")
Set Email = olApp.CreateItem(0)
Set wdDoc = Email.GetInspector.WordEditor
With Email
.To = ""
.CC = ""
.BCC = ""
.Subject = ""
.Attachments.Add ActiveWorkbook.FullName
wdDoc.Range.PasteAndFormat Type:=wdChartPicture
' if need setup inlineshapes hight & width
With wdDoc
.InlineShapes(1).Height = 130
End With
.Display
End With
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set Email = Nothing
Set olApp = Nothing
End Sub
For more information, please refer to these links:
Copy Excel range as Picture to Outlook
Copy range of cells from Excel as picture and add text in the email body
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
I have a code that I've been using forever to automatically email a workbook via a commandbutton click. I tried to reformat this code to send 2 individual sheets (named: Pass, Pass Screenshot) from the workbook, but I can't get it to work. The sheets won't be active when the email is sent. This is the code I've been using, any help would be greatly appreciated:
Sub SendEmail()
ThisWorkbook.Save
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 = "my email"
.Subject = "my subject" & Date
.Attachments.Add '???
.Display
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
The Attachments.Add method takes a file path argument, you can't reconfigure that to send a worksheet (or array of worksheet) object. What you can do is export those two sheets in to a new/temporary file, send as attachment, and then remove/kill the temporary file which is no longer needed.
Sub SendEmail()
Dim OutApp As Object
Dim OutMail As Object
Dim tempWB as Workbook
Dim tempFile as String
Dim wb as Workbook
tempFile = Environ("Temp") & "\sheets_copy.xlsx"
Set wb = ThisWorkbook
wb.Save
' The Sheets.Copy method will create a new workbook containing the copied sheets
wb.Sheets(Array("Pass", "Pass Screenshot")).Copy
Set tempWB = ActiveWorkbook
' ensure no temp wb already exists
' this can technically still fail if the file is open/locked
If Len(Dir(tempFile)) <> 0 Then
Kill tempFile
End If
' Save & close the tempFile
tempWB.SaveAs tempFile
tempWB.Close
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.to = "my email"
.Subject = "my subject" & Date
.Attachments.Add tempFile '## Add your attachment here
.Display
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub