Originally Posted by
ItsMe
Good to hear!
Thank you for your help.
Herewith the final code used in this project:-
Option Compare Database
Private Sub Form_Load()
Me.cmdEmail.Visible = False
Dim rs As DAO.Recordset
Set rs = Me.RecordsetClone
Dim strDefaultPath As String
Dim strPath As String
Dim strFileName As String
Dim dtCheck As String
Dim strLogFileName As String
Dim strFirstTwoChars As String
Dim d As String, ext, X
Dim srcPath As String, destPath As String, srcFile As String
dtCheck = Format(Now, "mmyyyy")
strLogFileName = mnthSent & "EmailSent"
strDefaultPath = rs![DatabaseWorkPath]
srcPath = strDefaultPath & "\EmailReminders\Temp\"
destPath = strDefaultPath & "\EmailReminders\OldLogs\"
On Error Resume Next
' Routine to remove the previous months 'Current' Logfile from the temporary folder, and move it to the archive folder.
' This only happens on the first access of this form at the beginning of every new month.
If Left(Dir(srcPath), 6) <> dtCheck Then
d = Dir(srcPath)
srcFile = srcPath & d
FileCopy srcFile, destPath & d
Kill srcFile
End If
strPath = strDefaultPath & "\EmailReminders\Temp\"
If Left(Dir(strPath), 6) = dtCheck Then
' Message box to inform the user that the Insurance reminder EMails have already been sent
Dim Msg, Style, Title, Help, Ctxt, Response, MyString
MsgBox "The EMailed reminders have been sent for this month already." & vbCrLf & vbCrLf & "Thanks for checking.", vbOKOnly, "EMails Already Run" ' ' Define message, buttons and title.
Style = vbOKCancel ' Define buttons.
Title = "EMails Already Run" ' Define title.
End If
strShow = "SELECT * FROM qryListMemberOrganisationDetailsEMail"
Me.RecordSource = strShow 'Adjust the Form's Recordsource
Me.Requery
End Sub
Private Sub tglShowReminder_Click()
' This 'button click' routine is to show which organisations are due for a reminder.
' This will also either show the "Send Email" button or a message box to inform the
' user that the Insurance reminder EMails have already been sent
If Me.tglShowReminder.Value = -1 Then
Me.tglShowReminder.Caption = "Show All"
' Routine to print report for those without EmailAddress
Set rs = Me.RecordsetClone
Dim strDefaultPath As String
Dim strPath As String
Dim strFileName As String
Dim dtCheck As String
Dim strLogFileName As String
Dim strFirstTwoChars As String
Dim d As String, ext, X
Dim srcPath As String, destPath As String, srcFile As String
dtCheck = Format(Now, "mmyyyy")
strLogFileName = mnthSent & "EmailSent"
strDefaultPath = rs![DatabaseWorkPath]
srcPath = strDefaultPath & "\EmailReminders\Temp\"
destPath = strDefaultPath & "\EmailReminders\OldLogs\"
On Error Resume Next
' Routine to check if there are any reminders required for those organisations that do not have EMail addresses
If Left(Dir(srcPath), 6) <> dtCheck Then
If DCount("*", "qryLetterInsuranceReminder") > 0 Then
Dim strNoEmailWhere As String
Dim strNoEmailTo As String
strNoEmailWhere = "OrganisationID = '" & [organisationID] & "'"
strNoEmailTo = "SELECT * FROM qryLetterInsuranceReminder"
' Message box to inform the user that the printer needs to be used now
MsgBox "There is a reminder that needs to be printed for an Orgainsation without EMail address." & vbCrLf & vbCrLf & _
"When you exit this Message box, please click on the printer icon at the top left of the screen." & vbCrLf & vbCrLf & _
"Please click on the OK button below to exit this message box and then Print.”"
DoCmd.OpenReport "rptInsuranceReminderLetter", acViewPreview
End If
End If
strPath = strDefaultPath & "\EmailReminders\Temp\"
If Left(Dir(strPath), 6) = dtCheck Then
' Message box to inform the user that the Insurance reminder EMails have already been sent
Dim Msg, Style, Title, Help, Ctxt, Response, MyString
MsgBox "The EMailed reminders have been sent for this month already." & vbCrLf & vbCrLf & "You can only view the relevant records until next month. ", vbOKOnly, "EMails Already Run" ' ' Define message, buttons and title.
Style = vbOKCancel ' Define buttons.
Title = "EMails Already Run" ' Define title.
Else
Me.cmdEmail.Visible = True
End If
strShow = "SELECT * FROM qryEMailInsuranceReminder"
rs.MoveNext
rs.MoveFirst
Else
Me.tglShowReminder.Value = 0
Me.tglShowReminder.Caption = "Show who is due a reminder"
strShow = "SELECT * FROM qryListMemberOrganisationDetailsEMail"
Me.cmdEmail.Visible = False
End If
Me.RecordSource = strShow 'Adjust the Form's Recordsource
Me.Requery
End Sub
Private Sub cmdEmail_Click()
' This is where we generate the E-Mail.
Dim rs As DAO.Recordset
Set rs = Me.RecordsetClone
Dim strWhere As String
Dim strPath As String
Dim strLogFileName As String
Dim mnthSent As String
Dim strFileName As String
Dim strTo As String
Dim strSubject As String
Dim strInfo As String
Dim strLineSeparator1 As String
Dim strEndingSalutation As String
Dim strTitle1 As String
Dim strNRCG As String
' strDefaultPath is the full path to the relevant disk folder.
' This is an Adminstrator settable parameter in the VSM 'Default Settings'
Dim strDefaultPath As String
Dim smtpserverDNS As String
Dim sendemailaddress As String
strDefaultPath = rs![DatabaseWorkPath]
smtpserverDNS = rs![smtpserverDNS]
sendemailaddress = rs![sendemailaddress]
mnthSent = Format(Date, "mmyyyy") 'Variable used in the LogFileName below
strPath = strDefaultPath & "\EmailReminders\Temp\"
strLogFileName = mnthSent & "EmailSent" 'Naming the LogFile
' Then output the LogFile to the disk folder path.
' The output format is defined as a Comma Delimited file with '.txt' appended
DoCmd.TransferText acExportDelim, , "qryLogFileEMailInsuranceReminder", strPath & strLogFileName & ".txt", True
Set rs = Me.Recordset
If rs.EOF = True Then
'No records found
MsgBox "No Warnings needed. No Records found"
End If
Dim intCount As Integer
intCount = rs.RecordCount
MsgBox "Record Count = " & intCount
rs.MoveFirst
'This is where the temporary PDF attachments are generated and then attached to the outgoing EMails
While Not rs.EOF
On Error Resume Next
strFileName = rs![organisationID] & "_Ins_Request.pdf"
strWhere = "OrganisationID = '" & rs![organisationID] & "'"
strTo = rs![EmailAddress]
strSubject = "Insurance details update please"
strInfo = " Please find attached our annual request for your updated Insurance Certificate of Currency."
strEndingSalutation = rs![Coordinator Volunter Programs]
strTitle1 = "Volunteer Resource Centre"
strNRCG = "Northern Rivers Community Gateway"
DoCmd.OpenReport "rptInsuranceReminderEmail", acViewPreview, , strWhere
DoCmd.OutputTo acOutputReport, "rptInsuranceReminderEmail", acFormatPDF, strPath & strFileName
DoCmd.Close acReport, "rptInsuranceReminderEmail"
rs.MoveNext
Dim iCfg As Object
Dim iMsg As Object
Set iCfg = CreateObject("CDO.Configuration")
Set iMsg = CreateObject("CDO.Message")
With iCfg.Fields
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = smtpserverDNS ' telstra bibpond SMTP server
' .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.telstrabusiness.com" ' telstra bibpond SMTP server
' or 61.9.168.243
.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 0 'anonymous sender
.Item("http://schemas.microsoft.com/cdo/configuration/sendemailaddress") = sendemailaddress
.Update
End With
With iMsg
.Configuration = iCfg
.Subject = strSubject
.to = strTo
.TextBody = strInfo & vbCrLf & vbCrLf & strEndingSalutation & vbCrLf & strTitle1 & vbCrLf & strNRCG
.AddAttachment strPath & strFileName
.Send
End With
Set iMsg = Nothing
Set iCfg = Nothing
Wend
rs.MoveFirst
Me.cmdEmail.Visible = False
Set rs = Nothing
' Close form frmInsEmailReminderView
End Sub
Private Sub cmdCurrentLogFile_Click()
' This routine loads and displays the current months log-file for any queries from clients
Dim rs As DAO.Recordset
Set rs = Me.RecordsetClone
Dim fd As Office.FileDialog
Dim LogFile As Variant
Dim strDefaultPath As String
strDefaultPath = rs![DatabaseWorkPath]
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
.InitialFileName = strDefaultPath & "\EmailReminders\Temp"
.AllowMultiSelect = False
.InitialView = msoFileDialogViewSmallIcons
.Filters.Clear
.Filters.Add "All Files", "*.*"
.ButtonName = "Check archived Log Files"
'Set the title of the dialog box.
.Title = "Please select one of these files"
If fd.Show = True Then
LogFile = fd.SelectedItems(1)
DoCmd.TransferText acImportDelim, , "tblEMailInsuranceLogFileView", LogFile, True
DoCmd.OpenReport "rptEMailInsuranceLogFileView", acViewReport
Reports("rptEMailInsuranceLogFileView").Controls(" LogFileName") = LogFile
' Here we delete all records that have been temporarily imported into "tblEMailInsuranceLogFileView"
DoCmd.SetWarnings False
DoCmd.RunSQL "Delete * From [tblEMailInsuranceLogFileView]"
DoCmd.SetWarnings True
End If
End With
End Sub
Private Sub cmdArchivedLogFiles_Click()
' This routine loads and displays the user-chosen archived log-file for any queries from clients
Dim rs As DAO.Recordset
Dim fd As Office.FileDialog
Dim dskLogFile As Variant
Dim rptEMailInsuranceLogFileView As String
Dim rptLogFileName As String
Dim LogFileName As String
Dim strDefaultPath As String
Set rs = Me.RecordsetClone
strDefaultPath = rs![DatabaseWorkPath]
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
.InitialFileName = strDefaultPath & "\EmailReminders\OldLogs\"
.AllowMultiSelect = False
.InitialView = msoFileDialogViewSmallIcons
.Filters.Clear
.Filters.Add "All Files", "*.*"
.ButtonName = "Check archived Log Files"
'Set the title of the dialog box.
.Title = "Please select one of these files"
' dskLogFile = fd.SelectedItems(1)
If fd.Show = True Then
dskLogFile = fd.SelectedItems(1)
DoCmd.TransferText acImportDelim, , "tblEMailInsuranceLogFileView", dskLogFile, True
DoCmd.OpenReport "rptEMailInsuranceLogFileView", acViewReport
Reports("rptEMailInsuranceLogFileView").Controls(" LogFileName") = dskLogFile
' Here we delete all records that have been temporarily imported into "tblEMailInsuranceLogFileView"
DoCmd.SetWarnings False
DoCmd.RunSQL "Delete * From [tblEMailInsuranceLogFileView]"
DoCmd.SetWarnings True
End If
End With
End Sub
Private Sub cmdClose_Click()
On Error GoTo Err_Close_Click
DoCmd.Close
Exit_Close_Click:
Exit Sub
Err_Close_Click:
Call DisplayRuntimeError
Resume Exit_Close_Click
End Sub
Private Sub Form_Close()
'After the email and or printed report is complete
'we issue a Kill command
'to delete the temp PDF files from ..\EmailReminders\Temp\
Set rs = Me.RecordsetClone
Dim strDefaultPath As String
strDefaultPath = rs![DatabaseWorkPath]
Dim strDelFile As String
Dim test As Variable
On Error Resume Next
strDelFile = strDefaultPath & "\EmailReminders\Temp\*.pdf"
test = Dir(strDelFile)
If Not test = "" Then
Kill (strDelFile)
End If
On Error GoTo 0
End Sub
Since today is my last day here, I will no longer be available on this 'moniker'.
Thanks again.
Kind regards
Alex
How to Email separate pages of report to different EMail_Address per client
Windows XP 
Access 2003
Reply With Quote
