VBA to email a file I have open

[mholton63]

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

 

[Logit]

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.

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

 

[mholton63]

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.

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.

 

[Logit]

You are welcome.