Slow report creating after x reports

F

fvdb

Registered User.
Local time
Today, 13:33
Joined
Aug 24, 2015
Messages
67
Every night i create a batch reports and send them with email to people.

The first reports go quickly but then memory usage of acces keep growing and then start to get slowly.

I Think i close every recorset that i use but still keep getting slow.

The reports have a chart inside so maybe thats what use the memory.

I need some help to keep getting it smoothly because now i talk about 200 reports but soon will be many more.

I get my data for the reports from 2 SQL servers wich i put in temp table wich i clean after the report is created and then refill same table with new data

This code check a table to determine wich reports have to been created
Code: 
Public Function THistoriek()

Dim rst3 As DAO.Recordset

Set rst3 = CurrentDb.OpenRecordset("Select * from dbo_tbl_Temprapporten_Ontvangers WHERE [SYSTEEM]=1 AND [PERIODE]=1", dbOpenDynaset, dbSeeChanges)
With rst3
    While Not rst3.EOF
        Tagnr = rst3.Fields(3).Value
        TToestel = rst3.Fields(1).Value
        OPMERKING = rst3.Fields(6).Value
        Call GetSauterDaily("" & Tagnr & "", "" & TToestel & "", "" & OPMERKING & "")
        Pause (2)
        .MoveNext
    Wend
End With

Set rst3 = Nothing
    
Set rst3 = CurrentDb.OpenRecordset("Select * from dbo_tbl_Temprapporten_Ontvangers WHERE [SYSTEEM]=2 AND [PERIODE]=1", dbOpenDynaset, dbSeeChanges)
With rst3
    While Not rst3.EOF
        Tagnr = rst3.Fields(3).Value
        TToestel = rst3.Fields(1).Value
        OPMERKING = rst3.Fields(6).Value
        Call GetSiemensDaily("" & Tagnr & "", "" & TToestel & "", "" & OPMERKING & "")
        Pause (2)
        .MoveNext
    Wend
End With

Set rst3 = Nothing

If (Weekday(Date, vbFriday) = 1) Then

Set rst3 = CurrentDb.OpenRecordset("Select * from dbo_tbl_Temprapporten_Ontvangers WHERE [SYSTEEM]=1 AND [PERIODE]=2", dbOpenDynaset, dbSeeChanges)
With rst3
    While Not rst3.EOF
        Tagnr = rst3.Fields(3).Value
        TToestel = rst3.Fields(1).Value
        OPMERKING = rst3.Fields(6).Value
        Call GetSauterWeekly("" & Tagnr & "", "" & TToestel & "", "" & OPMERKING & "")
        Pause (2)
        .MoveNext
    Wend
End With

rst3.Close
Set rst3 = Nothing
    
Set rst3 = CurrentDb.OpenRecordset("Select * from dbo_tbl_Temprapporten_Ontvangers WHERE [SYSTEEM]=2 AND [PERIODE]=2", dbOpenDynaset, dbSeeChanges)
With rst3
    While Not rst3.EOF
        Tagnr = rst3.Fields(3).Value
        TToestel = rst3.Fields(1).Value
        OPMERKING = rst3.Fields(6).Value
        Call GetSiemensWeekly("" & Tagnr & "", "" & TToestel & "", "" & OPMERKING & "")
        Pause (2)
        .MoveNext
    Wend
End With

rst3.Close
Set rst3 = Nothing

End If

Set rst3 = CurrentDb.OpenRecordset("Select * from dbo_tbl_Temprapporten_Ontvangers WHERE [SYSTEEM]=1 AND [PERIODE]=3", dbOpenDynaset, dbSeeChanges)
With rst3
    While Not rst3.EOF
        Tagnr = rst3.Fields(3).Value
        TToestel = rst3.Fields(1).Value
        Call GetSauterErbis("" & Tagnr & "", "" & TToestel & "", "")
        .MoveNext
    Wend
End With

rst3.Close
Set rst3 = Nothing
    
Set rst3 = CurrentDb.OpenRecordset("Select * from dbo_tbl_Temprapporten_Ontvangers WHERE [SYSTEEM]=2 AND [PERIODE]=3", dbOpenDynaset, dbSeeChanges)
With rst3
    While Not rst3.EOF
        Tagnr = rst3.Fields(3).Value
        TToestel = rst3.Fields(1).Value
        Call GetSiemensErbis("" & Tagnr & "", "" & TToestel & "", "")
        .MoveNext
    Wend
End With

rst3.Close
Set rst3 = Nothing
End Function

This code will get the data put it in a table
Code: 
Public Function GetSauterDaily(tagid As String, TNUMMER As String, opm As String)
Dim rst As DAO.Recordset
Dim dt As String
Dim rst2 As DAO.Recordset
Dim conn As ADODB.Connection
Dim rs As ADODB.Recordset
Dim strSQL As String
Dim rs2 As DAO.Recordset

    Set conn = New ADODB.Connection
    Set rs = New ADODB.Recordset
    Set rst2 = CurrentDb.OpenRecordset("dbo_tbl_Temprapporten_Historiek", dbOpenDynaset, dbSeeChanges)

dt = 1000 * DateDiff("s", #1/1/1970 2:00:00 AM#, Now() - 1.1)
tagid2 = (65536 * 10) + tagid

    conn.Open "Driver={SQL Server};" & _
                   "Server=CI2008BAZUUR;" & _
                   "Database=NPO_VfiTag;" & _
                   "Trusted_Connection=Yes"
    

    strSQL = "SELECT [time], [gateId], [flags], [value]" & _
            "FROM [VfiTagNumHistory] " & _
            "WHERE ([time] > '" & dt & "')" & _
            "AND ([gateId] = '" & tagid2 & "') " & _
            "AND ([flags] = '2')"

    rs.Open strSQL, conn, adOpenForwardOnly

If Not (rs.EOF And Not rs.BOF) Then
Do Until rs.EOF
    With rst2
        .AddNew
        newtime = DateAdd("s", rs.Fields(0).Value / 1000, #1/1/1970 2:00:00 AM#)
        .Fields(1).Value = TNUMMER
        .Fields(2).Value = newtime
        .Fields(3).Value = rs.Fields(3).Value
        .Update
        rs.MoveNext
    End With
Loop
End If

    rst2.Close
    Set rst2 = Nothing
    rs.Close
    Set rs = Nothing

    conn.Close
    Set conn = Nothing

    'alarmhsitoriek
    Set conn = New ADODB.Connection
    Set rst2 = CurrentDb.OpenRecordset("dbo_tbl_Temprapporten_Alarmen", dbOpenDynaset, dbSeeChanges)
    
    conn.Open "Driver={SQL Server};" & _
               "Server=CI2008BAZUUR;" & _
               "Database=NPO_VfiAlarm;" & _
               "Trusted_Connection=Yes"
               
    strSQL = "SELECT [Start_Time],[End_Time],[Text] " & _
            "FROM [VfiAlarmHistory] " & _
            "WHERE [text] like '%" & TNUMMER & "%'"
            
    rs.Open strSQL, conn, adOpenForwardOnly
    
    If Not (rs.EOF And rs.BOF) Then
    With rs
        .MoveFirst
        While Not .EOF
            With rst2
                .AddNew
                newtime = DateAdd("s", rs.Fields(0).Value / 1000, #1/1/1970 2:00:00 AM#)
                .Fields(1).Value = newtime
                .Fields(2).Value = "IN ALARM"
                .Fields(3).Value = rs.Fields(2).Value
                .Fields(4).Value = TNUMMER
                .Update
                .AddNew
                newtime = DateAdd("s", rs.Fields(1).Value / 1000, #1/1/1970 2:00:00 AM#)
                .Fields(1).Value = newtime
                .Fields(2).Value = "UIT ALARM"
                .Fields(3).Value = rs.Fields(2).Value
                .Fields(4).Value = TNUMMER
                .Update
                rs.MoveNext
            End With
        Wend
    End With
    End If
    rs.Close
    Set rs = Nothing
    rst2.Close
    Set rst2 = Nothing
    conn.Close
    Set conn = Nothing
    
    Call SetTnummer(TNUMMER)
    Call SetOpmerking(opm)
    Wie = DLookup("ONTVANGER", "dbo_tbl_Temprapporten_Ontvangers", "[T-Nummer] = '" & TNUMMER & "'")
    Ond = "Historische Gegevens GBS voor " & TNUMMER
    Call SendEmail("" & Wie & "", "" & Ond & "", , "filip.vandenbosch@uzleuven.be", "rpt_Temprapporten_Historiek")
    DoCmd.RunSQL ("DELETE * FROM dbo_tbl_Temprapporten_Historiek")
    DoCmd.RunSQL ("DELETE * FROM dbo_tbl_Temprapporten_Alarmen")

End Function

another one because have more systems (SQL's) to get data from

Code: 
Public Function GetSiemensDaily(tagid As String, TNUMMER As String, opm As String)
Dim conn As ADODB.Connection
Dim rs As ADODB.Recordset
Dim strSQL As String
Dim rs2 As DAO.Recordset
    Set conn = New ADODB.Connection
    Set rs = New ADODB.Recordset
    
    'Gelogde waardes
    Set rst2 = CurrentDb.OpenRecordset("dbo_tbl_Temprapporten_Historiek", dbOpenDynaset, dbSeeChanges)
    
    conn.Open "Driver={SQL Server};" & _
                   "Server=SQLCI2008R;" & _
                   "Database=DIV23!PRJ=UZ_Leuven!DB=ISHTTND;" & _
                   "Trusted_Connection=Yes"
    

    strSQL = "SELECT [DateTimeStamp],[Value] FROM [TrendRecord] " _
                & "WHERE [TrendLogId] = '" & tagid & "' And [DateTimeStamp] > Getdate()-1.1 AND [Qualitytag]='192'"
    
    rs.Open strSQL, conn, adOpenForwardOnly
    If Not (rs.EOF And rs.BOF) Then
    With rs
        .MoveFirst
        While Not .EOF
            With rst2
                .AddNew
                .Fields(1).Value = TNUMMER
                .Fields(2).Value = rs.Fields(0).Value
                .Fields(3).Value = rs.Fields(1).Value
                .Update
                rs.MoveNext
            End With
        Wend
    End With
    End If
    
rs.Close
Set rs = Nothing
rst2.Close
Set rst2 = Nothing
conn.Close
Set conn = Nothing

    
    'Alarmhistory
    Set rst2 = CurrentDb.OpenRecordset("dbo_tbl_Temprapporten_Alarmen", dbOpenDynaset, dbSeeChanges)
    
    conn.Open "Driver={SQL Server};" & _
               "Server=SQLCI2008R;" & _
               "Database=DIV23!PRJ=UZ_Leuven!DB=ISHTLOG;" & _
               "Trusted_Connection=Yes"
    
    strSQL = "SELECT [DateTimeStamp],[EventText],[TechDescription],[ArgValueReal],[ArgUnitText] " _
            & "FROM [LogEntry] " _
            & "WHERE [EventText] IN ('alarm into', 'alarm low', 'alarm high', 'alarm return to normal','alarm fault') " _
            & "AND [MgtStationName] = 'desigo1' " _
            & "AND [TechDescription] like '%" & TNUMMER & "%'" _
            & "AND [DateTimeStamp] > getdate() -1 " _
            & "order by [DateTimeStamp] asc"
    
    rs.Open strSQL, conn, adOpenForwardOnly
    If Not (rs.EOF And rs.BOF) Then
    With rs
        .MoveFirst
        While Not .EOF
            With rst2
                .AddNew
                .Fields(1).Value = rs.Fields(0).Value
                .Fields(2).Value = rs.Fields(1).Value
                .Fields(3).Value = rs.Fields(2).Value
                .Fields(4).Value = TNUMMER
                .Fields(5).Value = rs.Fields(3).Value
                .Fields(6).Value = rs.Fields(4).Value
                .Update
                rs.MoveNext
            End With
        Wend
    End With
    End If
rs.Close
Set rs = Nothing
rst2.Close
Set rst2 = Nothing
conn.Close
Set conn = Nothing

    Call SetTnummer(TNUMMER)
    Call SetOpmerking(opm)
    Wie = DLookup("ONTVANGER", "dbo_tbl_Temprapporten_Ontvangers", "[T-Nummer] = '" & TNUMMER & "'")
    Ond = "Historische Gegevens GBS voor " & TNUMMER
    Call SendEmail("" & Wie & "", "" & Ond & "", , "filip.vandenbosch@uzleuven.be", "rpt_Temprapporten_Historiek")
    DoCmd.RunSQL ("DELETE * FROM dbo_tbl_Temprapporten_Historiek")
    DoCmd.RunSQL ("DELETE * FROM dbo_tbl_Temprapporten_Alarmen")
    
End Function

and this is the email function
Code: 
Public Function SendEmail(Email_To As String, Subject As String, Optional Body As String, Optional Email_BCC As String, Optional rapport As String, Optional printout As String) As Boolean
  Dim Msg As String
  Dim bStarted As Boolean
  Dim oOutlookApp As Outlook.Application
  Dim oItem As Outlook.MailItem
  Dim NotificationTypeDescription As String
  Dim DocPath As String
  
  On Error Resume Next
  Set oOutlookApp = GetObject(, "Outlook.Application")
  If Err <> 0 Then
    Set oOutlookApp = CreateObject("Outlook.Application")
    bStarted = True
  End If
  
  Set oItem = oOutlookApp.CreateItem(olMailItem)
  
  With oItem
    If LenB(Email_To) <> 0 Then .To = Email_To
    If Not IsNull(Email_BCC) And LenB(Email_BCC) <> 0 Then .CC = Email_BCC
    .Subject = Subject
    .Body = Body
    .BodyFormat = olFormatPlain
    'Add the document as an attachment, you can use the .displayname property
    'to set the description that's used in the message
    If Not IsNull(Attachdoc) Then
        DocPath = CurrentProject.path & "\Temp\"
        'DoCmd.OpenReport rapport, acViewPreview, , , acWindowNormal
        DoCmd.OutputTo acOutputReport, rapport, acFormatPDF, DocPath & rapport & ".PDF", False
        If (printout = "y") Then DoCmd.printout
        .Attachments.Add DocPath & rapport & ".PDF"
    End If
    .Send
  End With
          DoCmd.Close acReport, rapport
          
  If bStarted Then
'    MsgBox "Sending email re:" & Chr$(13) & Subject & Chr$(13) & Chr$(13) & "(You will need to CLICK YES AGAIN when MS Outlook asks" & Chr$(13) & "whether to permit this...)", vbOKOnly, "Sending Automatic Email..."
    oItem.Send
    ' oOutlookApp.Quit
  Else
    oItem.Display
  End If
  
  On Error Resume Next
  Set oItem = Nothing
  Set oOutlookApp = Nothing
  SendEmailViaOutlook = True
End Function

The full db

https://drive.google.com/file/d/0BynMVePAwPceQ3R4TEtGc3E4REk/view?usp=sharing

screenshot of memory when still creating reports an did create 90 reports as attachment


If anybody have suggestions or solutions to speed it up I will be very happy :)
 

Attachments

  • Naamloos.png
    Naamloos.png
    28.4 KB · Views: 192
Last edited:
I suggest commenting out some of the code to narrow down the issue.
 
speakers_86 said:
I suggest commenting out some of the code to narrow down the issue.
Click to expand...

The code works butt it start to get slow after 15 reports and access use a lot of memory, when the memory goes up to 720 Mb then i get error messages like error 91

I learn a lot of myself with the help of this forum but this one i working last full week on it because the amount of reports grown up and now get some issues. I'm sure i make some mistakes but can not find them ... :|

How can i comment some code out and still keep it working? I Used breakpoints, the debug window, variable window ...

I think the mem usage is the problem and did many searches how to solve it and the only thing i find is to close recordsets that you use and I think I do but not sure anymore ... That why i ask you people to have a look and maybe you see something i overloook?

Tnx allready
 
Why are you declaring all of these as functions? A function should return an answer, and I don't see these returning anything. Try changing them to sub. I doubt that is your issue, but it isn't great practice, especially since the missing result is a variant since you didn't declare the data type.

For the comment step I mentioned, start at the very bottom of the order of operations. It looks like it is the email routine. Comment that whole block out.

Once you verify that is not causing the issue, comment the GetSauterDaily routine, and after that, comment the GetSiemensDaily routine. When the issue is resolved, you should have the problem narrowed down.
 
You've a lot of opening and closing connections to servers in your code, which is time consuming, can't you use the same connection?
I've a feeling of that the system not get time enough to "clean up" after it self, before the next block of code is executed, maybe some DoEvents could help, but as written it is only a felling I have, which is supported by fact you write the system gets slower and slower.
You've also a lot of loops with recordset, I think some of them could be replaced by queries writing directly in a table at once.
 
I added the doevents
I changed to subs
i commented out the email, speeds ups, commented out int the email sub the docmd.outputto line and speeds ups. commented out also docmd.openreport doesnt change

Seems the docmd.outputto uses the memory but don't free it after the job

Somebody some tricks to free the memory

Code: 
Option Compare Database

Public Sub SendEmail(Email_To As String, Subject As String, Optional Body As String, Optional Email_BCC As String, Optional rapport As String, Optional printout As String)
  Dim Msg As String
  Dim bStarted As Boolean
  Dim oOutlookApp As outlook.Application
  Dim oItem As outlook.MailItem
  Dim NotificationTypeDescription As String
  Dim DocPath As String
  
  On Error Resume Next
  Set oOutlookApp = GetObject(, "Outlook.Application")
  If Err <> 0 Then
    Set oOutlookApp = CreateObject("Outlook.Application")
    bStarted = True
  End If
  
  Set oItem = oOutlookApp.CreateItem(olMailItem)
  
  With oItem
    If LenB(Email_To) <> 0 Then .To = Email_To
    If Not IsNull(Email_BCC) And LenB(Email_BCC) <> 0 Then .CC = Email_BCC
    .Subject = Subject
    .Body = Body
    .BodyFormat = olFormatPlain
    'Add the document as an attachment, you can use the .displayname property
    'to set the description that's used in the message
    If Not IsNull(Attachdoc) Then
        DocPath = CurrentProject.path & "\Temp\"
        DoCmd.OpenReport rapport, acViewPreview, , , acWindowNormal
        DoCmd.OutputTo acOutputReport, rapport, acFormatPDF, DocPath & rapport & ".PDF", False, , , acExportQualityScreen
    
        If (printout = "y") Then DoCmd.printout
        .Attachments.Add DocPath & rapport & ".PDF"
        DoCmd.Close acReport, rapport
        DoEvents
    End If
    .Send
  End With
  
  'DoCmd.SendObject acSendReport, rapport, acFormatPDF, Email_To, "filip.vandenbosch@uzleuven.be", , Subject, Body, False
          
  If bStarted Then
'    MsgBox "Sending email re:" & Chr$(13) & Subject & Chr$(13) & Chr$(13) & "(You will need to CLICK YES AGAIN when MS Outlook asks" & Chr$(13) & "whether to permit this...)", vbOKOnly, "Sending Automatic Email..."
    oItem.Send
    ' oOutlookApp.Quit
  'Else
    'oItem.Display
  End If
  
  On Error Resume Next
  Set oItem = Nothing
  Set oOutlookApp = Nothing
  SendEmailViaOutlook = True
  DoEvents
  
End Sub
 
tried with pdf creator and no succes,this proofs the reports keep staying in the memory
 
fvdb said:
Code: 
        DoCmd.OpenReport rapport, acViewPreview, , , acWindowNormal
        DoCmd.OutputTo acOutputReport, rapport, acFormatPDF, DocPath & rapport & ".PDF", False, , , acExportQualityScreen
Click to expand...

Hi fvdb,
I vaguely remember seeing somewhere that ommitting the name of the report in the OutputTo statement (ie. writing it as
Code: 
 DoCmd.OutputTo acOutputReport, "", acFormatPDF,,,
) after opening the report in preview mode has effect on the way the output objects are handled. Can't remember if this had an effect on the objects when closing the report, but you might want to try it to see if it helps your issue.

Best,
Jiri
 
Solo712 said:
Hi fvdb,
I vaguely remember seeing somewhere that ommitting the name of the report in the OutputTo statement (ie. writing it as
Code: 
 DoCmd.OutputTo acOutputReport, "", acFormatPDF,,,
) after opening the report in preview mode has effect on the way the output objects are handled. Can't remember if this had an effect on the objects when closing the report, but you might want to try it to see if it helps your issue.

Best,
Jiri
Click to expand...

Thanks for the reply, tried it but bad luck :(
 
i solved the issue to make seperate DB with the mail function. The call this function from the Main DB en after close the seperate DB, this clean the memory after each report. Tried many things the last 3 days and this is the only things what works.
 
That sounds like a temporary solution. I think you should keep investigating this.
 
speakers_86 said:
That sounds like a temporary solution. I think you should keep investigating this.
Click to expand...

I investigated all the options and the problem is that the report creation (docmd.outputto or docmd.openreport and then printout as PDF with pdfcreator or docmd.sendobject) keeps the reports in the memory.

All the rest of the recordsets,... are closed. Now my DB keeps running at 20Mb memory.

Any suggestions are welcome but i think its a memory leak of access itself.

I also tried installing O2016 and same problem.
 
You must log in or register to reply here.

Similar threads

B
  • Solved
Solved Help with recordset
Replies
6
Views
444
Pat Hartman
P
N
Solved Receiving Emails in Access Database using CDO 2000 library
Replies
10
Views
347
sonic8
S
N
Solved Failing To Save Imported Data from the internet in Ms Access
Replies
6
Views
428
nector
N
J
Unable to add record because of read only access
Replies
12
Views
373
Gasman
Gasman
A
how to insert attachment in sharepoint list using ado access vba
Replies
3
Views
755
theDBguy
theDBguy

Users who are viewing this thread

Total: 1 (members: 0, guests: 1)
Back
Top Bottom