Send Email from Excel - Error in Macro

T

TG2812

Board Regular
Joined
Apr 15, 2015
Messages
180
Hello, I came up with the below code in order to send an excel file from VBA leveraging outlook.
While some part of the code works, I'm stuck when Excel is not opened /or is opened. I got an error.

I have highlighted the part I'm struggling with in red. Any idea what I have to adjust?
Thank you very much in advance for your help!

-------------------------------------------------------

Sub SendEmail()

Dim rng As Range, OutApp As Object, OutMail As Object, Dest As Workbook, wb As Workbook
Dim sSubj As String, iMonth As String, iYear As Integer, Obj As Object
Dim TempFilePath As String, TempFileName As String

Application.Calculation = xlCalculationManual

iMonth = MonthName(Month(Now()))
iYear = Year(Now())
sSubj = iMonth & "-" & iYear & " " & " my subject"

Set Obj = CreateObject("WScript.Shell")
desktop = Obj.SpecialFolders("Desktop")
Set wb = ThisWorkbook
Set Dest = Workbooks.Add
Set rng = Nothing
On Error Resume Next
Set rng = wb.Sheets("Tracking").Cells(1).CurrentRegion
rng.Copy

With Dest.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial Paste:=xlPasteValues
.Cells(1).PasteSpecial Paste:=xlPasteFormats
.Cells(1).Select
Application.CutCopyMode = False
End With

TempFilePath = desktop & ""
TempFileName = "My Subject" & "-" & Format(Now, "dd-mmm-yyyy h-mm-ss")
Dest.SaveAs TempFilePath & TempFileName & ".xlsx", FileFormat:=51
Dest.Close

On Error GoTo 0

With Application
.EnableEvents = 0
.ScreenUpdating = 0
End With

Set OutApp = CreateObject("Outlook.Application")
If OutApp Is Nothing Then
MsgBox "Outlook is not open, Open Outlook and try again!"
Kill TempFilePath & TempFileName & ".xlsx"
Exit Sub
Else
Set OutMail = OutApp.CreateItem(0)

End If

On Error Resume Next
With OutMail
.Subject = sSubj
.Attachments.Add Dest.FullName
.Display
End With
On Error GoTo 0

With Application
.EnableEvents = 1
.ScreenUpdating = 1
End With

Dest.Close savechanges:=False
Kill TempFilePath & TempFileName & ".xlsx"
Set OutMail = Nothing: Set OutApp = Nothing


End Sub
 

Excel Facts

Formula for Yesterday
Name Manager, New Name. Yesterday =TODAY()-1. OK. Then, use =YESTERDAY in any cell. Tomorrow could be =TODAY()+1.
Sort by date Sort by votes
I'm still struggling with the code...I do not know how to handle when Outlook is open vs when it is closed. I believe I need to re-arrange the code but I do know which part require an adjustment.
Thank you all in advance for your help.
 
Upvote 0
.
I can't explain why you are receiving the error on your machine. Might be a silly question, but do you have Outlook installed on your machine ?

I am running Excel 2007 on Win 10 / 64 here and the following works fine. I do not need to have Outlook open here for the email to be created.

Code: 
Option Explicit


Sub SendEmail()


Dim rng As Range, OutApp As Object, OutMail As Object, Dest As Workbook, wb As Workbook
Dim sSubj As String, iMonth As String, iYear As Integer, Obj As Object
Dim TempFilePath As String, TempFileName As String
Dim desktop As String
Application.Calculation = xlCalculationManual


iMonth = MonthName(Month(Now()))
iYear = Year(Now())
sSubj = iMonth & "-" & iYear & " " & " my subject"


Set Obj = CreateObject("WScript.Shell")
desktop = Obj.SpecialFolders("Desktop")
Set wb = ThisWorkbook
Set Dest = Workbooks.Add
Set rng = Nothing
On Error Resume Next
Set rng = wb.Sheets("Tracking").Cells(1).CurrentRegion
rng.Copy


With Dest.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial Paste:=xlPasteValues
.Cells(1).PasteSpecial Paste:=xlPasteFormats
.Cells(1).Select
Application.CutCopyMode = False
End With


TempFilePath = Environ("USERPROFILE") & "\Desktop\"
TempFileName = "My Subject" & "-" & Format(Now, "dd-mmm-yyyy h-mm-ss")
Dest.SaveAs TempFilePath & TempFileName & ".xlsx", FileFormat:=51


On Error GoTo 0


With Application
.EnableEvents = 0
.ScreenUpdating = 0
End With


Set OutApp = CreateObject("Outlook.Application")
If OutApp Is Nothing Then
MsgBox "Outlook is not open, Open Outlook and try again!"
Kill TempFilePath & TempFileName & ".xlsx"
Exit Sub
Else
Set OutMail = OutApp.CreateItem(0)


End If


On Error Resume Next
With OutMail
.Subject = sSubj
.Attachments.Add Dest.FullName
.Display
End With
On Error GoTo 0


With Application
.EnableEvents = 1
.ScreenUpdating = 1
End With


Dest.Close savechanges:=False
Kill TempFilePath & TempFileName & ".xlsx"
Set OutMail = Nothing: Set OutApp = Nothing


End Sub

NOTE: I made just a couple of small edits to your macro.
 
Upvote 0
Yes I do have Microsoft Outlook installed on my computer. The code you provided above works fine, however the same errors occur.

Run-time error '-21472211231 (80040111) Cannot Create the email message because a data file to send and receive messages cannot be found. Check your settings in this Microsoft Office profile [...]



This only happens when Microsoft Outlook is closed on the below code line. This is the reason why i wanted to put an error handler procedure to avoid any issues going forward if outlook is closed.


Set OutMail = OutApp.CreateItem(0)
 
Upvote 0
.
The following macro will check if Outlook is open/running. If it isn't, the macro opens Outlook.

Code: 
Option Explicit


Sub Is_Outlook_Running_Open_App()
    'Declare Variables to Check Get Instance of Outlook Object
    Dim objOutlook As Object
    
    'Initialize
    Set objOutlook = Nothing
    
    'Get Instance of Object
    'Getobject will give error if it did not find the app.
    'Sp, On Error is required all the time
    On Error Resume Next
    Set objOutlook = GetObject(, "Outlook.Application")
    On Error GoTo 0
    
    'Check if Outlook is Running
    If objOutlook Is Nothing Then
        'Outlook is not Running - Open Outlook App
        VBA.Shell ("Outlook")
    Else
        MsgBox "Outlook is already Running in Your Machine"
    End If
End Sub
 
Upvote 0
I still get error message. Let's make it more simple, that is to alert the user when Outlook is not open. To reflect this, how am I supposed to modify the current code?
1 - if Outlook is opened then run the code
2 - if Outlook is closed, the users gets a warning message via an info box.

Code: 
Sub SendEmail()




Dim rng As Range, OutApp As Object, OutMail As Object, Dest As Workbook, wb As Workbook
Dim sSubj As String, iMonth As String, iYear As Integer, Obj As Object
Dim TempFilePath As String, TempFileName As String
Dim desktop As String
Application.Calculation = xlCalculationManual




iMonth = MonthName(Month(Now()))
iYear = Year(Now())
sSubj = iMonth & "-" & iYear & " " & " my subject"




Set Obj = CreateObject("WScript.Shell")
desktop = Obj.SpecialFolders("Desktop")
Set wb = ThisWorkbook
Set Dest = Workbooks.Add
Set rng = Nothing
On Error Resume Next
Set rng = wb.Sheets("Tracking").Cells(1).CurrentRegion
rng.Copy




With Dest.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial Paste:=xlPasteValues
.Cells(1).PasteSpecial Paste:=xlPasteFormats
.Cells(1).Select
Application.CutCopyMode = False
End With




TempFilePath = Environ("USERPROFILE") & "\Desktop\"
TempFileName = "My Subject" & "-" & Format(Now, "dd-mmm-yyyy h-mm-ss")
Dest.SaveAs TempFilePath & TempFileName & ".xlsx", FileFormat:=51




With Application
.EnableEvents = 0
.ScreenUpdating = 0
End With


Set OutApp = Nothing
On Error Resume Next


Set OutApp = CreateObject("Outlook.Application")
If OutApp Is Nothing Then
MsgBox "Outlook is not open, Open Outlook and try again!"
Kill TempFilePath & TempFileName & ".xlsx"
Exit Sub
Else
Set OutMail = OutApp.CreateItem(0)




End If




On Error Resume Next
With OutMail
.Subject = sSubj
.Attachments.Add Dest.FullName
.Display
End With






With Application
.EnableEvents = 1
.ScreenUpdating = 1
End With




Dest.Close savechanges:=False
Kill TempFilePath & TempFileName & ".xlsx"
Set OutMail = Nothing: Set OutApp = Nothing




End Sub
 
Upvote 0
Code: 
Sub TestOutlookIsOpen()
    Dim oOutlook As Object


    On Error Resume Next
    Set oOutlook = GetObject(, "Outlook.Application")
    On Error GoTo 0


    If oOutlook Is Nothing Then
        MsgBox "Outlook is not open, open Outlook and try again"
    Else
        'Call NameOfYourMailMacro
    End If
End Sub
 
Upvote 0
When the code gets to the following code line, an error pops up "Run time error 429 - ActiveX component can't create object"...

Set oOutlook = getObject(,"Outlook.Application")


My file will be used by people who have zero knowledge of VBA. Can you please tell me if my error handling procedures in the below codes are fine? If an error occur, I just want the code to alert the user by saying "Outlook is not opened"...

Code: 
Sub SendEmail()




Dim rng As Range, oOutlook As Object, OutMail As Object, Dest As Workbook, wb As Workbook
Dim sSubj As String, iMonth As String, iYear As Integer, Obj As Object
Dim TempFilePath As String, TempFileName As String
Dim desktop As String
Application.Calculation = xlCalculationManual




iMonth = MonthName(Month(Now()))
iYear = Year(Now())
sSubj = iMonth & "-" & iYear & " " & " my subject"




Set Obj = CreateObject("WScript.Shell")
desktop = Obj.SpecialFolders("Desktop")
Set wb = ThisWorkbook
Set Dest = Workbooks.Add
Set rng = Nothing
On Error Resume Next
Set rng = wb.Sheets("Tracking").Cells(1).CurrentRegion
rng.Copy




With Dest.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial Paste:=xlPasteValues
.Cells(1).PasteSpecial Paste:=xlPasteFormats
.Cells(1).Select
Application.CutCopyMode = False
End With




TempFilePath = Environ("USERPROFILE") & "\Desktop\"
TempFileName = "My Subject" & "-" & Format(Now, "dd-mmm-yyyy h-mm-ss")
Dest.SaveAs TempFilePath & TempFileName & ".xlsx", FileFormat:=51




On Error GoTo 0




With Application
.EnableEvents = 0
.ScreenUpdating = 0
End With




Set oOutlook = GetObject(, "Outlook.Application")
On Error GoTo 0




If oOutlook Is Nothing Then
MsgBox "Outlook is not open, Open Outlook and try again!"
Kill TempFilePath & TempFileName & ".xlsx"
Exit Sub
Else
Set OutMail = oOutlook.CreateItem(0)




End If




On Error Resume Next
With OutMail
.Subject = sSubj
.Attachments.Add Dest.FullName
.Display
End With
On Error GoTo 0




With Application
.EnableEvents = 1
.ScreenUpdating = 1
End With




Dest.Close savechanges:=False
Kill TempFilePath & TempFileName & ".xlsx"
Set OutMail = Nothing: Set oOutlook = Nothing




End Sub
 
Last edited:
Upvote 0
.
I moved the portion of code that checks for Outlook to the top of the macro. Tested here and it works.
I did not review the remainder of your code.

Code: 
Option Explicit




Sub SendEmail()


Dim oOutlook As Object




    On Error Resume Next
    Set oOutlook = GetObject(, "Outlook.Application")
    On Error GoTo 0




    If oOutlook Is Nothing Then
        MsgBox "Outlook is not open, open Outlook and try again"
        Exit Sub
    Else
        'continues with remainder of macro
    End If






Dim rng As Range, OutMail As Object, Dest As Workbook, wb As Workbook
Dim sSubj As String, iMonth As String, iYear As Integer, Obj As Object
Dim TempFilePath As String, TempFileName As String
Dim desktop As String
Application.Calculation = xlCalculationManual








iMonth = MonthName(Month(Now()))
iYear = Year(Now())
sSubj = iMonth & "-" & iYear & " " & " my subject"








Set Obj = CreateObject("WScript.Shell")
desktop = Obj.SpecialFolders("Desktop")
Set wb = ThisWorkbook
Set Dest = Workbooks.Add
Set rng = Nothing
On Error Resume Next
Set rng = wb.Sheets("Tracking").Cells(1).CurrentRegion
rng.Copy








With Dest.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial Paste:=xlPasteValues
.Cells(1).PasteSpecial Paste:=xlPasteFormats
.Cells(1).Select
Application.CutCopyMode = False
End With








TempFilePath = Environ("USERPROFILE") & "\Desktop\"
TempFileName = "My Subject" & "-" & Format(Now, "dd-mmm-yyyy h-mm-ss")
Dest.SaveAs TempFilePath & TempFileName & ".xlsx", FileFormat:=51








On Error GoTo 0








With Application
.EnableEvents = 0
.ScreenUpdating = 0
End With








Set oOutlook = GetObject(, "Outlook.Application")
On Error GoTo 0








If oOutlook Is Nothing Then
MsgBox "Outlook is not open, Open Outlook and try again!"
Kill TempFilePath & TempFileName & ".xlsx"
Exit Sub
Else
Set OutMail = oOutlook.CreateItem(0)








End If








On Error Resume Next
With OutMail
.Subject = sSubj
.Attachments.Add Dest.FullName
.Display
End With
On Error GoTo 0








With Application
.EnableEvents = 1
.ScreenUpdating = 1
End With








Dest.Close savechanges:=False
Kill TempFilePath & TempFileName & ".xlsx"
Set OutMail = Nothing: Set oOutlook = Nothing








End Sub
 
Upvote 0
You must log in or register to reply here.

Similar threads

R
  • Question
Mail merge to insert the picture in the mail body and schedule the email
Replies
0
Views
774
rafeek4u
R
M
  • Question
Creating and emailing Excel sheet with only visible data
Replies
0
Views
184
mecerrato
M
S
  • Question
Excel VBA to email multiple ranges as a PDF
Replies
0
Views
669
shophoney
S
catscantuseexcel
  • Solved
VBA to send sheets based on column values
Replies
3
Views
651
DanteAmor
DanteAmor
P
  • Question
Signature is being removed when I run the rest of my VBA
Replies
3
Views
166
rollis13
rollis13

Forum statistics

Threads
1,215,035
Messages
6,122,785
Members
449,095
Latest member
m_smith_solihull

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top