Public sh_emailSettings As Worksheet
Sub sendMailOneByOne()
Call sendMail("Sheet1")
Call sendMail("Sheet2")
End Sub
'Sub sendMailAllAtOnce()
'Dim mailToRng As Range, cell As Range
'Set mailToRng = ThisWorkbook.Sheets("Email Settings").Range("tbl_emailSettings[Mail To]")
'For Each cell In mailToRng
'Call sendMail(cell.Value)
'Next cell
'End Sub
Sub sendMail(mailTo As String)
Dim emailRow As Long
Dim cell As Range
Dim OutApp As Object, OutMail As Object
Dim cmd As String, t As Single
Dim strTo As String, strCc As String, strSub As String, strBody As String, strType As String, strAtt As String, attFilename As String, sendToFilename As String
'On Error GoTo errorHandler
'Store Email Settings Tab in a variable
Set sh_emailSettings = ThisWorkbook.Sheets("Email Settings")
'Store fileName in a variable
sendToFilename = ThisWorkbook.Path & "\" & ThisWorkbook.Name
'Find mailTo row in tbl_email_settings table
For Each cell In sh_emailSettings.Range("tbl_emailSettings[Mail To]")
If cell.Value2 <> "" Then
If cell = mailTo Then
emailRow = cell.Row
Exit For
End If
End If
Next cell
'If no relevant row found with called mailTo then exit
If emailRow = 0 Then
MsgBox "Recipent " & mailTo & " not found. Please check.", vbCritical, "MISSING RECIPIENT"
GoTo exitProcedure
End If
'Start Outlook
'Set outApp = CreateObject("Outlook.Application")
cmd = """" & Application.Path & "\OUTLOOK.EXE"""
Shell cmd, vbHide
t = Timer + 10 ' timeout = 10 seconds max
While OutApp Is Nothing And Timer < t
Set OutApp = GetObject(, "Outlook.Application")
Wend
'If Outlook start failed raise an error and exit
If OutApp Is Nothing Then
MsgBox "Microsoft Outlook session is not created, email will not be sent.", vbCritical, "OUTLOOK ERROR"
GoTo exitProcedure
End If
'Create mail
Set OutMail = OutApp.CreateItem(0)
'Store email details in variables (receipient, copy, subject, email body etc)
strTo = Trim(cell.Offset(0, 1))
strCc = cell.Offset(0, 2)
strSub = cell.Offset(0, 3)
strAtt = cell.Offset(0, 4)
strBody = cell.Offset(0, 5)
strType = cell.Offset(0, 6)
'create_attachment (str_att), Attacgment column in tbl_emailSettings
attFilename = generateAttachment(strAtt)
'If there was an error during attachment generation exit
If attFilename = "" Then GoTo exitProcedure
'create email
With OutMail
.To = strTo
.CC = strCc
.Subject = strSub
.Body = strBody
.Attachments.Add attFilename
If strType = "Send" Then
.send
Else
.Display
End If
End With
'If not the whole file sent delete the temporary file
If Dir(attFilename) <> "" And attFilename <> sendToFilename Then
Kill attFilename
End If
exitProcedure:
Set OutMail = Nothing
Set OutApp = Nothing
Exit Sub
errorHandler:
MsgBox (Err.Number & vbCrLf & Err.Description & vbCrLf & "Something went wrong during sendMail procedure.")
On Error GoTo 0
Resume exitProcedure
End Sub
Function generateAttachment(attachmentStr As String) As String
Dim fileName As String
Dim sh_array() As String
Dim wbTemp As Workbook
Dim sh As Worksheet
Dim i As Long
'On Error GoTo errorHandler
'Turn off events
Application.EnableEvents = False
'Set calculation to manual
Application.Calculation = xlCalculationManual
'Turn off screen updating
Application.ScreenUpdating = False
Select Case attachmentStr
'Whole file will be sent, in this case file's name remain the same
Case "full"
'NOTE: other possible solution is to Save As the workbook as a new file
'Attached file name will be the same
'fileName = ThisWorkbook.Path & "\" & ThisWorkbook.Name
'Function return value is the filename
generateAttachment = fileName
'Listed sheets will be sent
Case Else
'Store listed sheet names in an array (Attachment column in tbl_emailSettings)
sh_array = Split(attachmentStr, ",")
'Define name to the new the where the sheets will be copied, this will be the attachment name in the mail
If UBound(sh_array) = 1 Then
fileName = Application.ActiveWorkbook.Path & "\" & CStr(sh_array(1)) & ".xlsx"
'Else
'fileName = ThisWorkbook.Path & "\" & CStr(sh_array(1)) & ".xlsx"
End If
'Store listed sheet names in an array (Attachment column in tbl_emailSettings)
'sh_array = Split(attachmentStr, ",")
'Define name to the new the where the sheets will be copied, this will be the attachment name in the mail
'fileName = ThisWorkbook.Path & "\" & sh.Name & ".xlsx"
'Add a new workbook
Set wbTemp = Workbooks.Add(1)
'Turn off alerts
Application.DisplayAlerts = False
'Copy sheets given on Email Settings sheet (Attachment column)
'NOTE: if the workbook is protected and/or sheet(s) is hidden handle that before copying
For i = UBound(sh_array) To LBound(sh_array) Step -1
ThisWorkbook.Sheets(sh_array(i)).Copy after:=wbTemp.Sheets(1)
Next i
'Paste special values - only optional, if you 100% sure that no formula error will occur you can delete this part
'NOTE: also worth to consider to delete names, break links and connections
'For Each sh In wbTemp.Sheets
'Delete first sheet
wbTemp.Sheets(1).Delete
'Save the new workbook
wbTemp.SaveAs
wbTemp.Close
'Function return value is the fileName
generateAttachment = fileName
End Select
exitFunction:
'Turn back on things
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Exit Function
errorHandler:
MsgBox Err.Number & vbCrLf & Err.Description & vbCrLf & "Something went wrong. Check Attachment Settings."
'In case of an error function return "empty" string
generateAttachment = ""
On Error GoTo 0
Resume exitFunction
End Function
