VBA DAO 3.6 Database - How to release resources on the PC after multiple Queries

[Earl Brown]

Hi, I have noticed that my PC's resources are being used
up by making multiple Queries using DAO 3.6 within the
worksheet. It keeps getting larger till teh PC can't
handle anhymore. I've tried closeing the RS and the DB
and also setting the RS and DB to NOTHING, but it does
not release the resources assigned to Excel. Shutting
down Excel also does not appear to correct it when it is
restarted. Only shutting down the PC seems to correct it.

Sample Code Below...

With Worksheets(15)
mMonth = InputBox("Please enter the MONTH of the
Report.", "Northern Trip Monthly Report", Format(Month
(Now) - 1, "#0"))
If Val(mMonth) <= 0 Or Val(mYear) > 12 Then Exit Sub
mYear = InputBox("Please enter the YEAR of the
Report.", "Northern Trip Monthly Report", Format(Year
(Now), "#0"))
If mYear < 1 Or mYear > 2020 Then Exit Sub
If .Range(.Cells(6, 5).Address).Value = "" Then .Range
(.Cells(6, 5).Address).Value = "1901-01-01"
If .Range(.Cells(6, 6).Address).Value = "" Then .Range
(.Cells(6, 6).Address).Value = "1901-01-01"
'.Range("a6:l300").Select
Dim db As Database
Dim rs As Recordset
Dim rs2 As Recordset
Set db = OpenDatabase(Application.ActiveWorkbook.Path
& "\" & Application.ActiveWorkbook.Name, False,
False, "Excel 5.0;")
Set rs = db.OpenRecordset("Select * from NTDatabase
WHERE RDate >=datevalue('" & Format(DateSerial(mYear,
mMonth, 1), "mmm-yyyy") & "') AND RDate < datevalue('" &
Format(DateSerial(mYear, mMonth + 1, 1), "mmm-yyyy")
& "')")

End With
mrow = 5
With Worksheets(Val(mMonth))
.Select
.Range(.Cells(mrow, 1), .Cells(200, 12)).Clear
.Range(.Cells(2, 1).Address).Value = "For the Month
of " & Format(DateSerial(mYear, mMonth, 1), "mmmm") & " "
& Format(DateSerial(mYear, mMonth, 1), "yyyy")
If rs.EOF = False Then

rs.MoveFirst
'MsgBox rs.Fields(1).Name & rs.Fields(2).Name
'MsgBox " Report Date " & rs.Fields!Rdate


While rs.EOF = False

If mrow <> 5 Then

If rs.Fields!enumber <> .Cells(mrow - 1, 5)
And .Cells(mrow - 1, 5) <> "" Then

' ********** SUB Totals **************
.Cells(mrow, 8) = "Total:"
.Cells(mrow, 9) = Format
(costGST, "$###,##0.00")
.Cells(mrow, 10) = Format(costGST * (1 *
1 / 1.07), "$###,##0.00")
.Range(.Cells(mrow, 8), .Cells(mrow,
11)).Font.Bold = True
costGST = 0
.Range(.Cells(mrow, 8), .Cells(mrow,
11)).Borders(xlEdgeTop).LineStyle = xlSingle
.Range(.Cells(mrow, 8), .Cells(mrow,
11)).Borders(xlEdgeBottom).LineStyle = xlDouble

'Sheet1.Range.Clear
.Range(.Cells(mrow, 1), .Cells(mrow,
12)).Interior.Color = 12632256

mrow = mrow + 1
End If

End If
On Error Resume Next
.Cells(mrow, 1) = rs.Fields!lName
.Cells(mrow, 2) = rs.Fields!tName
If UCase(Left(rs.Fields!payType, 1)) = "H"
Then
.Cells(mrow, 3) = "XX"
Else
If UCase(Left(rs.Fields!payType, 1))
= "B" Then .Cells(mrow, 4) = "XX"
End If
.Cells(mrow, 5) = rs.Fields!enumber
.Cells(mrow, 6) = rs.Fields!CC
If IsNull(rs.Fields!TSDate) = False Then
.Cells(mrow, 7) = Format(DateValue
(rs.Fields!TSDate), "yyyy/mm/dd")
'.Cells(mrow, 7) = rs.Fields!TSDate
End If
If IsNull(rs.Fields!TEDate) = False Then
.Cells(mrow, 8) = Format(rs.Fields!
TEDate, "yyyy/mm/dd")
'.Cells(mRow, 8) = rs.Fields!TEDate
End If
.Cells(mrow, 9) = Format(rs.Fields!
cost, "$###,##0.00")
.Cells(mrow, 10) = Format(rs.Fields!cost *
(1 / 1.07), "$###,##0.00")
.Cells(mrow, 11) = rs.Fields!Trip & " of " &
rs.Fields!ofTrip
.Cells(mrow, 12) = rs.Fields!Remarks
costGST = costGST + rs.Fields!cost
mrow = mrow + 1
TotalCost = TotalCost + rs.Fields!cost
rs.MoveNext
Wend
' ********** SUB Totals for last set of employee
Records **************
'mRow = mRow + 1
.Cells(mrow, 8) = "Total:"
.Cells(mrow, 9) = Format
(costGST, "$###,##0.00")
.Cells(mrow, 10) = Format(costGST * (1 *
1 / 1.07), "$###,##0.00")
.Range(.Cells(mrow, 8), .Cells(mrow,
11)).Font.Bold = True
'Sheet1.Range.Font.Bold
costGST = 0
.Range(.Cells(mrow, 8), .Cells(mrow,
11)).Borders(xlEdgeTop).LineStyle = xlSingle
.Range(.Cells(mrow, 8), .Cells(mrow,
11)).Borders(xlEdgeBottom).LineStyle = xlDouble
.Range(.Cells(mrow, 1), .Cells(mrow,
12)).Interior.Color = 12632256

' ***** Grand Totals ************
mrow = mrow + 1
.Cells(mrow, 7) = "Monthly Total:"
.Cells(mrow, 9) = Format(TotalCost, "$###,##0.00")
.Cells(mrow, 10) = Format(TotalCost * (1 * 1 /
1.07), "$###,##0.00")
.Range(.Cells(mrow, 7), .Cells(mrow, 11)).Font.Bold =
True
.Range(.Cells(mrow, 1), .Cells(mrow, 12)).Borders
(xlEdgeTop).Weight = XlBorderWeight.xlThick
.Range(.Cells(mrow, 1), .Cells(mrow, 12)).Borders
(xlEdgeTop).LineStyle = XlLineStyle.xlContinuous
.Range(.Cells(mrow, 1), .Cells(mrow, 12)).Borders
(xlEdgeTop).LineStyle = XlLineStyle.xlContinuous
.Range(.Cells(mrow, 1), .Cells(mrow, 12)).Borders
(xlEdgeBottom).Weight = XlBorderWeight.xlThick
.Range(.Cells(mrow, 1), .Cells(mrow, 12)).Borders
(xlEdgeBottom).LineStyle = xlDouble
.Range(.Cells(mrow, 1), .Cells(mrow,
12)).Interior.Color = RGB(200, 200, 255)

rs.Close
db.Close

MsgBox "Finished the Report !!", vbOKOnly +
vbInformation
Else
MsgBox "There are no records for " & Format(DateSerial
(mYear, mMonth, 1), "mmm-yyyy") & " in the DataBase. If
this seems incorrect, then update the main Database
before updating the report.", vbOKOnly + vbInformation
End If
End With


Thanks
Earl Brown
Gillam MB, Canada

 

[onedaywhen]

If you were using ADO you'd get this effect because of the memory leak
bug:

BUG: Memory Leak Occurs When You Query an Open Excel Worksheet Using
ADO
http://support.microsoft.com/default.aspx?scid=kb;en-us;Q319998

I'm not sure whether the same applies to DAO (the technology is from
before my time!) You are querying the ActiveWorkbook so the source
workbook is definitely open. Something to test would be to change your
code to query a closed copy of your workbook to see if you still get
the problem.

--