none
Access vba memory leak RRS feed

  • Question

  • Memory kept growing for MSACCESS

    All I did was using a form and VBA module to regularly retrieve data from sensors and update/insert data in Access and Excel, I closed all Recordset after using them, but the memory is seemed to be creeping up slowly, how should I solve this problem?

    I also got an error '3981' last night, and according to what I had found online, I added an index to one of the columns on sharepoint, but didn't know if this is going to solve my problem...

    Global num(26) As Integer Global dict_pre_Signal As Scripting.Dictionary Global dict_pre_Time As Scripting.Dictionary Private Sub Form_Load() Set Module1.dict_pre_Signal = New Scripting.Dictionary Set Module1.dict_pre_Time = New Scripting.Dictionary ' initialize the array to store pre-status voltage for each line ' read data from txt file to retrieve the last saved data ' and initialize the dictionary Dim fileName, lineNum, textRow As String, signal As Double, pre_DateTime As Date, fileNo As Integer fileName = "\\cp-apps01\ExtruderDataCollector\TESTING\log.txt" fileNo = FreeFile Open fileName For Input As #fileNo Dim arr() As String Do While Not EOF(fileNo) Line Input #fileNo, textRow If StrComp(textRow, "") = 0 Then Exit Do End If arr = Split(textRow) lineNum = arr(0) signal = CDbl(arr(1)) pre_DateTime = DateValue(arr(2)) + TimeValue(arr(3)) Module1.dict_pre_Signal.Add lineNum, signal Module1.dict_pre_Time.Add lineNum, pre_DateTime Loop End Sub Private Sub Form_Timer() Call mainFunc End Sub Private Sub Form_Unload(Cancel As Integer) ' update the data in txt, signal and datetime Dim fso As New FileSystemObject 'the file we're going to write to Dim ts As TextStream 'open this file to write to it Set ts = fso.CreateTextFile("\\cp-apps01\ExtruderDataCollector\TESTING\log.txt", True) For Each Key In Module1.dict_pre_Signal.Keys ts.WriteLine (Key & " " & Module1.dict_pre_Signal.Item(Key) & " " _ & DateValue(CStr(Module1.dict_pre_Time.Item(Key))) & " " _ & TimeValue(CStr(Module1.dict_pre_Time.Item(Key)))) Next Key ts.Close End Sub Sub mainFunc() Dim wsh As Object Set wsh = VBA.CreateObject("WScript.Shell") Dim waitOnReturn As Boolean: waitOnReturn = True Dim windowStyle As Integer: windowStyle = 0 Dim shellCmd, shellPath, filePath As String shellPath = "\\cp-apps01\ExtruderDataCollector\TESTING\" filePath = shellPath & "output.txt" shellCmd = shellPath & "TST10.exe" & " /r:" _ & shellPath & "script.txt" & " /o:" & filePath & " /m" wsh.Run shellCmd, windowStyle, waitOnReturn Set wsh = Nothing

    Dim re As Object Set re = CreateObject("VBScript.RegExp") Dim strPattern As String: strPattern = "\s+" With re .Pattern = strPattern .Global = True End With Dim combine_Date_Time As Date Dim lineNum As String Dim signal As Double Dim strTextLine As String Dim FileNum As Integer FileNum = FreeFile Open filePath For Input As #FileNum Set db = CurrentDb While Not EOF(FileNum) Line Input #FileNum, strTextLine strTextLine = re.Replace(strTextLine, " ") strTextLine = Trim(strTextLine) Dim param_Array() As String param_Array = Split(strTextLine) Dim SQLst As String ' Dim rs As DAO.Recordset If UBound(param_Array) = 4 Then ' check the time inverval between currTime and preTime combine_Date_Time = DateValue(param_Array(0)) + TimeValue(param_Array(1)) lineNum = param_Array(2) ' skip the 3rd element signal = CDbl(param_Array(4)) Dim dt_ID As String dt_ID = lineNum & Format(combine_Date_Time, "yyyyMMddhhmmss") If signal < 1 Then ' check if the curr lineNum has been defined in the dictionary If Module1.dict_pre_Signal.Exists(lineNum) Then ' check if the current time is down and if curr time is within 3 mins diff from pre time If Module1.dict_pre_Signal.Item(lineNum) < 1 And DateDiff("s", Module1.dict_pre_Time.Item(lineNum), combine_Date_Time) < 300 Then ' Update the old downtime entry SQLst = "UPDATE TS_Downtime_Entry AS tb_1 SET tb_1.[End] = #" & combine_Date_Time & "# WHERE exists " _ & "(select top 1 * from TS_Downtime_Entry as tb_2 where tb_2.lineNo = '" & lineNum & "' and tb_2.Downtime_ID = tb_1.Downtime_ID ORDER BY tb_2.Downtime_ID DESC);" db.Execute SQLst, dbFailOnError Else ' Insert new downtime entry SQLst = "INSERT INTO TS_Downtime_Entry (Title, LineNo, Downtime_ID, Start, [End]) SELECT 'Test', '" _ & lineNum & "', '" & dt_ID & "', #" & combine_Date_Time & "#, #" & combine_Date_Time & "#" db.Execute SQLst, dbFailOnError End If Else Module1.dict_pre_Signal.Add lineNum, 10 Module1.dict_pre_Time.Add lineNum, combine_Date_Time ' Insert SQLst = "INSERT INTO TS_Downtime_Entry (Title, LineNo, Downtime_ID, Start, [End]) SELECT 'Test', '" _ & lineNum & "', '" & dt_ID & "', #" & combine_Date_Time & "#, #" & combine_Date_Time & "#" db.Execute SQLst, dbFailOnError End If End If Module1.dict_pre_Signal.Item(lineNum) = signal Module1.dict_pre_Time.Item(lineNum) = combine_Date_Time End If Wend Close #FileNum
    Set re = Nothing

    Dim currDate_Time As Date Dim strDateTime As String ' Get current datetime currDate_Time = Now() ' convert datetime into string strDateTime = Format(currDate_Time, "yyyyMMddHHmmss") ' Separate current Date and time Dim fileDate As String Dim currTm As String fileDate = Mid(strDateTime, 1, 8) currTm = Mid(strDateTime, 9, 4) Dim timeList_() As Variant timeList_ = Array("1000") If is_in(timeList_, currTm) = 1 Then ' Dim SQLst As String ' SQLst = "appending" filePath = "U:\Data Analysis\TS_Downtime_Entry_System\TS_downtime_analysis.xlsx" ' DoCmd.OutputTo acOutputQuery, SQLst, acFormatXLSX, filePath, False Dim xls As Excel.Application Dim wkb As Excel.Workbook Dim wks As Excel.Worksheet Set xls = New Excel.Application Set wkb = xls.Workbooks.Open(filePath) Set wks = wkb.Worksheets(1) Set appdx = wkb.Worksheets(2) Dim from_Date As Date Dim to_Date As Date from_Date = appdx.Cells(1, "B").Value to_Date = DateValue(Now()) to_Date = DateAdd("h", 6, to_Date) Dim SQLst_ As String Dim rs_Excel As DAO.Recordset SQLst_ = "Select * from TS_Downtime_Entry where End > #" & from_Date & "# and End <= #" & to_Date & "#" Set rs_Excel = db.OpenRecordset(SQLst_) Dim lastRow As Integer startRow = wks.Range("A:A").SpecialCells(11).Row + 1 If StrComp(wks.Cells(startRow - 1, "A").Value, "") = 0 Then startRow = startRow - 1 End If Do Until rs_Excel.EOF = True ' Move to the next record. Don't ever forget to do this. wks.Cells(startRow, "A").Value = rs_Excel!LineNo wks.Cells(startRow, "B").Value = rs_Excel!Downtime_ID wks.Cells(startRow, "C").Value = rs_Excel!Start wks.Cells(startRow, "D").Value = rs_Excel!End wks.Cells(startRow, "F").Value = rs_Excel!Module wks.Cells(startRow, "G").Value = rs_Excel!Symptom startRow = startRow + 1 rs_Excel.MoveNext Loop appdx.Cells(1, "B").Value = to_Date wkb.Close True Set wks = Nothing Set appdx = Nothing Set wkb = Nothing xls.Quit Set xls = Nothing Set rs_Excel = Nothing Dim SQL_Count_Total As String ' Step #1: Check the total count of downtime entries SQL_Count_Total = "SELECT count(*) as NumofEnt FROM TS_Downtime_Entry;" Dim rs_ As DAO.Recordset Set rs_ = db.OpenRecordset(SQL_Count_Total) Dim total_ As Integer Do Until rs_.EOF = True total_ = rs_!NumofEnt rs_.MoveNext Loop Set rs_ = Nothing ' Archive the data if the total # of entries is greater than 4500 If total_ > 4500 Then ' Step #2: count the number of entries to be deleted for each line ' And, save them in a integer array Dim remain As Integer remain = 30 Dim SQL_count As String SQL_count = "SELECT LineNo, count(*) - " _ & remain & " AS remain FROM TS_Downtime_Entry" _ & "GROUP BY LineNo;" Dim rs_dup As DAO.Recordset Set rs_dup = db.OpenRecordset(SQL_count) Do Until rs_dup.EOF = True ' Step #3: Archive the data, insert and delete Dim SQL_insert As String SQL_insert = "INSERT INTO ArchivingData (LineNo, Downtime_ID, Start, End, Module, Symptom) " _ & "SELECT top " & rs_dup!remain & " tb.LineNo, tb.Downtime_ID, tb.Start, tb.End, M.[Module Code], R.[Reason Code] " _ & "FROM (SELECT LineNo, Downtime_ID, Start, End, Module, Symptom " _ & "FROM TS_Downtime_Entry " _ & "WHERE LineNo = '" & rs_dup!LineNo & "') AS tb " _ & "LEFT JOIN [Module] AS M " _ & "ON tb.Module = M.ID " _ & "LEFT JOIN [Reason Code] AS R " _ & "ON tb.Symptom = R.ID ORDER BY tb.Downtime_ID" db.Execute SQL_insert, dbFailOnError ' Step #4: Delete the archived data from the original table Dim SQL_delete As String SQL_delete = "DELETE DLonSP.* " _ & "FROM TS_Downtime_Entry AS DLonSP" _ & "WHERE Exists (" _ & "Select 1 From " _ & "(SELECT TOP " & rs_dup!remain & " LineNo, Downtime_ID " _ & "FROM TS_Downtime_Entry WHERE lineNo = '" & rs_dup!LineNo & "' ORDER BY Downtime_ID) as tb" _ & "Where tb.Downtime_ID = DLonSP.Downtime_ID" _ & ") = True;" db.Execute SQL_delete, dbFailOnError 'Move to the next record. Don't ever forget to do this. rs_dup.MoveNext Loop Set rs_dup = Nothing End If End If End Sub Function is_in(timeList() As Variant, time_check As String) As Integer For n = LBound(timeList) To UBound(timeList) ' for some reason, comparing string variables with = would not give correct result ' So, for all string variables comparison, I am going to use StrComp build-in function ' which, returns 1 if str1 > str2, 0 if str1 == str2, -1 if str1 < str2 If StrComp(time_check, timeList(n)) = 0 Then ' the returning variable has to have the same name as the function name is_in = 1 ' there is no return in VBA, so using Exit Function instead Exit Function End If Next n is_in = 2 End Function




    • Edited by Aaron Geng Wednesday, September 6, 2017 6:37 PM
    Wednesday, September 6, 2017 4:37 PM

All replies

  • Aaron,
    re: memory use

    I don't do Access and there is a lot of code to go thru, but I did notice this...
       Static re As Object
        Set re = CreateObject("VBScript.RegExp")
        Dim strPattern As String: strPattern = "\s+"
        With re
            .Pattern = strPattern
            .Global = True
        End With
    I don't see where you release the object and it appears to be used only once.
    Why not...
    Dim re As Object
    Set re = CreateObject("VBScript.RegExp")
    'code
    Set re = Nothing
    '---

    Jim Cone
    Portland, Oregon USA
    https://goo.gl/IUQUN2 (Dropbox)
    (free & commercial excel add-ins & workbooks)

    Wednesday, September 6, 2017 5:12 PM
  • Hi Jim,

    Thanks for pointing it out, I also close the shell script object. Don't know if it is the cause, but I am monitoring it, see if the memory keeps growing or not.

    Do you have any idea or thought about how to solve the second problem? 

    Wednesday, September 6, 2017 6:41 PM
  • Aaron,
    Re:  error 3981

    Can't help with that.
    '---
    Jim Cone
    Wednesday, September 6, 2017 7:28 PM