VBA To Create Email

I

IgnoranceIsBliss

Registered User.
Local time
Today, 15:13
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
 
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:
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
 
June7 said:
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
Click to expand...

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
 
Debug.Print strRS and see what that produces.?
 
Gasman said:
Debug.Print strRS and see what that produces.?
Click to expand...

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?
 
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:
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
 
Yes, please reread my post, i have edited it.
 
Oooops, common oversight of mine. I get caught in that infinite loop often enough, think I'd learn by now. Sorry.
 
You must log in or register to reply here.

Similar threads

M
VBA output report to PDF and email
Replies
18
Views
1,572
Pat Hartman
P
A
Solved Auto email error needed if attachment file doesn't exist or is named incorrectly
Replies
3
Views
497
theDBguy
theDBguy
A
Solved Problems with code execution following email
Replies
19
Views
842
Pat Hartman
P
J
Help with Email VBA
Replies
4
Views
861
Gasman
Gasman
A
Solved VBA Code to generate email and place query result in Message body
Replies
8
Views
1,258
Ashfaque
A

Users who are viewing this thread

Total: 1 (members: 0, guests: 1)
Back
Top Bottom