Private Sub Send_Mail_Click() On Error GoTo Err_SendEmail Dim sTo As String Dim sCC As String Dim sBCC As String Dim sSubject As String Dim sBody As String Dim sAttachmentList As String Dim sReplyRecipient As String Dim oFSO As New FileSystemObject Dim oFS Dim db As DAO.Database Dim qryMail As QueryDef Dim MailList As DAO.Recordset ' this is a test to make sure the type of customer is chosen otherwise exit ' If Me.Choice = "" Then ' from form MsgBox " You have to select a customer status " GoTo Exit_SendEmail End If ' ' You must key a semicolon between each email name ' sTo = "" sCC = "" sBCC = "" sReplyRecipient = "firstname.lastname@example.org" sSubject = Me.Mess_Subject ' from form sBody = Me.mess_text ' from form ' 'Path to the text file If Left(Me.Mail_Attachment_Path, 1) <> "<" Then Attachment = Me.Mail_Attachment_Path Attachment = 1 Else Attachment = 0 End If ' ' does attachment exist ' If Dir(Attachment) = "" Then MsgBox "Document not found. Please check path" Attachment = 0 End If ' ' Set up the database and query connections ' Set db = CurrentDb 'chosen database ' define query to be used from database Set qryMail = db.QueryDefs("MyEmailAddresses") ' Set MailList = qryMail.OpenRecordset ' ' now, this is where we go through our list of addresses, ' adding them to the sCC list ' LOOP through all the emails on the list ' Do While Not MailList.EOF If MailList![Status] = Me.Choice Then NewEmail = MailList![EmailAddress] sBCC = sBCC & ";" & NewEmail End If MailList.MoveNext Loop ' 'send email but first check if there is an attachment If Attachment = 0 Then ' send without a file attachment Call SetupOutlookEmail(sTo, sCC, sBCC, sReplyRecipient, sSubject, sBody) Else ' send with a file attachment Call SetupOutlookEmail(sTo, sCC, sBCC, sReplyRecipient, sSubject, sBody, sAttachmentList) End If Exit_SendEmail: Exit Sub Err_SendEmail: If Err.Number = -2147024894 Then 'Cannot find this file. Verify the path and file name are correct. MsgBox "Email message was not sent. Please verify the file " & sPathFile & " exists before attempting to resend the email.", vbCritical, "Invalid File Attachment" Exit Sub ElseIf Err.Number = -2147467259 Then 'Outlook does not recognize one or more names. MsgBox "Email message was not sent. Please verify all user names and email addresses are valid before attempting to resend the email.", vbCritical, "Invalid Email Name" Exit Sub Else Call ErrorHandling(Err.Number, Err.Description, "sendmail_Click", "2-Email_clients_Monthly") Resume Exit_SendEmail End If End Sub ---------------------------------------------- sendoutlookemail proc Public Function SetupOutlookEmail(ByVal sTo As String, ByVal sCC As String, ByVal sBCC As String, ByVal sReplyRecipient As String, ByVal sSubject As String, ByVal sBody As String, ParamArray sAttachmentList() As Variant) As Boolean On Error GoTo Err_SetupOutlookEmail Dim objOLApp As Object Dim outItem As Object Dim outFolder As Object Dim DestFolder As Object Dim outNameSpace As Object Dim lngAttachment As Long Set objOLApp = CreateObject("Outlook.Application") Set outNameSpace = objOLApp.GetNamespace("MAPI") Set outFolder = outNameSpace.GetDefaultFolder(6) Set outItem = objOLApp.CreateItem(0) outItem.To = sTo outItem.CC = sCC outItem.BCC = sBCC outItem.Subject = sSubject outItem.Body = sBody outItem.ReplyRecipients.Add sReplyRecipient outItem.ReadReceiptRequested = False With outItem.Attachments For lngAttachment = LBound(sAttachmentList) To UBound(sAttachmentList) .Add sAttachmentList(lngAttachment) Next lngAttachment End With ' outItem.Send outItem.Display 'setup and open email in edit mode instead of sending the email SetupOutlookEmail = True Exit_SetupOutlookEmail: On Error Resume Next Set outItem = Nothing Set outFolder = Nothing Set outNameSpace = Nothing Set objOLApp = Nothing Exit Function Err_SetupOutlookEmail: If Err.Number = 287 Then 'User stopped Outlook from sending email. MsgBox "User aborted email.", vbInformation, "Email Cancelled" Resume Exit_SetupOutlookEmail Else Call ErrorHandling(Err.Number, Err.Description, "SetupOutlookEmail module", "Function in Main_window_Open_Module") Resume Exit_SetupOutlookEmail End If End Function
Join the community of 500,000 technology professionals and ask your questions.
Connect with top rated Experts
21 Experts available now in Live!