I have written a routine to send emails to members.
Basically the routine creates a table containing members who will receive an email.
The routine copies the 1st record to another table, exports that record to excel, calls a word document and populates it with the excel data, saves the word document as a pdf file and emails the pdf file to the relevant member showing the data held. The 1st record in the main table is deleted and the routine loops back to the start to process the 2nd record etc etc.
The routine works fine and produces exactly what I am after but it takes a few minutes to run for approx 80 members.
I would appreciate it if anyone would look at my code and suggest improvements to it especially pointing out things that I may only need to run once at the beginning rather than repeating it for every record.
Hi, is this code any better? Can anyone help please? I can email the code if that would be easier.
Sub EmailMembershipForms()
'
' Set the variables
'
Dim Count As Integer ' number of records in "Send email to current players to update details totals query"
Dim EmailAddress As String ' email address to send player email to
Dim frmCurrentForm As Form
Dim i As Integer ' fields count in raAll
Dim mailmergedoc As String ' location of mailmerge document
Dim mailmergepdf As String ' location of mailmerge pdf document
mailmergepdf = "C:\Xxxxx\Players database\Updates to data\Membership form.pdf"
Dim mailmergexls As String ' location of mailmerge spreadsheet
mailmergexls = "C:\Xxxxx\Players database\Updates to data\Membership Form - Mailmerge data.xlsx"
Dim msgStr As String ' message re mem cat totals
Dim MyDB As DAO.Database ' Database definition
Set MyDB = CurrentDb ' Set current database
Dim oMail As Object ' Outlook email application
Dim oOutlook As Object ' Outlook email application
Dim rsAll As DAO.Recordset ' records from "Updatedetailsall"
Dim rsOne As DAO.Recordset ' records from "Updatedetailsone"
Dim rsMemCatTotals As DAO.Recordset ' records from "Send email to current players to update details totals query"
Dim sMsgBody As String ' Email body
Dim wordApp As Object ' Word application
Dim wordDoc As Object ' Word application
'
' Run queries to clear Updatedetailsone and Updatedetailsall
' Run query to create Updatedetailsall
'
DoCmd.SetWarnings False
DoCmd.OpenQuery "Update details one delete query"
DoCmd.OpenQuery "Update details all delete query"
Set frmCurrentForm = Screen.ActiveForm
If frmCurrentForm.Name = "People maintenance" Then
DoCmd.OpenQuery "Send email to current players to update details single query"
End If
If frmCurrentForm.Name = "Bulk emails" Then
DoCmd.OpenQuery "Send email to current players to update details query"
End If
'
' Display message re analysis of membership categories
'
Set rsMemCatTotals = MyDB.OpenRecordset("Send email to current players to update details totals query")
Do While Not rsMemCatTotals.EOF
msgStr = msgStr & rsMemCatTotals.Fields("Membership Category") & " " & rsMemCatTotals.Fields("Count") & vbCrLf
Count = Count + rsMemCatTotals.Fields("Count")
rsMemCatTotals.MoveNext
Loop
Set rsAll = MyDB.OpenRecordset("Updatedetailsall")
Set rsOne = CurrentDb.OpenRecordset("SELECT * FROM Updatedetailsone")
MsgBox msgStr & vbCrLf & "Analysis Of Membership Categories = " & Count & vbCrLf & vbCrLf & "Total Players Selected = " & (rsAll.RecordCount) & vbCrLf & vbCrLf & "PLEASE ENSURE TOTALS BALANCE. IF THEY DO NOT, THERE ARE ERRORS WITH MEMBERSHIP CATEGORY.", , "Send email to current players to update details"
'
' If no records in Updatedetailsall display message and end routine
'
If rsAll.RecordCount = 0 Then
MsgBox "No players meet the specified criteria", , "Send email to current players to update details"
GoTo NoData
End If
'
' Open Updatedetailsall table to allow selection of players to send email to
'
DoCmd.OpenForm "Updatedetailsall", WindowMode:=acDialog
'
' Delete players with no email addresses (should never be any as validation on people maintenance form does not allow this
' but leave it in as an additional check)
'
DoCmd.OpenQuery "Delete players with no email address query"
'
' Move 1st record in Updatedetailsall to Updatedetailsone
' Delete 1st record from UpdatedetailsAll
'
If MsgBox(rsAll.RecordCount & " email(s) will be sent." & vbCrLf & "Are you sure you want to send it/them?", vbYesNo, "Send email to current players to update details") = vbYes Then
With rsAll
Do Until .EOF = True
Set rsOne = CurrentDb.OpenRecordset("SELECT * FROM Updatedetailsone")
Set rsAll = CurrentDb.OpenRecordset("SELECT * FROM Updatedetailsall")
rsAll.MoveLast
rsAll.MoveFirst
rsOne.AddNew
For i = 0 To rsAll.Fields.Count - 1
rsOne.Fields(i).Value = rsAll.Fields(i).Value
Next
rsOne.Update
With rsAll
rsOne.MoveFirst
.FindFirst "ID = " & rsOne![ID]
.Delete
End With
'
' Set files to use depending on membership category
'
If rsOne![Membership Category] = "Junior Player" Or rsOne![Membership Category] = "Junior Player (Sibling)" Then
mailmergedoc = "C:\Xxxxx\Players database\Updates to data\Junior Player Membership Form - Mailmerge.docx"
Else
mailmergedoc = "C:\Xxxxx\Players database\Updates to data\Adult Player Membership Form - Mailmerge.docx"
End If
'
' Delete existing mailmerge spreadsheet data file
' Create new mailmerge spreadsheet file with current record
'
Kill mailmergexls
DoCmd.TransferSpreadsheet _
acExport, _
acSpreadsheetTypeExcel12Xml, _
"Updatedetailsone", _
mailmergexls, True
'
' Merge Word document with mailmerge spreadsheet file
'
Set wordApp = CreateObject("Word.Application")
wordApp.Visible = True
Set wordDoc = wordApp.Documents.Open(mailmergedoc)
With wordDoc.MailMerge
.MainDocumentType = wdMailingLetters
.OpenDataSource Name:=mailmergexls, _
ConfirmConversions:=False, _
ReadOnly:=False, _
LinkToSource:=False, _
AddToRecentFiles:=False, _
sqlstatement:="select * from [Updatedetailsone]"
.Destination = wdSendToNewDocument
.Execute
.MainDocumentType = wdNotAMergeDocument
End With
'
' Delete existing membership form PDF file
' Create new membership form PDF file with current record
'
Kill mailmergepdf
wordApp.ActiveDocument.SaveAs2 mailmergepdf, 17
'
' Close and clean up Word documents
'
For Each wordDoc In wordApp.Documents
wordDoc.Close SaveChanges:=False
Next wordDoc
wordApp.Quit
Set wordDoc = Nothing
Set wordApp = Nothing
'
' Send email
'
Set oOutlook = CreateObject("Outlook.Application")
Set oMail = oOutlook.CreateItem(0)
sMsgBody = "Hello " & rsOne![People_Forename] & "," & vbCr & vbCr
sMsgBody = sMsgBody & "The Club is carrying out an exercise to ensure that all of the personal data you previously provided using the Club's player membership form is still accurate and up to date." & vbCr & vbCr
sMsgBody = sMsgBody & "Attached is a PDF file which contains your current player membership form data." & vbCr & vbCr
sMsgBody = sMsgBody & "It would be greatly appreciated if you would reply to this email confirming whether your data is still accurate and up to date or, if it is not, provide the Club with the relevant amendments." & vbCr & vbCr
sMsgBody = sMsgBody & "Thank you for your help in this matter." & vbCr & vbCr
'
' Email addresses must be checked in this order
'
If Not IsNull(rsOne![People_2_Email Address]) Then
EmailAddress = rsOne![People_2_Email Address]
End If
If Not IsNull(rsOne![People_1_Email Address]) Then
EmailAddress = rsOne![People_1_Email Address]
End If
If Not IsNull(rsOne![People_Email Address]) Then
EmailAddress = rsOne![People_Email Address]
End If
With oMail
.SentOnBehalfOfName = "Xxxxx <[email protected]>"
.To = EmailAddress
.Subject = "Xxxxx - Personal Data"
.Body = sMsgBody
.Attachments.Add mailmergepdf
.send
End With
ValidEmails = ValidEmails + 1
.MoveNext
DoCmd.OpenQuery "Update details one delete query"
Loop
'
' Display number of emails sent message
'
MsgBox ValidEmails & " email(s) sent successfully", , "Send email to current players to update details"
End With
'
'Clean up
'
End If
NoData:
Set oMail = Nothing
Set oOutlook = Nothing
rsAll.Close
Set rsAll = Nothing
rsOne.Close
Set rsOne = Nothing
End Sub
