AngelSpeaks
Active member
- Local time
- Today, 13:43
- Joined
- Oct 21, 2021
- Messages
- 543
I posted on another thread about my FE having database bloat and I've implemented the following changes:
1) removed to temporary tables, so I'm no longer making tables, deleting all records, and appending to it.
2) added a routine to close all forms and reports when frmNavigation is closed
3) added docmd.close to reports that seem to be behind the bloat
4) added close to Excel automation
5) Outlook automation set to nothing (close causes error message.
6). added close to dao objects.
The bloat seems to be centered on two activities. The one where I'm creating .csv files, calling Excel automation to open and save, and outputting a report to pdf for each unique job. The second, a new activity, creates a report for a selected job, sends it to pdf, and then invokes Outlook to send an email.
The code for activity 1
The code for activity 2, create pdf:
Form has a button to send an email, which has a button to launch Outlook:
Thanks for any help you can provide.
1) removed to temporary tables, so I'm no longer making tables, deleting all records, and appending to it.
2) added a routine to close all forms and reports when frmNavigation is closed
3) added docmd.close to reports that seem to be behind the bloat
4) added close to Excel automation
5) Outlook automation set to nothing (close causes error message.
6). added close to dao objects.
The bloat seems to be centered on two activities. The one where I'm creating .csv files, calling Excel automation to open and save, and outputting a report to pdf for each unique job. The second, a new activity, creates a report for a selected job, sends it to pdf, and then invokes Outlook to send an email.
The code for activity 1
Code:
Private Sub cmdExport_Click()
Dim dbs As dao.Database
Dim qdf As dao.QueryDef
Dim rst As dao.Recordset
Dim lRecCount As Long
Set dbs = CurrentDb
Set qdf = dbs.QueryDefs("qryMissingEmployees")
'Open a Recordset based on the parameter query
Set rst = qdf.OpenRecordset()
lRecCount = rst.RecordCount
If lRecCount > 0 Then
msgText = "Employees are Missing - Procedure Stopped"
Response = MsgBox(msgText, vbOKOnly, msgApp)
Exit Sub
End If
rst.Close
Set rst = Nothing
Set qdf = dbs.QueryDefs("qryMissingJobs")
Set rst = qdf.OpenRecordset()
lRecCount = rst.RecordCount
If lRecCount > 0 Then
msgText = "Jobs are Missing - Procedure Stopped"
Response = MsgBox(msgText, vbOKOnly, msgApp)
Exit Sub
End If
rst.Close
Set rst = Nothing
Set qdf = dbs.QueryDefs("qryMissingPublicBody")
Set rst = qdf.OpenRecordset()
lRecCount = rst.RecordCount
If lRecCount > 0 Then
msgText = "Public Body records are Missing - Procedure Stopped"
Response = MsgBox(msgText, vbOKOnly, msgApp)
Exit Sub
End If
rst.Close
dbs.Close '3-2-22
Set rst = Nothing
TempVars.RemoveAll
dteStart = Me.StartDate
dteEnd = Me.EndDate
TempVars.Add "StartDate", dteStart
TempVars.Add "EndDate", dteEnd
TempVars.Add "State", gstrState
Dim strCriteria As String 'Date criteria to extract unique jobs
Select Case gstrState
Case "IL"
Illinois_Split
End Select
End Sub
Private Sub Illinois_Split()
Dim sDate As String
Dim lRecCount As Integer
'For renaming columns
Dim sFile As String
Dim sFieldNamesOrig As String, sFieldNamesTarget As String
Dim oApp As Excel.Application 'Excel Application
'dim oApp as Object 'you can remove the reference to Microsoft Excel xx.0 Object library)
Set oApp = CreateObject("Excel.Application") 'opens new instance of Excel
oApp.Visible = False 'for testing, you can see what Excel does, set to false when done
'Dim oWkbk As Object 'defines a workbook
Dim oWkbk As Excel.Workbook
oApp.DisplayAlerts = False 'turn off alerts
msgApp = "Certified Payroll"
'Extract Unique Jobs
strCriteria = "[Date] Between " & Format(dteStart, strcJetDate) & " And " & Format(dteEnd, strcJetDate) ' Setup Date Criteria
Set rsJobs = CurrentDb.OpenRecordset("SELECT DISTINCTROW Job FROM tblPWBenefits WHERE (" & strCriteria & ") GROUP BY Job ORDER BY Job;", dbOpenDynaset)
lRecCount = rsJobs.RecordCount
If lRecCount = 0 Then
msgApp = "Certified Payroll"
msgText = "No Jobs within that date period - Procedure Stopped"
Response = MsgBox(msgText, vbOKOnly, msgApp)
Exit Sub
End If
Dim FileName As String
Dim filenamePDF As String
Dim directoryName As String
sDate = Format(dteStart, "mmddyyyy")
dashdate = Format(dteStart, "mm-dd-yyyy")
directoryName = gExportPath & "\" & dashdate
'Make directory
If Not DirExists(directoryName) Then
MkDir (directoryName)
End If
TempVars.Add "StartDate", dteStart
TempVars.Add "EndDate", dteEnd
Dim dbs As dao.Database
Dim qdf As dao.QueryDef
Dim rst As dao.Recordset
Set dbs = CurrentDb
Do While Not rsJobs.EOF
Job = rsJobs!Job
'Set up from/to for Job Selection
TempVars.Add "Job", Job 'for qryIllinoisPWExportPortal
TempVars.Add "JobTo", Job 'Not being used, I don't think
TempVars.Add "JobStart", Job 'for qryIllinoisPWExport
TempVars.Add "JobEnd", Job
FileName = directoryName & "\State " & gstrState & " Job " & Job & " Start Date " & sDate & " - CP Upload.csv"
DoCmd.TransferText acExportDelim, "qryIllinoisPWExport Export Specification", "qryIllinoisPWExport", FileName, True
'Rename Columns
sFieldNamesOrig = Me.FieldNamesOriginal
sFieldNamesTarget = Me.FieldNamesTarget
sFile = FileName
'Below is code to do what TransferText does
'Set rs = CurrentDb.OpenRecordset(rsExportSQL, dbOpenDynaset)
'Call ExportToCSV(rs, sFile, True)
'replace original with target
Call TextFile_FindReplace(sFile, sFieldNamesOrig, sFieldNamesTarget)
'Use Excel to save file in format IDOL Portal wants
With DoCmd
.SetWarnings False
Set oWkbk = oApp.WorkBooks.Open(sFile)
oWkbk.SaveAs sFile
oWkbk.Close
.SetWarnings True
End With
filenamePDF = directoryName & "\State " & gstrState & " Job " & Job & " Start Date " & sDate & " - CP Upload.pdf"
With DoCmd
.SetWarnings False
.OutputTo acOutputReport, "rptAffidavit", acFormatPDF, filenamePDF
.SetWarnings True
End With
DoCmd.Close acOutputReport, "rptAffidavit" '3-2-22
rsJobs.MoveNext
Loop
Set qdf = Nothing
Set dbs = Nothing
' dbs.Close '3-2-22 error message
' rst.Close '3-2-22 error message
rsJobs.Close '3-2-22
'Close Excel
Set oWkbk = Nothing
oApp.DisplayAlerts = True
Set oApp = Nothing
oWkbk.Close '3-2-22
oApp.Close '3-2-22
msgText = "Extract Completed, look at folder " & gExportPath & " for extracted CSV files"
Response = MsgBox(msgText, vbOKOnly, msgApp)
End Sub
Code:
Private Sub cmdReportPDF_Click()
'Check to make sure job was selected
If IsNull(Me.cboJob.Value) Then
msgApp = "Certified Payroll Reporting"
msgText = "Please select a Job from the list"
Response = MsgBox(msgText, vbOKOnly, msgApp)
Exit Sub
End If
'set default path
If Len(gExportPath) = 0 Then
gExportPath = CurrentProject.Path
End If
Dim directoryName As String
Dim blnNoWork As Boolean
blnNoWork = False
dteStart = Me.StartDate
dteEnd = Me.EndDate
intJob = CLng(Me.cboJob)
sDate = Format(dteStart, "mmddyyyy")
dashdate = Format(dteStart, "mm-dd-yyyy")
directoryName = gExportPath & "\CPReports"
'Make directory
If Not DirExists(directoryName) Then
MkDir (directoryName)
End If
TempVars.RemoveAll
TempVars.Add "StartDate", dteStart
TempVars.Add "EndDate", dteEnd
TempVars.Add "JobStart", intJob
TempVars.Add "JobEnd", intJob
TempVars.Add "State", gstrState
TempVars.Add "NoWork", blnNoWork
filenamePDF = directoryName & "\CPReport for Job " & intJob & " Start Date " & dashdate & ".pdf"
With DoCmd
.SetWarnings False
.OutputTo acOutputReport, "rptCPReport", acFormatPDF, filenamePDF
.SetWarnings True
End With
DoCmd.Close acOutputReport, "rptCPReport" '3-2-22
msgApp = "Certified Payroll"
msgText = "CP Report created " & filenamePDF
Response = MsgBox(msgText, vbOKOnly, msgApp)
cmdEmail.Visible = True
End Sub
Form has a button to send an email, which has a button to launch Outlook:
Code:
Private Sub cmdEmail_Click()
' Define app variable and get Outlook using the "New" keyword
Dim OutApp As Object
Dim OutMail As Object ' An Outlook Mail item
' Create a new email object
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(olMailItem)
Dim strTo As String
Dim strCc As String
Dim strBcc As String
Dim strMessage As String
Dim strSubject As String
Dim strAttch As String
strTo = Me.txtEmail
strAttch = Me.txtAttachment
strSubject = Me.txtSubject
strMessage = Me.txtMessage
If Not IsNull(Me.SecondaryEmail) Then
strCc = Me.SecondaryEmail
End If
' Add the To/Subject/Body to the message and display the message
With OutMail
.To = strTo
.Cc = strCc
.Bcc = strBcc
.Attachments.Add strAttch
.Subject = strSubject
.Body = strMessage
.display ' Display the message
End With
' Release all object variables
Set OutApp = Nothing
Set OutMail = Nothing
' OutApp.Close '3-2-22
' OutMail.Close '3-2-22
End Sub
Thanks for any help you can provide.