VBA to email a file I have open

mholton63

New Member
Joined
Nov 16, 2018
Messages
9
I'm trying to create a button that will allow me to email the file I have open for updating. Below is the code I currently have. I don't want to create a copy. Any help would be greatly appreciated.

Sub SendSheetMail()
Dim strTo As String
Dim strSubject As String
Dim strBody As String
strTo = "test1@test.com"
'strCC = "test@test.com"
strSubject = "Please find Maintenance Log attached"
strBody = "Current Maintenance Log "
If SendActiveWorksheet(strTo, strSubject, , strBody) = True Then
MsgBox "Email creation Success"
Else
MsgBox "Email creation failed!"
End If
End Sub


Function SendActiveWorksheet(strTo As String, strSubject As String, Optional strCC As String, Optional strBody As String) As Boolean
On Error GoTo eh
'declare variables to hold the objects required
Dim wbDestination As Workbook
Dim strDestName As String
Dim wbSource As Workbook
Dim wsSource As Worksheet
Dim OutApp As Object
Dim OutMail As Object
Dim strTempName As String
Dim strTempPath As String
'first create destination workbook
Set wbDestination = Workbooks.Add
strDestName = wbDestination.name
'set the source workbook and sheet
Set wbSource = ActiveWorkbook
Set wsSource = wbSource.ActiveSheet
'copy the activesheet to the new workbook
wsSource.copy After:=Workbooks(strDestName).Sheets(1)
'save with a temp name
strTempPath = Environ$("temp") & "\"
'strTempPath = Environ$("S:\Tool and Die") & "\"
strTempName = "Die Maintenance Log" & ".xlsx"
'strTempName = "List obtained from " & wbSource.name & ".xlsx"
With wbDestination
.SaveAs strTempPath & strTempName
'now email the destination workbook
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = strTo
.subject = strSubject
.body = strBody
.Attachments.Add wbDestination.FullName
'use send to send immediately or display to show on the screen
.Send 'or .Display
End With
.Close False
End With
'delete temp workbook that you have attached to your mail
Kill strTempPath & strTempName
'clean up the objects to release the memory
Set wbDestination = Nothing
Set wbSource = Nothing
Set wsSource = Nothing
Set OutMail = Nothing
Set OutApp = Nothing
Exit Function
eh:
MsgBox Err.Description
End Function
 

Excel Facts

How to calculate loan payments in Excel?
Use the PMT function: =PMT(5%/12,60,-25000) is for a $25,000 loan, 5% annual interest, 60 month loan.

Logit

Well-known Member
Joined
Aug 31, 2016
Messages
4,577
The following will send an email with the active workbook attached. In order to preview the newly created workbook it
will be necessary to closed the original workbook because both will have the same name.

VBA Code:
Option Explicit

Sub Mail_workbook_Outlook()

    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 = "me@yahoo.com"
        .CC = ""
        .BCC = ""
        .Subject = "Test"
        .Body = ""
        .Attachments.Add (Application.ActiveWorkbook.FullName)
        
        '.Send
        .display
    End With
    On Error GoTo 0

    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub
 
Solution

mholton63

New Member
Joined
Nov 16, 2018
Messages
9
The following will send an email with the active workbook attached. In order to preview the newly created workbook it
will be necessary to closed the original workbook because both will have the same name.

VBA Code:
Option Explicit

Sub Mail_workbook_Outlook()

    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 = "me@yahoo.com"
        .CC = ""
        .BCC = ""
        .Subject = "Test"
        .Body = ""
        .Attachments.Add (Application.ActiveWorkbook.FullName)
       
        '.Send
        .display
    End With
    On Error GoTo 0

    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub
Thank You.
 

Forum statistics

Threads
1,181,673
Messages
5,931,352
Members
436,787
Latest member
ogharipour

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
Top