VBA To Create Email (1 Viewer)

IgnoranceIsBliss

Registered User.
Local time
Today, 11:02
Joined
Jun 13, 2019
Messages
35
Hi all - I have a Customers table that has roughly 4,000 rows in it (and growing). I am attempting to automate some things that are currently manually done.

Below is the process..
1) Query Table1 For all customers whose ContactFUTimeFrame is current month
2) Create Two groups of the current month customers
a. Group 1 = New Sale
b. Group 2 = Follow-Up
3) Capture the Contact Name, Contact Email and Folder Location for the Customer
4) Create an email Draft

I have put together this syntax, which debugs perfect, but when I attempt to press the button and hopefully have Drafts created, I get no draft created and no errors displayed.

Can someone help me here with what is going wrong with my code?

Code:
Option Compare Database
Private Sub Command2_Click()
Dim currMonth As String
Dim contact As String
Dim contactEmail As String
Dim customerFolder As String
Dim emailBody As String
Dim emailSubject As String
Dim rsNS As DAO.Recordset
Dim rsFU As DAO.Recordset
Dim nsAll As Variant
Dim fuAll As Variant
Dim ns As Variant
Dim fu As Variant

'Get current month
currMonth = MonthName(Month(Now), True)

'Create array to house New Sale for current month
Set rsNS = CurrentDb.OpenRecordset("Select ClientName FROM Table1 WHERE Mid(ContactFUTimeFrame, InStrRev(ContactFUTimeFrame, ' ') + 1) = " & currMonth & " And ContactType = 'New Sale'")
rsNS.MoveFirst
rsNS.MoveLast
nsAll = rsNS.GetRows(rsNS.RecordCount)

'Create Array to house Follow Up for current month
Set rsFU = CurrentDb.OpenRecordset("Select ClientName FROM Table1 WHERE Mid(ContactFUTimeFrame, InStrRev(ContactFUTimeFrame, ' ') + 1) = " & currMonth & " And ContactType = 'Follow-Up'")
rsFU.MoveFirst
rsFU.MoveLast
fuAll = rsFU.GetRows(rsFU.RecordCount)

'Iterate the array
For Each ns In nsAll
    'Grab the contact Name
    contact = DLookup("ClientContactName", "Table1", "ClientName = '" & CStr(ns) & "'")
    
    'Grabbing Customer Folder
    customerFolder = DLookup("LocalCustomerFolder", "Table1", "ClientName = '" & CStr(ns) & "'")
    
    'Grabbing Customer Email
    contactEmail = DLookup("ClientContactEmail", "Table1", "ClientName = '" & CStr(ns) & "'")
    
    'Check if Customer Name field has one name or multiple
    ValidateInput (contact)
    
    'If Not All take first name only
    If contact <> "All" Then
        contact = Left(contact, InStr(1, contact, " ") - 1)
    End If
    
    'Set email info
    emailBody = "<p>Hi " & contact & ",</p><p>Test test test test test test test test test test test test test.  Thanks!</p>"
    emailSubject = Year(Date) & " New Sale Information - " & CStr(ns)
    
    'Creating the email draft
    CreateEmail emailSubject, emailBody, customerFolder, contactEmail
Next


'Iterate the array
For Each fu In fuAll
    'Grab the contact Name
    contact = DLookup("ClientContactName", "Table1", "ClientName = '" & CStr(ns) & "'")
    
    'Grabbing Customer Folder
    customerFolder = DLookup("LocalCustomerFolder", "Table1", "ClientName = '" & CStr(ns) & "'")
    
    'Grabbing Customer Email
    contactEmail = DLookup("ClientContactEmail", "Table1", "ClientName = '" & CStr(ns) & "'")
    
    'Check if Customer Name field has one name or multiple
    ValidateInput (contact)
    
    'If Not All take first name only
    If contact <> "All" Then
        contact = Left(contact, InStr(1, contact, " ") - 1)
    End If
    
    'Set email info
    emailBody = "<p>Hi " & contact & ",</p><p>Test test test test test test test test test test test test test.  Thanks!</p>"
    emailSubject = Year(Date) & " Follow-Up Email - " & CStr(ns)
    
    'Creating the email draft
    CreateEmail emailSubject, emailBody, customerFolder, contactEmail
Next


End Sub
Private Function CreateEmail(emailSubject As String, emailBody As String, customerFolder As String, contactEmail As String)
    Set appOutLook = CreateObject("Outlook.Application")
    Set MailOutLook = appOutLook.CreateItem(olMailItem)
    
    With MailOutLook
        .BodyFormat = olFormatHTML
        .To = contactEmail
        .Subject = emailSubject
        .HTMLBody = emailBody
        .Save
    End With
End Function
Private Function ValidateInput(cn As String)
If InStr(cn, ",") = 0 Then
    contactName = cn
Else
    contactName = "All"
End If
End Function
 

June7

AWF VIP
Local time
Today, 10:02
Joined
Mar 9, 2014
Messages
5,423
You say code has no compile errors but have you stepped through code?

ValidateInput function is not needed.

Your table is actually named "Table1"? Hardly informative.

Why use DLookup? Why not include those fields in the recordset?

People name parts really should be saved in separate fields. It is easier to concatenate than split apart.

This can be accomplished without arrays.

Use .Close to automatically save into Draft folder.

You want individual email to each contact? Or a single email to multiple addresses?

Consider:

Code:
Option Compare Database
Option Explicit

Private Sub Command2_Click()
Dim currMonth As String
'Get current month
currMonth = MonthName(Month(Now), True)
CreateEmail "Select ClientName, ClientContactName, LocalCustomerFolder, ClientContactEmail FROM Table1 WHERE Mid(ContactFUTimeFrame, InStrRev(ContactFUTimeFrame, ' ') + 1) = " & currMonth & " And ContactType = 'New Sale'"
CreateEmail "Select ClientName, ClientContactName, LocalCustomerFolder, ClientContactEmail FROM Table1 WHERE Mid(ContactFUTimeFrame, InStrRev(ContactFUTimeFrame, ' ') + 1) = " & currMonth & " And ContactType = 'Follow-Up'"
End Sub

Private Sub CreateEmail(strRS As String)
Dim contact As String
Dim emailBody As String
Dim appOutlook As Outlook.Application
Dim MailOutlook As Outlook.MailItem
Dim rs As DAO.Recordset
Set appOutlook = CreateObject("Outlook.Application")
Set MailOutlook = appOutlook.CreateItem(olMailItem)
Set rs = CurrentDb.OpenRecordset(strRS)
Do While Not rs.EOF
    'Grab the contact Name
    contact = rs!ClientContactName
    If InStr(contact, ",") = 0 Then
        contact = Left(contact, InStr(1, contact, " ") - 1)
    End If
    'Set email info
    emailBody = "<p>Hi " & contact & ",</p><p>Test test test test test test test test test test test test test.  Thanks!</p>"
    With MailOutlook
        .BodyFormat = olFormatHTML
        .To = rs!ClientContactEmail
        .Subject = Year(Date) & " New Sale Information - " & rs!ClientName
        .HTMLBody = emailBody
        .Save
        .Close olSave
    End With
Loop
End Sub
 
Last edited:

CJ_London

Super Moderator
Staff member
Local time
Today, 18:02
Joined
Feb 19, 2013
Messages
16,553
try putting option explicit under option compare database - think you will then find plenty of compilation errors.

suspect you are getting contact and contactname mixed up since I cannot see any reason for calling your validateinput function

Also agree with June - step through the code and check values as you go
 

IgnoranceIsBliss

Registered User.
Local time
Today, 11:02
Joined
Jun 13, 2019
Messages
35
You say code has no compile errors but have you stepped through code?

ValidateInput function is not needed.

Your table is actually named "Table1"? Hardly informative.

Why use DLookup? Why not include those fields in the recordset?

People name parts really should be saved in separate fields. It is easier to concatenate than split apart.

This can be accomplished without arrays.

Use .Close to automatically save into Draft folder.

You want individual email to each contact? Or a single email to multiple addresses?

Consider:

Code:
Option Compare Database
Option Explicit

Private Sub Command2_Click()
Dim currMonth As String
'Get current month
currMonth = MonthName(Month(Now), True)
CreateEmail "Select ClientName, ClientContactName, LocalCustomerFolder, ClientContactEmail FROM Table1 WHERE Mid(ContactFUTimeFrame, InStrRev(ContactFUTimeFrame, ' ') + 1) = " & currMonth & " And ContactType = 'New Sale'"
CreateEmail "Select ClientName, ClientContactName, LocalCustomerFolder, ClientContactEmail FROM Table1 WHERE Mid(ContactFUTimeFrame, InStrRev(ContactFUTimeFrame, ' ') + 1) = " & currMonth & " And ContactType = 'Follow-Up'"
End Sub

Private Sub CreateEmail(strRS As String)
Dim contact As String
Dim emailBody As String
Dim appOutlook As Outlook.Application
Dim MailOutlook As Outlook.MailItem
Dim rs As DAO.Recordset
Set appOutlook = CreateObject("Outlook.Application")
Set MailOutlook = appOutlook.CreateItem(olMailItem)
Set rs = CurrentDb.OpenRecordset(strRS)
Do While Not rs.EOF
    'Grab the contact Name
    contact = rs!ClientContactName
    If InStr(contact, ",") = 0 Then
        contact = Left(contact, InStr(1, contact, " ") - 1)
    End If
    'Set email info
    emailBody = "<p>Hi " & contact & ",</p><p>Test test test test test test test test test test test test test.  Thanks!</p>"
    With MailOutlook
        .BodyFormat = olFormatHTML
        .To = rs!ClientContactEmail
        .Subject = Year(Date) & " New Sale Information - " & rs!ClientName
        .HTMLBody = emailBody
        .Save
        .Close olSave
    End With
Loop
End Sub

Hi - I like your approach much better! I finally have had a moment to test the code, but I am getting a debug error of on the Set rs line....
Run-time error '3061':

Too few parameters. Expected 1

And this is the syntax I am using (with actual field names since I know realize that matters)....
Code:
Function Test()
Dim currMonth As String
currMonth = MonthName(Month(Now), True)
CreateEmail "Select [_Parent Info].CompanyName, [_Parent Info].[Main Contact], [_LocalData].CF FROM [_Parent Info] Inner Join [_LocalData] ON [_Parent Info].CompanyName = [_LocalData].Company Where Mid([Status], InStrRev([Status], ' ') + 1) = " & currMonth & "
End Test

Sub CreateEmail (strRS As String)
Dim contact As String
Dim emailBody As String
Dim appOutlook As Outlook.Application
Dim MailOutlook As Outlook.MailItem
Dim rs As DAO.Recordset
Set appOutlook = CreateObject("Outlook.Application")
Set MailOutlook = appOutlook.CreateItem(olMailItem)
Set rs = CurrentDb.OpenRecordset(strRS)
End Sub
 

Gasman

Enthusiastic Amateur
Local time
Today, 18:02
Joined
Sep 21, 2011
Messages
14,046
Debug.Print strRS and see what that produces.?
 

IgnoranceIsBliss

Registered User.
Local time
Today, 11:02
Joined
Jun 13, 2019
Messages
35
Debug.Print strRS and see what that produces.?

Ah-hah! That showed me I was missing the single quotes around the month!

Onto my last issue....
This code works, creates drafts, but it just constantly loops through the recordset never stopping. For example, If I copy/paste the strRS into a query window it produces two results. However, for some reason the code just continues to process repeatedly?
 

Gasman

Enthusiastic Amateur
Local time
Today, 18:02
Joined
Sep 21, 2011
Messages
14,046
You need to show the code?
From what you have posted it would just create a blank email.?

Most likely you are not checking for .EOF or not issuing a .MoveNext if you are?

Why not look at what June7 has posted?

Edit: Ah, there is a .MoveNext missed from there?

Code:
Do While Not rs.EOF
    'Grab the contact Name
    contact = rs!ClientContactName
    If InStr(contact, ",") = 0 Then
        contact = Left(contact, InStr(1, contact, " ") - 1)
    End If
    'Set email info
    emailBody = "<p>Hi " & contact & ",</p><p>Test test test test test test test test test test test test test.  Thanks!</p>"
    With MailOutlook
        .BodyFormat = olFormatHTML
        .To = rs!ClientContactEmail
        .Subject = Year(Date) & " New Sale Information - " & rs!ClientName
        .HTMLBody = emailBody
        .Save
        .Close olSave
    End With
    [COLOR="Red"]rs.MoveNext[/COLOR]
Loop

HTH
 
Last edited:

IgnoranceIsBliss

Registered User.
Local time
Today, 11:02
Joined
Jun 13, 2019
Messages
35
I am using the syntax June7 posted. This is the code that I have, excluding the recordset being passed in which I verified is valid.

Code:
Private Sub CreateEmail(strRS As String)
Dim contact As String
Dim emailBody As String
Dim appOutlook As Outlook.Application
Dim MailOutlook As Outlook.MailItem
Dim rs As DAO.Recordset
Set appOutlook = CreateObject("Outlook.Application")
Set MailOutlook = appOutlook.CreateItem(olMailItem)
Set rs = CurrentDb.OpenRecordset(strRS)
Do While Not rs.EOF
    'Grab the contact Name
    contact = rs!ClientContactName
    If InStr(contact, ",") = 0 Then
        contact = Left(contact, InStr(1, contact, " ") - 1)
    End If
    'Set email info
    emailBody = "<p>Hi " & contact & ",</p><p>Test test test test test test test test test test test test test.  Thanks!</p>"
    With MailOutlook
        .BodyFormat = olFormatHTML
        .To = rs!ClientContactEmail
        .Subject = Year(Date) & " New Sale Information - " & rs!ClientName
        .HTMLBody = emailBody
        .Save
        .Close olSave
    End With
Loop
End Sub
 

Gasman

Enthusiastic Amateur
Local time
Today, 18:02
Joined
Sep 21, 2011
Messages
14,046
Yes, please reread my post, i have edited it.
 

June7

AWF VIP
Local time
Today, 10:02
Joined
Mar 9, 2014
Messages
5,423
Oooops, common oversight of mine. I get caught in that infinite loop often enough, think I'd learn by now. Sorry.
 

Users who are viewing this thread

Top Bottom