Access VBA

Send eMail from Access

' Purpose   : Gather emails based on club checked and set BCC blast
'---------------------------------------------------------------------------------------
'
Private Sub cmdCreateEmail_Click()
    Dim RS          As Recordset
    Dim dB          As Database
    Dim CT          As Recordset
    Dim strEmail    As String
    Dim strMsg      As String
    Dim EmailList   As String
    Dim objRecipient As Outlook.Recipient
    Dim oLook       As Outlook.Application
    Dim oMail       As Outlook.MailItem
    Dim oAccount    As Outlook.Account
    Dim oNs      As Outlook.NameSpace
    Dim sqlString   As String
    Dim MsgBody     As String
    Dim CountString As String
    Dim X           As Long
    Dim Z           As Long
   On Error GoTo cmdCreateEmail_Click_Error

    If Me.MsgSubject = Null Then        'Force msg to have subject
        MsgBox "Please type a Subject for this email and continue", vbInformation, "Subject ??"
        Exit Sub
    End If
    Set dB = CurrentDb()                                   'For RecordSet
    Set oLook = Outlook.Application                 'Reference
    Set oNs = oLook.GetNamespace("Mapi")    'Set msg type
    EmailList = ""  			    'Empty from prev
    CountString = "SELECT COUNT (*) as RecsCount FROM NamesMaster AS NM LEFT ↩
JOIN  (LocalMembership AS LM LEFT JOIN tblEmailAddresses AS EmailA " _
        & " ON LM.MemberID = EmailA.MemberID) ON NM.ID = LM.MemberID  WHERE  ↩
(((EmailA.Prefered)=True) AND ((NM.Deceased)=False) AND ((LM.ClubID)=" _
        & Me.ClubName.Value & ") AND ((LM.InUse)=1)); "
    Set CT = dB.OpenRecordset(CountString, dbOpenDynaset)
    Z = CT.Fields("RecsCount")                        'Determine number of records
    If Z < 1 Then GoTo cmdCreateEmail_Click_Error
            Set oMail = oLook.CreateItem(olMailItem)
                                          'Recordset to get mail recipients
    sqlString = "SELECT  * FROM NamesMaster AS NM LEFT JOIN  (LocalMembership  ↩
AS LM LEFT JOIN tblEmailAddresses AS EmailA ON LM.MemberID = EmailA.MemberID)  ↩
ON NM.ID = LM.MemberID "
    sqlString = sqlString & " WHERE (((EmailA.Prefered)=True) AND ((NM.Deceased)=False)  ↩
AND ((LM.ClubID)=" & Me.ClubName.Value & ") AND ((LM.InUse)=1)); "
    Set RS = dB.OpenRecordset(sqlString, dbOpenDynaset)
        RS.MoveFirst
        Do While Not RS.EOF
                                    'do the mailing thing
        EmailList = EmailList & RS.Fields("EmailAddress") & ";"
  '+-------------------------------------------------------------------
            RS.MoveNext
        Loop
    With oMail
        MsgBody = "<p>" & Me.EmailMsg & "</p><p>------------</p><p>" & Me.ContactName.Value
        MsgBody = MsgBody & "<br />" & Me.ContactEmail.Value & "</p>"
        .BCC = EmailList
        .HTMLBody = MsgBody
        .Subject = Me.MsgSubject.Value
        .SendUsingAccount = oNs.Accounts(Me.ContactEmail.Value)
        .ReminderSet = True
            If Me.bPreview = 1 Then
                .display
            Else
                .Send
            End If
    End With

    If bPreview = False Then

End If
   
   '+------------------------------------------------------------------------------
   Set CT = dB.OpenRecordset("tblEmailMsg", dbOpenDynaset)
    With CT
        .AddNew
        !EmailMsg = MsgBody
        !Subject = Me.MsgSubject.Value
        !ClubID = Me.ClubName.Value
        !From = Me.ContactName.Value
        !fromEmail = Me.ContactEmail.Value
        .Update
    End With
    Set CT = Nothing

   Set RS = Nothing
   Set dB = Nothing
    Set oMail = Nothing
    Set oLook = Nothing
   On Error GoTo 0
   Exit Sub

cmdCreateEmail_Click_Error:

    MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure  ↩
	cmdCreateEmail_Click of VBA Document Form_frmWriteEmail"
End Sub