D
Dale
Access 2000
My query returns all members whose certification expires
prior to a specifed date
(studentID,certlevel,certExp,email1)
My objective is from a single button click open a report
(rptCertExp_1) for only the 1st student, email the report
(preferably HTML format and Preferably in the body of the
email, however an attachment will work also), close the
report, and loop back to the 2nd student, etc...
The student should receive an individualized report as
their certifications and expiration dates varies. This
report also shows their "Total hours of training".
I am using Jmail (1st Time) so that my users are not
dependant upon Outlook and to get around the new Outlook
security.
Ihave my email loop working but can not figure out the
report issue.
1) Can the reports record source be the same record set
as my email loop uses? If so, How would I code it?
This is what I have so far:
Private Sub Command15_Click()
On Local Error GoTo Some_Err
Dim MyDB As Database, RS As Recordset
Dim strBody As String, lngCount As Long, lngRSCount
As Long
Dim strMsg As String
Dim strServer As String
Dim strUser As String
Dim strPassword As String
Dim strFrom As String
Dim strReplyTo As String
Dim strRecip As String
Dim strCC As String
Dim strBCC As String
Dim strSubject As String
DoCmd.RunCommand acCmdSaveRecord
Set MyDB = DBEngine.Workspaces(0).Databases(0)
Me!txtProgress = Null
Set RS = MyDB.OpenRecordset("qEmail_1")
'lngRSCount = RS.RecordCount
lngRSCount = RS.RecordCount
If lngRSCount = 0 Then
MsgBox "No email messages to send.", vbInformation
Else
RS.MoveLast
RS.MoveFirst
Do Until RS.EOF
lngCount = lngCount + 1
lblStatus.Caption = "Writing Message " & CStr
(lngCount) _
& " of " & CStr(lngRSCount) & "..."
strTo = RS!E_Mail
intMessageID = Year(Now) & Month(Now) & Day(Now)
& Fix(Timer) & "_MabryMail"
' Send the email using some technique or other
'MsgBox "Sent Mail Dummy"
' Verify that all critical information was passed
' Server is required
strServer = Nz(Me.MSMTP, "")
If Len(strServer) = 0 Then
strMsg = "Must enter a valid SMTP Server"
MsgBox strMsg, vbExclamation, "Error"
Me.lblMsg.Caption = strMsg
'Me.MSMTP.SetFocus
Exit Sub
End If
' User may be blank for purpose of this test
strUser = Nz(Me.MUSERID, "")
' Password may be blank for purpose of this test
strPassword = Nz(Me.MUPassword, "")
strFrom = Nz(Me.MFrom, "")
If Len(strFrom) = 0 Then
strMsg = "Must enter a valid From Address (or
Mail User Name)"
MsgBox strMsg, vbExclamation, "Error"
Me.lblMsg.Caption = strMsg
'Me.MFrom.SetFocus
Exit Sub
End If
' ReplyTo is From address unless otherwise defined
strReplyTo = Nz(Me.MReply, "")
If Len(strServer) = 0 Then strReplyTo = strFrom
strRecip = strTo
If Len(strRecip) = 0 Then
strMsg = "Must enter a valid Recipient in format
(e-mail address removed)"
MsgBox strMsg, vbExclamation, "Error"
Me.lblMsg.Caption = strMsg
'Me.txtRecipient.SetFocus
Exit Sub
End If
' Check format of recipient address for
(e-mail address removed)
If InStr(1, strRecip, "@") = 0 And InStr(1,
strRecip, ".") = 0 Then
strMsg = "Enter Recipient in proper format:
(e-mail address removed)"
MsgBox strMsg, vbExclamation, "Error"
Me.lblMsg.Caption = strMsg
'Me.txtRecipient.SetFocus
Exit Sub
End If
' Subject Defaults to "Hello from DataFast"
strSubject = Nz(Me.txtSubject, "")
If Len(strSubject) = 0 Then strSubject = "Hello from
M-Tech"
' Body Defaults to "This is a test of the DataFast
Mail system."
strBody = Nz(Me.txtBody, "")
If Len(strBody) = 0 Then strBody = "This is a test of
the M-Tech Tracker Mail system."
' We have collected all required information and set
missing
' arguments to their defaults. We may now continue
' ////////////////////////////////////////////////////////
//////////////////////////
'
' BEGIN MAIL CODE HERE
'
DoCmd.Hourglass True
Dim jmail As jmail.Message
Set jmail = New jmail.Message
If Len(strUser) Then jmail.MailServerUserName =
strUser
If Len(strPassword) Then jmail.MailServerPassWord =
strPassword
jmail.From = strFrom
jmail.ReplyTo = strReplyTo
jmail.AddRecipient strRecip
If Len(strCC) Then jmail.AddRecipientCC strCC
If Len(strBCC) Then jmail.AddRecipientBCC strBCC
jmail.Subject = strSubject
jmail.Body = strBody
jmail.Priority = 1
' Send it...
jmail.Send (strServer)
strMsg = jmail.Log
'If Len(strMsg) Then
' MsgBox strMsg
' UpdateMsgFail strMsg
'Else
' UpdateMsgSuccess
'End If
DoCmd.Hourglass False
' END MAIL CODE HERE
'
' ////////////////////////////////////////////////////////
//////////////////////////
'Loop Starts
RS.Edit
RS("cpeDateTimeEmailed") = Now()
RS.Update
RS.MoveNext
Loop
End If
RS.Close
MyDB.Close
Set RS = Nothing
Set MyDB = Nothing
Close
Me!txtProgress = "Sent " & CStr(lngRSCount) & "
emails."
lblStatus.Caption = "Email disconnected"
MsgBox "Done sending E-mail. ", vbInformation, "Done"
lblStatus.Caption = "Idle..."
Exit Sub
Some_Err:
'MousePointer = 0
MsgBox "Error (" & CStr(Err.Number) & ") " &
Err.Description, _
vbExclamation, "Error!"
lblStatus.Caption = "Email disconnected"
End Sub
As Always, Any And All Help Truly Appreciated!
Dale
My query returns all members whose certification expires
prior to a specifed date
(studentID,certlevel,certExp,email1)
My objective is from a single button click open a report
(rptCertExp_1) for only the 1st student, email the report
(preferably HTML format and Preferably in the body of the
email, however an attachment will work also), close the
report, and loop back to the 2nd student, etc...
The student should receive an individualized report as
their certifications and expiration dates varies. This
report also shows their "Total hours of training".
I am using Jmail (1st Time) so that my users are not
dependant upon Outlook and to get around the new Outlook
security.
Ihave my email loop working but can not figure out the
report issue.
1) Can the reports record source be the same record set
as my email loop uses? If so, How would I code it?
This is what I have so far:
Private Sub Command15_Click()
On Local Error GoTo Some_Err
Dim MyDB As Database, RS As Recordset
Dim strBody As String, lngCount As Long, lngRSCount
As Long
Dim strMsg As String
Dim strServer As String
Dim strUser As String
Dim strPassword As String
Dim strFrom As String
Dim strReplyTo As String
Dim strRecip As String
Dim strCC As String
Dim strBCC As String
Dim strSubject As String
DoCmd.RunCommand acCmdSaveRecord
Set MyDB = DBEngine.Workspaces(0).Databases(0)
Me!txtProgress = Null
Set RS = MyDB.OpenRecordset("qEmail_1")
'lngRSCount = RS.RecordCount
lngRSCount = RS.RecordCount
If lngRSCount = 0 Then
MsgBox "No email messages to send.", vbInformation
Else
RS.MoveLast
RS.MoveFirst
Do Until RS.EOF
lngCount = lngCount + 1
lblStatus.Caption = "Writing Message " & CStr
(lngCount) _
& " of " & CStr(lngRSCount) & "..."
strTo = RS!E_Mail
intMessageID = Year(Now) & Month(Now) & Day(Now)
& Fix(Timer) & "_MabryMail"
' Send the email using some technique or other
'MsgBox "Sent Mail Dummy"
' Verify that all critical information was passed
' Server is required
strServer = Nz(Me.MSMTP, "")
If Len(strServer) = 0 Then
strMsg = "Must enter a valid SMTP Server"
MsgBox strMsg, vbExclamation, "Error"
Me.lblMsg.Caption = strMsg
'Me.MSMTP.SetFocus
Exit Sub
End If
' User may be blank for purpose of this test
strUser = Nz(Me.MUSERID, "")
' Password may be blank for purpose of this test
strPassword = Nz(Me.MUPassword, "")
strFrom = Nz(Me.MFrom, "")
If Len(strFrom) = 0 Then
strMsg = "Must enter a valid From Address (or
Mail User Name)"
MsgBox strMsg, vbExclamation, "Error"
Me.lblMsg.Caption = strMsg
'Me.MFrom.SetFocus
Exit Sub
End If
' ReplyTo is From address unless otherwise defined
strReplyTo = Nz(Me.MReply, "")
If Len(strServer) = 0 Then strReplyTo = strFrom
strRecip = strTo
If Len(strRecip) = 0 Then
strMsg = "Must enter a valid Recipient in format
(e-mail address removed)"
MsgBox strMsg, vbExclamation, "Error"
Me.lblMsg.Caption = strMsg
'Me.txtRecipient.SetFocus
Exit Sub
End If
' Check format of recipient address for
(e-mail address removed)
If InStr(1, strRecip, "@") = 0 And InStr(1,
strRecip, ".") = 0 Then
strMsg = "Enter Recipient in proper format:
(e-mail address removed)"
MsgBox strMsg, vbExclamation, "Error"
Me.lblMsg.Caption = strMsg
'Me.txtRecipient.SetFocus
Exit Sub
End If
' Subject Defaults to "Hello from DataFast"
strSubject = Nz(Me.txtSubject, "")
If Len(strSubject) = 0 Then strSubject = "Hello from
M-Tech"
' Body Defaults to "This is a test of the DataFast
Mail system."
strBody = Nz(Me.txtBody, "")
If Len(strBody) = 0 Then strBody = "This is a test of
the M-Tech Tracker Mail system."
' We have collected all required information and set
missing
' arguments to their defaults. We may now continue
' ////////////////////////////////////////////////////////
//////////////////////////
'
' BEGIN MAIL CODE HERE
'
DoCmd.Hourglass True
Dim jmail As jmail.Message
Set jmail = New jmail.Message
If Len(strUser) Then jmail.MailServerUserName =
strUser
If Len(strPassword) Then jmail.MailServerPassWord =
strPassword
jmail.From = strFrom
jmail.ReplyTo = strReplyTo
jmail.AddRecipient strRecip
If Len(strCC) Then jmail.AddRecipientCC strCC
If Len(strBCC) Then jmail.AddRecipientBCC strBCC
jmail.Subject = strSubject
jmail.Body = strBody
jmail.Priority = 1
' Send it...
jmail.Send (strServer)
strMsg = jmail.Log
'If Len(strMsg) Then
' MsgBox strMsg
' UpdateMsgFail strMsg
'Else
' UpdateMsgSuccess
'End If
DoCmd.Hourglass False
' END MAIL CODE HERE
'
' ////////////////////////////////////////////////////////
//////////////////////////
'Loop Starts
RS.Edit
RS("cpeDateTimeEmailed") = Now()
RS.Update
RS.MoveNext
Loop
End If
RS.Close
MyDB.Close
Set RS = Nothing
Set MyDB = Nothing
Close
Me!txtProgress = "Sent " & CStr(lngRSCount) & "
emails."
lblStatus.Caption = "Email disconnected"
MsgBox "Done sending E-mail. ", vbInformation, "Done"
lblStatus.Caption = "Idle..."
Exit Sub
Some_Err:
'MousePointer = 0
MsgBox "Error (" & CStr(Err.Number) & ") " &
Err.Description, _
vbExclamation, "Error!"
lblStatus.Caption = "Email disconnected"
End Sub
As Always, Any And All Help Truly Appreciated!
Dale