Attribute VB_Name = "Confirmations" Option Compare Database Option Explicit ' Create as public so that it can be opened with one function, and dealt with in another Public myInDesign As InDesign.Application Public Type ConfRecordSet camperID As Integer campID As Integer programID As Integer programName As String FirstName As String LastName As String Gender As String ParentFirst As String ParentLast As String MailAddress As String MailCity As String MailProvince As String MailPostal As String Email As String ConfMethod As String CampName As String CampLocation As String CampFacility As String CampWeek As String CampDates As String CampCost As String PayTransID() As String PayAmount() As String PayDate() As Date PayName() As String PayNumber() As String PayType() As String OptPTL As Boolean OptEpipen As Boolean ExtraName() As String ExtraDesc() As String ExtraCost() As Currency AmtDue As Currency AmtPaid As Currency TotalCost As Currency ExtrasCost As Currency SelectedPmtType As String FinalConfSent As Integer ConfSent As Integer ConsentFormSigned As Integer ConsentFormLocation As String EpiPenFormLocation As String End Type ' Use this as a public variable so that we don't have to worry about passing it around between routines Public conf() As ConfRecordSet ' PARAMETERS: ' camperID - used when calling, printing, or generating a SINGLE receipt/confirmation ' example: clicking "Camper Receipt" on the camper's personal info screen ' printPDF - used for a SINGLE receipt/confirmation, if 1 print PDF right away, if 0 open the newly minted PDF ' groupQueryType - used when printing and marking off a batch of bulk confirmations. Ignored for single camperID ' VALUES: "email", "post" ' used to process all bulk confirmations at once, be it by post or email. Public Function Confirmation(camperID As Integer, printPDF As Boolean, groupQueryType As String) 'Ensure that Outlook is open for Email confirmations If groupQueryType = "email" Then Dim Response As Integer Response = MsgBox(prompt:="Are you sure you want to send email confirmations?? Is OUTLOOK open?", Buttons:=vbYesNo) If Response <> vbYes Then Exit Function MsgBox ("Emails.... AWAY!! ") End If ' Get together all the confirmation info need Dim conf() As ConfRecordSet ' What do we want to pass here? A SQL query? An array or camperIDs? Call GatherInfo(camperID, groupQueryType) ' Open InDesign First, Don't Open Documents Set myInDesign = CreateObject("InDesign.Application.CS3") ' Make PDF(s) Using InDesign -- since conf array is already made, what options need to be passed? ' Email/Print handling is done at the bottom of this function Call CreatePDF(printPDF, groupQueryType) 'Close Indesign When Done myInDesign.Quit idSaveOptions.idNo End Function Private Function CreatePDF(printPDF As Boolean, groupQueryType As String) ' Setup a few variables that we'll be needing. Dim myPDF As String, myString As String, myFile As String ' InDesign File template. Perfectly okay to use a "C:\File\Path\like\this.indd" myFile = "\\path\to\InDesign\template\file.indd" ' This part needs to be changed to a proper loop to deal with multiple confirmation entries Dim k As Integer, l As Integer, m As Integer k = 0 l = 0 m = 0 ' Loop through until all records are reached While k <= UBound(conf) ' Name a custom pdf using the camperID myPDF = "\\location\to\save\receipts\confirmation-" & conf(k).camperID & ".pdf" ' Make the body message based on conf(k) values Dim strTime As String, strAddressBlock As String, strPara1 As String, strPara2 As String, strPayments As String Dim StrPara3 As String, strBursary As String, strPmtHistory As String ' clear out the contents of the address block variable strAddressBlock = "" ' Open up the proper letterhead in InDesign myInDesign.Open myFile, True Dim myPage As InDesign.Page Dim myDocument As Object ' Get the letterhead as the active document Set myDocument = myInDesign.ActiveDocument Dim myTextFrame As InDesign.TextFrame ' Go to Page 1 Set myPage = myDocument.Pages.Item(1) ' Go to Text frame 1 (date). Textframes can be labelled in the InDesign file itself Set myTextFrame = myPage.TextFrames.Item("dateFrame") ' Date Header strTime = FormatDateTime(Now(), vbLongDate) myTextFrame.Contents = strTime ' Go to Text frame or address block myDocument.ViewPreferences.HorizontalMeasurementUnits = idMeasurementUnits.idPoints myDocument.ViewPreferences.VerticalMeasurementUnits = idMeasurementUnits.idPoints Set myTextFrame = myPage.TextFrames.Item("addressFrame") ' Delete contents of previous TextFrame If myTextFrame.Contents <> "" Then myTextFrame.Contents = "" End If ' Address Block strAddressBlock = conf(k).ParentFirst & " " & conf(k).ParentLast & vbCr & _ conf(k).MailAddress & vbCr & _ conf(k).MailCity & ", " & conf(k).MailProvince & " " & conf(k).MailPostal 'Set Varible to Block myTextFrame.Contents = strAddressBlock ' Go to Text body frame for the rest of the confirmation Set myTextFrame = myPage.TextFrames.Item("bodyFrame") ' Delete contents of previous TextFrame If myTextFrame.Contents <> "" Then myTextFrame.Contents = "" End If ' First Paragraph - Thank you, confirmation of camp, summary of payments received strPara1 = "Thank-you for registering! We have received " & conf(k).FirstName & " " & conf(k).LastName & _ "'s registration for " & conf(k).CampName & " (" & conf(k).CampDates & ") in " & conf(k).CampLocation & " (" & conf(k).CampFacility & "). " strPara1 = strPara1 + "The total cost of this registration is $" & conf(k).TotalCost & ". We have received a total of $" & conf(k).AmtPaid & _ ", leaving an outstanding balance of $" & conf(k).AmtDue & "." myTextFrame.ParentStory.InsertionPoints.Item(-1).Contents = strPara1 & vbCrLf 'Bursary info - basically, an example of adding extra information depending on the contents of a camper's record If conf(k).SelectedPmtType = "Bursary" Then strBursary = "Our records indicate that you have applied for a financial bursary to subsidize the cost of this participant's registration. " & _ "We will contact you before the event start date to let you know the status of this bursary application. In the meantime, please " & _ "do not submit any payments to us. Your child's registration spot is being held for them while we process bursary applications. " myTextFrame.ParentStory.InsertionPoints.Item(-1).Contents = strBursary & vbCrLf End If ' Second Paragraph - extra registration options strPara2 = "This registration includes the following options:" ' "m" cycles through all of the extra registration options; Permission to Leave and EpiPen is added at the end ' Only loop if there are actually registered extras to loop through If conf(k).ExtrasCost <> 0 Then While m <= UBound(conf(k).ExtraName) strPara2 = strPara2 & vbCr & "- " & conf(k).ExtraName(m) & " (" & conf(k).ExtraDesc(m) & ") ($" & conf(k).ExtraCost(m) & ")" m = m + 1 Wend End If If conf(k).OptPTL Then strPara2 = strPara2 & vbCr & "- This participant has permission to leave by themselves at the end of the day/event" Else: strPara2 = strPara2 & vbCr & "- This participant does NOT have permission to leave by themselves at the end of the day/event" End If myTextFrame.ParentStory.InsertionPoints.Item(-1).Contents = strPara2 & vbCrLf ' Final paragraph - pre-camp info, contact information StrPara3 = "A parent/participant information package will be sent out prior to the program's start date. Thanks for registering!" & vbCrLf StrPara3 = StrPara3 & "Sincerely," & vbCr & "-the SCI-FI Staff" myTextFrame.ParentStory.InsertionPoints.Item(-1).Contents = StrPara3 ' Go to payment body frame for the rest of the confirmation, this clears the old table even if the registrant hasn't paid yet. Set myTextFrame = myPage.TextFrames.Item("paymentFrame") ' Delete contents of previous TextFrame If myTextFrame.Contents <> "" Then myTextFrame.Contents = "" End If 'also delete contents of old static "PAYMENT HISTORY" in case there is none Set myTextFrame = myPage.TextFrames.Item("paymentHistoryText") If myTextFrame.Contents <> "" Then myTextFrame.Contents = "" End If 'Only print the payment table if we have received payments If conf(k).AmtPaid > 0 Then 're-set the payment history text Set myTextFrame = myPage.TextFrames.Item("paymentHistoryText") strPmtHistory = "PAYMENT HISTORY (KEEP THIS DOCUMENT AS A RECEIPT):" myTextFrame.ParentStory.InsertionPoints.Item(-1).Contents = strPmtHistory 're-focus on the payment frame Set myTextFrame = myPage.TextFrames.Item("paymentFrame") ' Real Payments Table Dim myTableText As String Dim myPaymentTotal As Currency ' Header Row myTableText = "Date" & vbTab & "TransID" & vbTab & "Amount" & vbTab & "Received From" & vbTab & "Pmt.Method" & vbTab & "Payment Number" ' Payment Rows While l <= UBound(conf(k).PayTransID) myTableText = myTableText & vbCr & FormatDateTime(conf(k).PayDate(l), vbShortDate) & vbTab myTableText = myTableText & conf(k).PayTransID(l) & vbTab myTableText = myTableText & "$" & conf(k).PayAmount(l) & vbTab myTableText = myTableText & conf(k).PayName(l) & vbTab myTableText = myTableText & conf(k).PayType(l) & vbTab myTableText = myTableText & conf(k).PayNumber(l) 'running count of payment total myPaymentTotal = conf(k).PayAmount(l) + myPaymentTotal l = l + 1 Wend 'last row myTableText = myTableText & vbCr & "" & vbTab & "TOTAL" & vbTab & "$" & myPaymentTotal & vbTab & "" & vbTab & "" & vbTab & "" 'raw text into the frame myTextFrame.ParentStory.InsertionPoints.Item(-1).Contents = myTableText 'Convert to table object myTextFrame.ParentStory.Texts.Item(1).ConvertToTable 'Dim myTable As Object Dim myTable As InDesign.Table Set myTable = myTextFrame.Tables.Item(1) 'Set Table colum widths...unfortunately this has to be done manually (units are 'points') myTable.Columns.Item(1).Width = 55 myTable.Columns.Item(2).Width = 55 myTable.Columns.Item(3).Width = 40 myTable.Columns.Item(4).Width = 120 myTable.Columns.Item(5).Width = 50 myTable.Columns.Item(6).Width = 110 'This property was created in the INDD file and referenced by name here. 'It makes the first line of the table shaded dark. myTable.AppliedTableStyle = "RegSysReceipt" 'Set payment row counter and payment total counter variables back to 0 l = 0 m = 0 myPaymentTotal = 0 End If ' Don't open the PDF after creating it if it's a straight-to-printer to straight-to-email job. If printPDF = True Or groupQueryType = "post" Or groupQueryType = "email" Then ' don't view PDF after exporting myInDesign.PDFExportPreferences.ViewPDF = False Else: myInDesign.PDFExportPreferences.ViewPDF = True End If ' Export to "myPDF" file using the Press Quality export preset ' The "ShowingOptions" boolean variable can be changed so that it does not view PDFs after printing -- but it's good for debugging myDocument.Export idExportFormat.idPDFType, myPDF, False, "Press Quality" ' Print the document out .. should add a field in the class for confMethod to determine this (or to call an email routine) ' Also, a print preset should be created with all the desired options (right now it asks for "plain universal paper" in the printer) ' or options could be set with myInDesign.ActiveDocument.PrintPreferences If printPDF = True Or groupQueryType = "post" Then 'Even though this is "false" it will still print. myDocument.PrintOut False End If If groupQueryType = "email" Then Call SendEmail(k, myPDF) End If k = k + 1 Wend ' Drink a beer and celebrate. End Function 'k is the record ID that is being looped through, myPDF is the network file location of the receipt Private Function SendEmail(k As Integer, myPDFreceipt As String) 'Define variables Dim MyOutlook As Outlook.Application Dim MyMail As Outlook.MailItem Dim Subjectline As String Dim MyBody As String 'Open Outlook Set MyOutlook = New Outlook.Application 'Create a new mail object for this record Set MyMail = MyOutlook.CreateItem(olMailItem) 'Email address MyMail.To = conf(k).Email MyMail.Subject = "Registration Confirmation - " & conf(k).programName MyMail.Body = "Dear " & conf(k).ParentFirst & " " & conf(k).ParentLast & "," & vbCrLf & vbCrLf MyMail.Body = MyMail.Body + "Thank you for registering your child in " & conf(k).programName & "! We have received your registration and have attached a " & _ "copy of the confirmation of registration/receipt for your records. Please print or save the attached PDF file." & vbCrLf & vbCrLf MyMail.Body = MyMail.Body + "If you have not already done so, please fill out the attached forms and submit them (by mail or fax) to SCI-FI Science " & _ "Camps. " & vbCrLf & vbCrLf MyMail.Body = MyMail.Body + "Sincerely," + vbCrLf + "the SCI-FI Staff" + vbCrLf + vbCrLf MyMail.Attachments.Add myPDFreceipt, olByValue, 1, "Confirmation" If conf(k).ConsentFormSigned <> "-1" Then MyMail.Attachments.Add conf(k).ConsentFormLocation, olByValue, 1, "Consent Form" End If If conf(k).OptEpipen = True Then MyMail.Attachments.Add conf(k).EpiPenFormLocation, olByValue, 1, "EpiPen Usage Form" End If ' To briefly describe the attachment process: ' "c:\myfile.txt" = the file you want to attach ' ' olByVaue = how to pass the file. olByValue attaches it, olByReference creates a shortcut. ' the shortcut only works if the file is available locally (via mapped or local drive) ' ' 1 = the position in the outlook message where to attachment goes. This is ignored by most ' other mailers, so you might want to ignore it too. Using 1 puts the attachment ' first in line. ' ' "My Displayname" = If you don't want the attachment's icon string to be "c:\myfile.txt" you ' can use this property to change it to something useful, i.e. "4th Qtr Report" ' To send your email you have two options. Outlook can send the emails in the background, ' or you can preview them before sending them. Leave MyMail.Send uncommented to send mail automatically ' when the function is called, or leave MyMail.Display uncommented to preview emails before ' sending them (useful for debugging). Only one should be uncommented at a time. ' Note: On "Display" mode, even if you don't send the emails, the database will still be ' updated if you update fields in the step above this one. MyMail.Send 'MyMail.Display 'Clean up after ourselves Set MyMail = Nothing Set MyOutlook = Nothing End Function Private Function GatherInfo(passedCamperID As Integer, groupQueryType As String) As ConfRecordSet ' Build DB connection object Dim dbConnect As ADODB.Connection Set dbConnect = New ADODB.Connection ' Connect to the current access database Dim strConnection As String strConnection = "Provider=Microsoft.ACE.OLEDB.12.0;" & _ "Data Source=" & CurrentProject.Path & "\" & CurrentProject.Name & ";" dbConnect.Open strConnection Dim myserverstrConnection As String myserverstrConnection = "Provider=SQLNCLI; " & _ "Server=myserver\subserver;" & _ "Database=database_name;" & _ "Trusted_Connection=yes;" & _ "Encrypt=yes;" ' Build connection object Dim rsPerson As ADODB.Recordset Set rsPerson = New ADODB.Recordset ' Set connection details and SQL query With rsPerson .CursorType = adOpenDynamic .CursorLocation = adUseServer .LockType = adLockPessimistic ' for single-camper confirmations: If passedCamperID > 0 Then .Open "SELECT * FROM camper_registration_table WHERE camperID = " & passedCamperID, dbConnect Else ' other IF/ELSE combos can go here to figure out how to SELECT the proper group If groupQueryType = "email" Then .Open "SELECT * FROM unsent_email_confirmations", dbConnect Else: If groupQueryType = "post" Then .Open "SELECT * FROM unsent_post_confirmations", dbConnect Else: MsgBox ("an invalid parameter has been passed to function GatherInfo") End If End If End If End With ' Jump to the first record rsPerson.MoveFirst ' Variables for loop counting and record sets for querying Dim k As Integer, l As Integer, m As Integer k = 0 l = 0 m = 0 Dim rsCamp As ADODB.Recordset, rsPayments As ADODB.Recordset, rsTrans As ADODB.Recordset, rsProgram As ADODB.Recordset ' Loop through recordset to get camper info While Not rsPerson.EOF ReDim Preserve conf(k) As ConfRecordSet With conf(k) .camperID = rsPerson!camperID .campID = rsPerson!campID .FirstName = rsPerson!First_Name .LastName = rsPerson!Last_Name .Gender = rsPerson!Gender .ParentFirst = rsPerson!Parent_First .ParentLast = rsPerson!Parent_Last .MailAddress = rsPerson!Address .MailCity = rsPerson!City .MailProvince = rsPerson!Province .MailPostal = rsPerson!Postal_Code .Email = rsPerson!Email .ConfMethod = rsPerson!Confirmation_Method .OptPTL = IIf(IsNull(rsPerson!Permission_To_Leave), "0", rsPerson!Permission_To_Leave) .OptEpipen = IIf(IsNull(rsPerson!EpiPen), "0", rsPerson!EpiPen) .AmtPaid = rsPerson!Amt_Paid .AmtDue = rsPerson!Amt_Due .TotalCost = rsPerson!Total_Cost .ExtrasCost = rsPerson!Extras_Cost .SelectedPmtType = IIf(IsNull(rsPerson!Payment_Method), "Person", rsPerson!Payment_Method) .ConfSent = IIf(IsNull(rsPerson!Confirmation_Sent), "0", rsPerson!Confirmation_Sent) .FinalConfSent = IIf(IsNull(rsPerson!Final_Receipt_Sent), "0", rsPerson!Final_Receipt_Sent) .ConsentFormSigned = IIf(IsNull(rsPerson!Consent_Form_Signed), "0", rsPerson!Consent_Form_Signed) .ConsentFormLocation = rsPerson!consent_form_location .EpiPenFormLocation = rsPerson!epipen_form_location End With 'confirmation sent updating - this is the easiest place to do this. If conf(k).AmtDue = 0 Then rsPerson!Final_Receipt_Sent = -1 rsPerson!Final_Receipt_Send_date = Now() rsPerson!Date_Confirmation_Sent = Now() rsPerson!Confirmation_Sent = -1 Else rsPerson!Date_Confirmation_Sent = Now() rsPerson!Confirmation_Sent = -1 End If ' Setup connection to find out camp information Set rsCamp = New ADODB.Recordset With rsCamp .CursorType = adOpenDynamic .CursorLocation = adUseServer .LockType = adLockReadOnly ' Select the record with the same camp information as the camper .Open "SELECT * FROM camp_table WHERE campID = " & conf(k).campID, dbConnect End With rsCamp.MoveFirst With conf(k) .programID = rsCamp!programID .CampName = rsCamp!camp_name .CampLocation = rsCamp!Location .CampFacility = rsCamp!facility .CampWeek = rsCamp!week .CampDates = rsCamp!Dates .CampCost = rsCamp!cost End With ' This would be a good spot to look up any camp specific info needed for merging rsCamp.Close ' Get Program Description Set rsProgram = New ADODB.Recordset With rsProgram .CursorType = adOpenDynamic .CursorLocation = adUseServer .LockType = adLockReadOnly ' Select the record with the same camp information as the camper .Open "SELECT * FROM program_table WHERE programID = " & conf(k).programID, dbConnect End With rsProgram.MoveFirst conf(k).programName = rsProgram!short_title ' This would be a good spot to look up the letterhead for a particular program rsProgram.Close 'Get Extra Options Information - only hunt for registered extras if the ExtrasCost not equal to 0 'there is the potential for trouble if a mix of extra options make ExtrasCost = 0 m = 0 If conf(k).ExtrasCost <> 0 Then Dim rsExtraRegOptions As ADODB.Recordset Set rsExtraRegOptions = New ADODB.Recordset With rsExtraRegOptions .CursorType = adOpenDynamic .CursorLocation = adUseServer .LockType = adLockReadOnly ' Select the record with the same camp information as the camper .Open "SELECT * FROM registered_extras_view WHERE camperID = " & conf(k).camperID, dbConnect End With rsExtraRegOptions.MoveFirst ' Cycle through any registered extra options While Not rsExtraRegOptions.EOF ReDim Preserve conf(k).ExtraName(m) As String ReDim Preserve conf(k).ExtraDesc(m) As String ReDim Preserve conf(k).ExtraCost(m) As Currency With conf(k) .ExtraName(m) = rsExtraRegOptions!Name .ExtraDesc(m) = rsExtraRegOptions!Description .ExtraCost(m) = rsExtraRegOptions!cost End With 'Bump to next extra registration option m = m + 1 rsExtraRegOptions.MoveNext Wend rsExtraRegOptions.Close End If ' Get Payment Information, only if AmtPaid > 0 If conf(k).AmtPaid > 0 Then Set rsPayments = New ADODB.Recordset With rsPayments .CursorType = adOpenDynamic .CursorLocation = adUseServer .LockType = adLockReadOnly ' Select the record with the same camp information as the camper .Open "SELECT * FROM payment_distribution WHERE (void = 0 OR void IS NULL) AND camperID = " & conf(k).camperID, dbConnect End With rsPayments.MoveFirst l = 0 ' Cycle through individual payments, then do a lookup of the transaction information for each one While Not rsPayments.EOF ReDim Preserve conf(k).PayTransID(l) As String ReDim Preserve conf(k).PayAmount(l) As String ReDim Preserve conf(k).PayName(l) As String ReDim Preserve conf(k).PayDate(l) As Date ReDim Preserve conf(k).PayNumber(l) As String ReDim Preserve conf(k).PayType(l) As String With conf(k) .PayTransID(l) = rsPayments!transactionID .PayAmount(l) = rsPayments!subamount End With ' Do transaction info lookup Set rsTrans = New ADODB.Recordset With rsTrans .CursorType = adOpenDynamic .CursorLocation = adUseServer .LockType = adLockReadOnly .Open "SELECT * FROM payment_transactions WHERE transactionID = " & conf(k).PayTransID(l), dbConnect End With rsTrans.MoveFirst With conf(k) .PayDate(l) = rsTrans!Date .PayNumber(l) = IIf(IsNull(rsTrans!Payment_Number), "N/A", rsTrans!Payment_Number) .PayType(l) = rsTrans!Payment_Type .PayName(l) = rsTrans!Payment_Name End With ' Take down connection transaction table rsTrans.Close ' Bump to next payment distribution ID l = l + 1 rsPayments.MoveNext Wend rsPayments.Close End If ' Increase Count and move to the next record k = k + 1 rsPerson.MoveNext Wend rsPerson.Close End Function