|
|
Thread Tools | Display Modes |
#1
|
|||
|
|||
Attach .xlsm file to Outlook email from whatever folder it's been saved in
This may be a case that I can't see the forest for the trees and the answer is not as complex as I think it is.
The code below runs to provide the file name as part of the SaveAs routine. The .xltm is saved as an .xlsm file in various folders by the users, depending on what it is that they are requesting. Code:
Public Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean) Dim ws As Worksheet Set ws = ActiveSheet Dim xFileName As String Dim U7part As String, U8part As String, K13part As String Dim strMsg As String If (Range("U7") = Empty) Then MsgBox "'Request number' is mandatory.", vbCritical, "Title" Cancel = True Range("U7").Select Exit Sub Else If (Range("U8") = Empty) Then MsgBox "'Request date' is mandatory.", vbCritical, "Title" Cancel = True Range("U8").Select Exit Sub Else If (Range("L33") = "click here then select from drop down list") Then MsgBox "para. 3.b. 'Method of Delivery' is mandatory.", vbExclamation, "Title" Cancel = True Range("L33").Select Exit Sub Else If (Range("L37") = Empty) Then MsgBox "para. 3.d. 'Date required by' is missing.", vbExclamation, "Title" Cancel = True Range("L37").Select Exit Sub Else Call RenameTemplateSheet U7part = ws.Range("U7").value U7part = Replace(Replace(U7part, " / ", "/"), "/", "_") U8part = ws.Range("U8").value U8part = Replace(Replace(U8part, " / ", "/"), "/", "_") K13part = ws.Range("K13").value K13part = Replace(K13part, "/", "_") Range("U9").Select If SaveAsUI <> False Then Cancel = True xFileName = Application.GetSaveAsFilename(K13part & " Text " & Range("A1").value & U7part & " dated " & U8part, "Excel Macro-Enabled Workbook (*.xlsm), *.xlsm", , "Save As xlsm file") If xFileName <> "False" Then Application.EnableEvents = False ActiveWorkbook.SaveAs Filename:=xFileName, FileFormat:=xlOpenXMLWorkbookMacroEnabled Application.EnableEvents = True End If End If End If End If End If End If End Sub The code will be attached to 'Save and Email to Department x' command buttons so that when the user clicks one of the three command buttons, the 'To address' will be pre-populated with the correct 'To address'. I thought I was finally onto something with the code I found here but I can't make it work no matter what I try. cheers Mike Last edited by kiwimtnbkr; 04-01-2022 at 07:49 PM. Reason: clarity |
#2
|
|||
|
|||
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 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 Mike |
Thread Tools | |
Display Modes | |
|
Similar Threads | ||||
Thread | Thread Starter | Forum | Replies | Last Post |
Cannot find file to attach in email | megabyte | Outlook | 0 | 09-23-2020 05:35 AM |
Lost mails (xlsm file attached) (solved) but unbelievelable | agnys | Outlook | 0 | 04-05-2018 05:10 PM |
VBA to create a button to attach the active word doc to an email as a PDF without using Outlook | TAKMalcolm | Word VBA | 1 | 09-21-2017 01:52 AM |
File Not Found error when trying to attach Word document to email | Kimber | Word | 0 | 03-06-2015 06:47 PM |
Having Touble Finding Word File When Trying to Attach to Email | freetibet213 | Word | 3 | 12-28-2011 05:26 AM |