Mark Drelinger
asked on
Macro to Send email for each record in Access database
I would like to create a macro that sends an email for each individual record in a database. There may not always be records in the database. Each database record includes an email address and some machine data (see attqached). This wouold be for internal use only so an smtp server is available
Is this possible?
db1.mdb
Is this possible?
db1.mdb
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
You can add more information to the message body from various fields in the recordset.
ASKER
perfect.. thank you.
If you need to send a file as an attachment to each email, here is some code for that (it will run in Access 2007 or higher, as those versions have build-in PDF support). The code creates a filtered report for each recipient, saves it as a PDF, and attaches it to the email:
Public Sub SendInterventionEmails()
'Created by Helen Feddema 10-Jan-2010
'Last modified by Helen Feddema 10-Jan-2010
On Error GoTo ErrorHandler
Dim appOutlook As New Outlook.Application
Dim itm As Outlook.MailItem
Dim rstIntervention As DAO.Recordset
Dim lngCount As Long
Dim lngID As Long
Dim rpt As Access.Report
Dim strFileName As String
Dim strPrompt As String
Dim strQuery As String
Dim strRecordSource As String
Dim strReport As String
Dim strSQL As String
Dim strTitle As String
Dim strCurrentPath As String
Dim strFileNameAndPath As String
Dim strEmailSource As String
strEmailSource = "qryInterventionEmail"
strRecordSource = "qryMissingAssignments"
strQuery = "qryMissingAssignmentsSingleStudent"
Set dbs = CurrentDb
Set rstIntervention = dbs.OpenRecordset(strEmailSource)
strCurrentPath = Application.CurrentProject.Path & "\"
'Use path selected with SelectFolder procedure
'strCurrentPath = SelectFolder()
With rstIntervention
Do While Not .EOF
lngID = ![StID]
Debug.Print "Processing Student ID " & lngID
strFileName = "Intervention Report for " & ![StFirst] _
& " " & ![StLast] & ".pdf"
strFileNameAndPath = strCurrentPath & strFileName
'Create filtered query
strSQL = "SELECT * FROM " & strRecordSource & " WHERE " _
& "[StID] = " & Chr(39) & lngID & Chr(39) & ";"
Debug.Print "SQL for " & strQuery & ": " & strSQL
lngCount = CreateAndTestQuery(strQuery, strSQL)
Debug.Print "No. of items found: " & lngCount
If lngCount = 0 Then
GoTo NextStudent
End If
'Open report with filtered query record source
strReport = "rptMissingAssignmentsNew"
DoCmd.OpenReport ReportName:=strReport, _
View:=acViewPreview, _
windowmode:=acWindowNormal
Set rpt = Reports(strReport)
DoCmd.OutputTo objecttype:=acOutputReport, _
objectname:=strReport, _
outputformat:=acFormatPDF, _
outputfile:=strFileNameAndPath
'Create email
Set itm = appOutlook.CreateItem(olMailItem)
itm.Subject = "MISSING WORK"
itm.Body = "The attached file lists your missing assignments"
itm.To = ![Email]
itm.Attachments.Add Source:=strFileNameAndPath, _
Type:=olByValue
'For editing before sending
itm.Display
'For sending automatically
'itm.Send
DoCmd.Close objecttype:=acReport, _
objectname:=strReport, _
Save:=acSaveNo
NextStudent:
.MoveNext
Loop
End With
ErrorHandlerExit:
Exit Sub
ErrorHandler:
MsgBox "Error No: " & Err.Number _
& " in SendInterventionEmails procedure; " _
& "Description: " & Err.Description
Resume ErrorHandlerExit
End Sub
Public Function CreateAndTestQuery(strTestQuery As String, _
strTestSQL As String) As Long
'Created by Helen Feddema 28-Jul-2002
'Last modified by Helen Feddema 10-Jan-2010
On Error Resume Next
'Delete old query
Set dbs = CurrentDb
dbs.QueryDefs.Delete strTestQuery
On Error GoTo ErrorHandler
'Create new query
Set qdf = dbs.CreateQueryDef(strTestQuery, strTestSQL)
'Test whether there are any records
Set rst = dbs.OpenRecordset(strTestQuery)
With rst
.MoveFirst
.MoveLast
CreateAndTestQuery = .RecordCount
End With
ErrorHandlerExit:
Exit Function
ErrorHandler:
If Err.Number = 3021 Then
CreateAndTestQuery = 0
Resume ErrorHandlerExit
Else
MsgBox "Error No: " & Err.Number _
& " in CreateAndTestQuery procedure; " _
& "Description: " & Err.Description
End If
End Function
ASKER
I have an error that I haven't figured out from the code above: "user defined type not defined". any insight ?