Hi Yasser,
See the attached zip file that contains a modified copy of your Excel File, and contains copies of your 3 sample data files in case anyone else wants to try to use the modified Excel file.
The Excel file contains code to:
a. Create/Delete CheckBoxes.
b. Send Emails (using Outlook) to the User(s) on each data line with the appropriate attachments.
To send one Email to multiple users, separate each Email address in Column 'A' with a semicolon (
.
The code does not close Outlook because most users keep Outlook open all the time.
Please note that 'Late Binding' is used which avoids the necessity to have a VBA library reference to Outlook. For more information see:
https://msdn.microsoft.com/en-us/library/0tcf61s1.aspx
http://peltiertech.com/Excel/EarlyLateBinding.html
Some newer versions of Outlook have NASTY Security messages when using VBA to access Outlook. The messages can be suppressed if your Anti-Virus software is up to date and you follow the following instructions:
To prevent OutLook Security Message such as (and to remain secure):
a. A program is trying to send an e-mail message on your behalf, or
b. A program is trying to access e-mail addresses:
Make sure Anti-Virus software is up to date
Go to Windows 'Start' Menu
Right Click on 'Outlook 2016' and select 'Run as Administrator'
File > Options > Trust Center > Trust Center Settings > Programmatic Access
AntiVirus status : Valid' should be displayed in the middle of the Screen.
The Email code in Ordinary Code module Mod ModOutlookEmail follows:
Option Explicit
'SetForegroundWindow() is used by MoveFocusToWorksheet()
#If VBA7 And Win64 Then
'64 bit Excel:
'All of the Win64 lines are supposed to be RED in 32 bit Excel
Private Declare PtrSafe Function SetForegroundWindow Lib "user32" (ByVal HWnd As LongPtr) As Long
#Else
'32 bit Excel:
Private Declare Function SetForegroundWindow Lib "user32" (ByVal HWnd As Long) As Long
#End If
'Reference: http://www.rondebruin.nl/win/s1/outlook/openclose.htm
'Thank you Ron deBruin and Ben Clothier
'
'Late Binding is used in the following routines
'Outlook enumeration constant reference: https://msdn.microsoft.com/en-us/library/office/aa219371(v=office.11).aspx
Private Const olMinimized As Long = 1
Private Const olMaximized As Long = 2
Private Const olFolderInbox As Long = 6
'Reference: http://www.globaliconnect.com/excel/index.php?option=com_content&view=article&id=170:automate-outlook-using-vba-sending-email-from-excel-using-outlook&catid=79&Itemid=475
'
'Chr(10) = linefeed between lines
'Chr(13) = carriage return
Sub SendMultipleEmailsWithAttachmentsUsingOutlook()
'This sends multiple Emails with attachments with NO Preview
Dim wb As Workbook
Dim ws As Worksheet
Dim iCountFailure As Long
Dim iCountSuccess As Long
Dim iError As Long
Dim iLastRowUsed As Long
Dim iNumberOfAttachments As Long
Dim iRow As Long
Dim bNeedAttachments As Boolean
Dim sAttachmentArray() As String
Dim sAttachmentPath As String
Dim sAttachmentPathAndFileName As String
Dim sDisplayOrSendOption As String
Dim sEmailAddress As String
Dim sEmailBCC As String
Dim sEmailBody As String
Dim sEmailCC As String
Dim sEmailSubject As String
Dim sFileName As String
Dim sMissingAttachmentList As String
Dim sValue As String
'''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Initialization
'''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Create the Worksheet Object
Set wb = ThisWorkbook
Set ws = wb.ActiveSheet
'Get the Last Row Used in Column 'A'
iLastRowUsed = ws.Range("A:A").Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
'''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Get Email options
'''''''''''''''''''''''''''''''''''''''''''''''''''''''
'The 'Display or Send Option is one of':
'a. 'Send'
'b. 'Display'
'c. 'Sendkeys'
sDisplayOrSendOption = "Send"
'''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Get the Email details from the SpreadSheet
'''''''''''''''''''''''''''''''''''''''''''''''''''''''
For iRow = 6 To iLastRowUsed
'Initialize the Attachment Array and Attachment Data
ReDim sAttachmentArray(1 To 1)
iNumberOfAttachments = 0
sMissingAttachmentList = ""
'Get the Email address
sEmailAddress = Trim(ws.Cells(iRow, "A").Value)
'Get the 'Email Subject:'
sEmailSubject = Trim(ws.Cells(iRow, "B").Value)
'Get the Email 'Carbon Copy'
sEmailCC = ""
'Get the Email 'Blind Carbon Copy'
sEmailBCC = ""
sEmailBody = Trim(ws.Cells(iRow, "C").Value)
sValue = UCase(Trim(ws.Cells(iRow, "F").Value))
If sValue = "TRUE" Then
bNeedAttachments = True
Else
bNeedAttachments = False
End If
If bNeedAttachments = True Then
sAttachmentPath = ThisWorkbook.Path & "\Files\"
'Attachment 1
sFileName = Trim(ws.Cells(iRow, "G").Value)
If Len(sFileName) > 0 Then
sAttachmentPathAndFileName = sAttachmentPath & sFileName
If Len(sAttachmentPathAndFileName) > 0 Then
If LJMFileExists(sAttachmentPathAndFileName) = True Then
iNumberOfAttachments = iNumberOfAttachments + 1
ReDim Preserve sAttachmentArray(1 To iNumberOfAttachments)
sAttachmentArray(iNumberOfAttachments) = sAttachmentPathAndFileName
Else
If Len(sMissingAttachmentList) = 0 Then
sMissingAttachmentList = sFileName
Else
sMissingAttachmentList = sMissingAttachmentList & vbCrLf & sFileName
End If
End If
End If
End If
'Attachment 2
sFileName = Trim(ws.Cells(iRow, "H").Value)
If Len(sFileName) > 0 Then
sAttachmentPathAndFileName = sAttachmentPath & sFileName
If Len(sAttachmentPathAndFileName) > 0 Then
If LJMFileExists(sAttachmentPathAndFileName) = True Then
iNumberOfAttachments = iNumberOfAttachments + 1
ReDim Preserve sAttachmentArray(1 To iNumberOfAttachments)
sAttachmentArray(iNumberOfAttachments) = sAttachmentPathAndFileName
Else
If Len(sMissingAttachmentList) = 0 Then
sMissingAttachmentList = sFileName
Else
sMissingAttachmentList = sMissingAttachmentList & vbCrLf & sFileName
End If
End If
End If
End If
'Attachment 3
sFileName = Trim(ws.Cells(iRow, "I").Value)
If Len(sFileName) > 0 Then
sAttachmentPathAndFileName = sAttachmentPath & sFileName
If Len(sAttachmentPathAndFileName) > 0 Then
If LJMFileExists(sAttachmentPathAndFileName) = True Then
iNumberOfAttachments = iNumberOfAttachments + 1
ReDim Preserve sAttachmentArray(1 To iNumberOfAttachments)
sAttachmentArray(iNumberOfAttachments) = sAttachmentPathAndFileName
Else
If Len(sMissingAttachmentList) = 0 Then
sMissingAttachmentList = sFileName
Else
sMissingAttachmentList = sMissingAttachmentList & vbCrLf & sFileName
End If
End If
End If
End If
End If
If Len(sMissingAttachmentList) = 0 Then
iError = SendEmailViaOutlook(sDisplayOrSendOption, sEmailAddress, sEmailCC, sEmailBCC, sEmailSubject, sEmailBody, sAttachmentArray)
If iError = 0 Then
'Normal processing - do nothing
iCountSuccess = iCountSuccess + 1
ElseIf iError = 1 Then
'Could Not Open Outlook Error
iCountFailure = iCountFailure + 1
Call MoveFocusToWorksheet(ws)
MsgBox "NOTHING DONE. EMail NOT sent because Outlook could NOT be OPENED."
GoTo MYEXIT
ElseIf iError = 2 Then
'Could Not Send Error
iCountFailure = iCountFailure + 1
Call MoveFocusToWorksheet(ws)
MsgBox "NOTHING DONE. EMail NOT sent due to Outlook 'Send' problem."
GoTo MYEXIT
Else
'Could Not Open Outlook Error
iCountFailure = iCountFailure + 1
Call MoveFocusToWorksheet(ws)
MsgBox "NOTHING DONE. EMail NOT sent due to Unknown Error number " & iError & "."
GoTo MYEXIT
End If
Else
iCountFailure = iCountFailure + 1
Call MoveFocusToWorksheet(ws)
MsgBox "NOTHING DONE for the Email on Row " & iRow & "." & vbCrLf & _
"The following data files DO NOT EXIST:" & vbCrLf & _
"Folder: " & sAttachmentPath & vbCrLf & _
sMissingAttachmentList
End If
Next iRow
Call MoveFocusToWorksheet(ws)
MsgBox "Done..." & vbCrLf & _
iCountSuccess & " Emails Sent Successfully." & vbCrLf & _
iCountFailure & " Emails NOT sent.", 64
MYEXIT:
'Clear object pointers
Set wb = Nothing
Set ws = Nothing
End Sub
Function SendEmailViaOutlook(sDisplayOrSendOption As String, _
sTo As String, _
sCC As String, _
sBCC As String, _
sSubject As String, _
sBody As String, _
sAttachmentArray() As String) As Long
'This sends an e-mail via Outlook
'
'Return Values: 0 = No Error
' 1 = Could not create Outlook object (Outlook could not be opened)
' 2 = Could Not Send the message (runtime error 429 is OK)
'
'Outlook objects are created using 'Late Binding' (no library reference required)
'
'Multiple recipients are separated by a semi-colon:
'For example: .CC = "person1@email.com;person2@email.com"
'
'If using .Display, SendKeys "^{ENTER}" can be placed before the 'With OutMail' line.
'This assumes 'SendKeys' works in the version of Excel.
Dim OutApp As Object
Dim OutMail As Object
Dim i As Long
Dim iError As Long
'Disable Events and Screen Updating
Application.EnableEvents = False
Application.ScreenUpdating = False
'Get the Outlook Objectif Outlook is already open
On Error Resume Next
Set OutApp = LjmOpenOutlook()
'Exit if the Outlook Object could not be created
If OutApp Is Nothing Then
iError = 1
GoTo MYEXIT
End If
'Create the Outlook Mail Object
Set OutMail = OutApp.CreateItem(0)
'Determine the values to be sent
With OutMail
.To = sTo
.CC = sCC
.BCC = sBCC
.Subject = sSubject
.Body = sBody
If Len(sAttachmentArray(1)) > 0 Then
For i = 1 To UBound(sAttachmentArray)
.Attachments.Add sAttachmentArray(i)
Debug.Print i, sAttachmentArray(i)
Next i
End If
If sDisplayOrSendOption = "Send" Then
.Send
If iError = 0 Or iError = 429 Then
'Do nothing - Send probably worked OK
Else
'Send Failure
iError = 2
GoTo MYEXIT
End If
ElseIf sDisplayOrSendOption = "Display" Then
.Display
Else
.Display
Application.Wait (Now + TimeValue("0:00:02")) 'SENDKEYS does not appear to work with this code
Application.SendKeys "%s", True '% = ALT ---> Sending 'ALT s'
End If
End With
MYEXIT:
'Resume normal error processing
On Error GoTo 0
'Reenable Events and Screen Updating
Application.EnableEvents = True
Application.ScreenUpdating = True
'Clear the Object Pointers
Set OutMail = Nothing
Set OutApp = Nothing
'Set the return value
SendEmailViaOutlook = iError
End Function
Private Function LJMFileExists(sPathAndFullFileName As String) As Boolean
'This returns TRUE if a file exists and FALSE if a file does NOT exist
Dim iError As Integer
Dim iFileAttributes As Integer
On Error Resume Next
iFileAttributes = GetAttr(sPathAndFullFileName)
'Check the internal error return
iError = Err.Number
Select Case iError
Case Is = 0
iFileAttributes = iFileAttributes And vbDirectory
If iFileAttributes = 0 Then
LJMFileExists = True
Else
LJMFileExists = False
End If
Case Else
LJMFileExists = False
End Select
On Error GoTo 0
End Function
Private Function LjmOpenOutlook( _
Optional iWindowState As Long = olMinimized, _
Optional bReleaseIt As Boolean = False _
) As Object
'This opens outlook if it is NOT already open
'Reference: http://www.rondebruin.nl/win/s1/outlook/openclose.htm
'Thank you Ron deBruin and Ben Clothier
'
'Late Binding is used in the following routines
Static myStaticOutlookObject As Object
On Error GoTo ERROR_HANDLER
Select Case True
Case myStaticOutlookObject Is Nothing, Len(myStaticOutlookObject.Name) = 0
Set myStaticOutlookObject = GetObject(, "Outlook.Application")
If myStaticOutlookObject.Explorers.Count = 0 Then
INIT_OUTLOOK:
'Open the Outlook inbox to prevent errors with security prompts
'Set the requested Outlook Windows state (i.e. Minimized, Maximized)
myStaticOutlookObject.Session.GetDefaultFolder(olFolderInbox).Display
myStaticOutlookObject.ActiveExplorer.WindowState = iWindowState
End If
Case bReleaseIt
'Clear the STATIC Outlook Object if requested by the input option
Set myStaticOutlookObject = Nothing
End Select
'Set the return value
Set LjmOpenOutlook = myStaticOutlookObject
GoTo MYEXIT
ERROR_HANDLER:
Select Case Err.Number
Case -2147352567
'User cancelled setup, silently exit
Set myStaticOutlookObject = Nothing
Case 429, 462
'Error 462 - Outlook is NOT open
Set myStaticOutlookObject = GetOutlookApp()
If myStaticOutlookObject Is Nothing Then
Err.Raise 429, "LjmOpenOutlook", "Outlook Application does not appear to be installed."
Else
Resume INIT_OUTLOOK
End If
Case Else
MsgBox "Error " & Err.Number & ": " & Err.Description, vbCritical, "Unexpected error attempting to OPen Outlook."
End Select
MYEXIT:
Exit Function
End Function
Lewis
The remainder of the code and code for CheckBoxes is in the next post due to size restrictions.
LinkBack URL
About LinkBacks
Register To Reply
Bookmarks