Microsoft Office Forums - View Single Post - [Solved] Attach .xlsm file to Outlook email from whatever folder it's been saved in

kiwimtnbkr · 04-02-2022, 11:32 PM

Amazing what a good night's sleep and a fresh look at things does, the answer wasn't as complex as I thought it was...

The already written code by Ron de Bruin, which can be found here, was pretty much the final piece of the jigsaw for me.
I used Example 1 (attaches the last saved version of the active workbook into an email message) from the site to solve this.

I inserted a module into the workbook and pasted the Example 1 code three times - one for each of the departments that the workbook could go to and modified the 'To' and 'Subject' lines to what I needed.
The only line of code that I added was line 2 where I 'Called' the 'Public Sub Workbook_BeforeSave' routine from the 'ThisWookbook' Object to give the file the required name when saving it.

Code:

Sub emailDept1()
    Call ThisWorkbook.Workbook_BeforeSave(True, False)
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 = "Dept1@xxx.xxx"
        .CC = ""
        .BCC = ""
        .Subject = "text"
        .Body = ""
        .Attachments.Add ActiveWorkbook.FullName
        .Display
    End With
    On Error GoTo 0
    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub
Sub emailDept2()
     Call ThisWorkbook.Workbook_BeforeSave(True, False)
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 = "Dept2@xxx.xxx"
        .CC = ""
        .BCC = ""
        .Subject = "text"
        .Body = ""
        .Attachments.Add ActiveWorkbook.FullName
        .Display
    End With
    On Error GoTo 0
    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub
Sub emailDept3()
    Call ThisWorkbook.Workbook_BeforeSave(True, False)
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 = "Dept3@xxx.xxx"
        .CC = ""
        .BCC = ""
        .Subject = "text"
        .Body = ""
        .Attachments.Add ActiveWorkbook.FullName
        .Display
    End With
    On Error GoTo 0
    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub

Three ActiveX command buttons were added to the template sheet, in my case 'Sheet2 (Ordering template), and named 'Private Sub cmdDept1_Click()', 'Private Sub cmdDept2_Click() and ''Private Sub cmdDept3_Click()' respectively.

The following code for the command buttons was added to the Sheet2 (Ordering template) with the call line executing the corresponding 'attach workbook in an email' subroutine from Module 1.

Code:

Private Sub cmdDept1_Click()
    Call emailDept1
End Sub
Private Sub cmdDept2_Click()
    Call emailDept2
End Sub
Private Sub cmdDept3_Click()
    Call emailDept3
End Sub

cheers
Mike