# Send Email from Excel - Error in Macro



## TG2812 (Dec 28, 2018)

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_


----------



## TG2812 (Dec 29, 2018)

Any idea, anyone?


----------



## TG2812 (Jan 3, 2019)

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.


----------



## Logit (Jan 3, 2019)

.
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.


```
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.


----------



## TG2812 (Jan 4, 2019)

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)


----------



## Logit (Jan 4, 2019)

.
The following macro will check if Outlook is open/running. If it isn't, the macro opens Outlook.


```
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
```


----------



## TG2812 (Jan 4, 2019)

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.


```
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
```


----------



## Logit (Jan 4, 2019)

```
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
```


----------



## TG2812 (Jan 5, 2019)

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"...


```
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
```


----------



## Logit (Jan 5, 2019)

.
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.


```
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
```


----------



## TG2812 (Dec 28, 2018)

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_


----------



## TG2812 (Jan 5, 2019)

Thank you for your prompt answer. I'm probably missing something but the macro is not working.
When I run the code on debug mode, the errors happens on this line "*Set oOutlook = GetObject(, "Outlook.Application")*"

I do not know what to do...

Here's the latest code I have. Do not hesitate to adjust it.


```
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
```


----------



## Logit (Jan 5, 2019)

.
You did not use the code posted in #10 .

Copy the code shown in Post #10  and paste it into a module. Connect your CommandButton to that macro. 

As indicated, the macro I posted in #10  runs here.


----------



## TG2812 (Jan 5, 2019)

Logit, it does work. I did not read carefully post #10 . My apologies.
Thank you very much for your time and help here!


----------



## Logit (Jan 5, 2019)

You are welcome. Glad to help.


----------

