Hi All,
I have put together a vba script that runs two sql queries using the data to populate a html template and then call that template and email it to an email address from one of the queries, this does almost everything I want except that if the query PER has more than one line of data (which it does) it only shows the first line and none of the others
Here is the code that I am using
Any help with this problem and I will be extremely grateful. I have looked everywhere for a solution to no avail
Many Thanks
Diehippy
I have put together a vba script that runs two sql queries using the data to populate a html template and then call that template and email it to an email address from one of the queries, this does almost everything I want except that if the query PER has more than one line of data (which it does) it only shows the first line and none of the others
Here is the code that I am using
Code:
Private Sub Command4_Click()
On Error Resume Next
Dim objOutlook As Object
Dim objEmail As Object
Dim MyDb As DAO.Database
Dim rsEmail As DAO.Recordset
Dim PER As DAO.Recordset
'Dim sToName As String
'Dim sSubject As String
Dim sMessageBody, strCC
'Dim sImportance As String
'Dim sSentOnBehalfOfName As String
Dim apetext As Variant
Dim abdtext As Variant
Set MyDb = CurrentDb()
apetext = MyDb.QueryDefs("absence_parent_email_master").SQL
apetext = Replace(apetext, "@date", "'" & Me.AbsenceDate & "'")
MyDb.QueryDefs("absence_parent_email").SQL = apetext
Set rsEmail = MyDb.OpenRecordset("absence_parent_email", dbOpenDynaset)
Set objOutlook = CreateObject("Outlook.application")
'abdtext = MyDb.QueryDefs("absence_per_day_master").SQL
'abdtext = Replace(abdtext, "@date", "'" & Me.AbsenceDate & "'")
'MyDb.QueryDefs("absence_per_day").SQL = abdtext
'Set PER = MyDb.OpenRecordset("absence_per_day", dbOpenDynaset)
With rsEmail
.MoveFirst
Do Until rsEmail.EOF
abdtext = MyDb.QueryDefs("absence_per_day_master").SQL
abdtext = Replace(abdtext, "@date", "'" & Me.AbsenceDate & "'")
abdtext = Replace(abdtext, "@person_code", rsEmail!person_code)
MyDb.QueryDefs("absence_per_day").SQL = abdtext
Set PER = MyDb.OpenRecordset("absence_per_day", dbOpenDynaset)
Set objEmail = objOutlook.CreateItem(olMailItem)
sMessageBody = ReturnTemplate("ParentEmail")
'replace variables
sMessageBody = Replace(sMessageBody, "@FORENAME@", rsEmail!FORENAME)
sMessageBody = Replace(sMessageBody, "@SURNAME@", rsEmail!SURNAME)
sMessageBody = Replace(sMessageBody, "@PARENT_TITLE@", rsEmail!PARENT_TITLE)
sMessageBody = Replace(sMessageBody, "@PARENT_FORENAME@", rsEmail!PARENT_FORENAME)
sMessageBody = Replace(sMessageBody, "@PARENT_SURNAME@", rsEmail!PARENT_SURNAME)
sMessageBody = Replace(sMessageBody, "@TIMESTAMP@", Format(Now(), "dddd, d mmmm yyyy at h:nn am/pm"))
sMessageBody = Replace(sMessageBody, "@SONORDAUGHTER@", rsEmail!SONORDAUGHTER)
'Dim html As String
'html = "<html><body><table>"
'html = html & "<tr><td>" & PER.Fields(10).Value & "</td></tr>"
'html = html & "<tr><td>" & PER.Fields(11).Value & "</td></tr>"
'html = html & "<tr><td>" & PER.Fields(12).Value & "</td></tr>"
'html = html & "<tr><td>" & PER.Fields(13).Value & "</td></tr>"
'html = html & "<tr><td>" & PER.Fields(15).Value & "</td></tr>"
'html = html & "<tr><td>" & PER.Fields(7).Value & "</td></tr>"
'html = html & "</table></body></html>"
sMessageBody = Replace(sMessageBody, "@REG_DATE@", PER!REG_DATE)
sMessageBody = Replace(sMessageBody, "@DAY@", PER!Day)
sMessageBody = Replace(sMessageBody, "@STARTTIME@", PER!STARTTIME)
sMessageBody = Replace(sMessageBody, "@ENDTIME@", PER!ENDTIME)
sMessageBody = Replace(sMessageBody, "@COURSETITLE@", PER!COURSETITLE)
sMessageBody = Replace(sMessageBody, "@REGMARKDESCR@", PER!REGMARKDESCR)
'DoCmd.OutputTo acOutputQuery, PER, acFormatHTML, True, "N:\absence parent email\templates\parentmail.html"
With objEmail
If IsNull(rsEmail!parent_email) = False Then
.To = rsEmail!parent_email
.SentOnBehalfOfName = "absence@southdevon.ac.uk"
.Subject = "Student Absence Notification - " & rsEmail!FORENAME & " " & rsEmail!SURNAME & " ID:" & rsEmail!person_code
.Importance = olImportanceHigh
.HTMLbody = sMessageBody
.display
'DoCmd.SendObject acSendNoObject, , , _
'sToName, , , sSubject, HTMLbody, False, False
End If
End With
Set objEmail = Nothing
Set PER = Nothing
.MoveNext
Loop
End With
Set MyDb = Nothing
Set rsEmail = Nothing
Set objOutlook = Nothing
Set objEmail = Nothing
End Sub
I am also using a function called "ReturnTemplate" and here is the code for this
Public Function ReturnTemplate(sTemplate As String) As String
Dim fnum
Dim applicationPath As String
Dim filename As String
Dim InputText As String
Dim data As String
Select Case sTemplate
Case "ParentEmail"
filename = "parentemail.html"
End Select
If IsEmpty(filename) Then
MsgBox "Template cannot be found", vbExclamation + vbOKOnly, ""
Exit Function
End If
applicationPath = Application.CurrentProject.Path & "\templates\"
fnum = FreeFile()
Close fnum
Open applicationPath & filename For Input As fnum
While Not EOF(fnum)
Line Input #fnum, data
InputText = InputText & data & vbNewLine
Wend
Close #fnum
ReturnTemplate = InputText
End FunctionAny help with this problem and I will be extremely grateful. I have looked everywhere for a solution to no avail
Many Thanks
Diehippy