Slow Loading form

D

Dreamweaver

Well-known member
Local time
Today, 03:52
Joined
Nov 28, 2005
Messages
2,467
Hi All Currently working on vesion 4 of the employees example


my problem is I have a screen as below which has at the moment 38 employees records but the screen takes 9-10 seconds to load Hopefully somebody can help speed it up.


I have taken steps and use a load warning screen which works nicely
this is a timesheet entry/viewer screen and has a lot of data to lookup in the form of:

  1. Timesheet Data
  2. Public holidays and company closures these are both in a union query
  3. The total hours and total overtime for the displayed month
  4. Booked holidays which is colour coded with 7 conditional formats x31 controls.
All the above is required so the user would have a visual indication before adding time of that employees/company status.


I would post a copy but there are to many errors I need to correct with the entry system as I have combined The Time And Overtime into one field thereby enableing me to remove 31 controls.
once I update the entry code I will post a copy if still needed



but the system wont prevent time being added esp on bank holiday etc.


Edit: Up until I added the employee holidays the screen would open in 3-4 seconds with the 38 records.

attachment.php


attachment.php
Code Runs first

Code: 
Public Sub TimeSheet(F As Object)
    Dim I As Integer, M As Integer, Y As Integer
    Dim DayOne As Date
    Dim E As Long
    Dim WD As Boolean, WDL As String
    Dim Rst As DAO.Recordset
'Started 10/08/2019 M Javes
'Edits
'
On Error GoTo HandleErr
    'Reset All Controls back to there defaults
    For I = 1 To 31 'Start a loop thought the month stoping on last day of month even if it's feb and 28 days
        F("Time" & I).Visible = False
        F("Time" & I).BackColor = vbWhite
        F("Label" & I).Visible = False
        F("MD" & I).Visible = False
    Next 'Move to next I

    'Get the current month and year as selected
    M = Forms!frmTimeSheet!Cmonth
    Y = Forms!frmTimeSheet!Cyear
    'Lookup The Working Day List
    WDL = DLookup("WorkingDays", "StblPreferences")
    
     DayOne = DateValue("1/" & M & "/" & Y) 'Set the first of the month for current month/year
     
     For I = 1 To LenMonth(DayOne) 'Start a loop thought the month stoping on last day of month even if it's feb and 28 days
        'Only diplay the lables in the current month
        F("Label" & I).Visible = True
        F("MD" & I).Visible = True
       ' F("CmdH" & I).Visible = True
        F("Label" & I).Caption = Format(DateValue(I & "/" & M & "/" & Y), "ddd") 'Show the day but like mon, tue, wed, thu, fri, sat, sun
        F("MD" & I).Caption = GetMDExtra(I) 'Update each label below the short day so it displays 2nd, 24th etc
        F("Time" & I).Visible = True 'All controls are set visible = false when form opens this changes that for the days in the selected month
        F("Time" & I).Tag = DateValue(I & "/" & M & "/" & Y) ' Store the Date for each field using the time field
        'Check For A Working Day
        WD = InStr(WDL, Format(DateValue(I & "/" & M & "/" & Y), "w")) <> 0 'If not 0 then this will return true
        'Update The Back Colours If not a working Day
        If WD = False Then
            F("Time" & I).BackColor = 15066597
        End If
        'Show the current date using the prefences colour just to keep the program cosistant
        If Format(DateValue(I & "/" & M & "/" & Y), "\#mm\/dd\/yyyy\#") = Format(Date, "\#mm\/dd\/yyyy\#") Then
            F("MD" & I).ForeColor = DLookup("CurrentDateColour", "StblPreferences")
        Else
            F("MD" & I).ForeColor = vbWhite
        End If
'Highlight public holidays in selected colors
    Set Rst = CurrentDb.OpenRecordset("SELECT * FROM tblPublicHols WHERE HolidayDate = " & Format(DateValue(I & "/" & M & "/" & Y), "\#mm\/dd\/yyyy\#"), dbOpenSnapshot)
        If Rst.RecordCount <> 0 Then
            F("Time" & I).BackColor = Rst!ChartColor      'and set color
        End If
    
'M Javes Edit Look For Any Company Closure Dates These should not be in tblpublicHols
    Set Rst = CurrentDb.OpenRecordset("SELECT * FROM QryClosureHolidays WHERE EventDate = " & Format(DateValue(I & "/" & M & "/" & Y), "\#mm\/dd\/yyyy\#"), dbOpenSnapshot)
        If Rst.RecordCount <> 0 Then
        F("Time" & I).BackColor = Rst!HolidayColour      'and set color
        End If


     Next 'Move to next I
     
     'Now get the data to display
     ShowTimeData
    
    Rst.Close
    Set Rst = Nothing

HandleExit:
   Exit Sub
    
    
HandleErr:
    Select Case Err.Number
        Case 2501 'Cancel = True
            Exit Sub
        Case Else
            MsgBox Err.Number & vbCrLf & Err.Description
            'Call GlobalErrs(Err.Number, Err.Description, Err.Source, "ModCalendar", "Sub: TimeSheet")
            Resume HandleExit
        Resume
    End Select
End Sub
Second
Code: 
Public Sub ShowTimeData()
Dim E As Recordset, RC As Recordset
Dim M As Integer, I As Integer, H As Integer
Dim Y As Long
Dim S As String
Dim SO As String

On Error GoTo HandleErr
    'Get the current month and year as selected
    M = Forms!frmTimeSheet!Cmonth
    Y = Forms!frmTimeSheet!Cyear
    
    'Before We do anything clear all old data
    CurrentDb.Execute "QryUpdateMonthDataNull"
    'Check for admin if not then filter the departments for the ones assigned to this manager
    If Not CheckIsAdminL And HasDepts <> 0 Then 'Admin should not have any assigned departments as they can see everything
        Set E = CurrentDb.OpenRecordset("SELECT * FROM QryTimeSheetLimited WHERE EmpID=" & Forms!frmDetectIdleTime!txtUser, dbOpenSnapshot)
    Else
        Set E = CurrentDb.OpenRecordset("SELECT * FROM tbxMonthData", dbOpenSnapshot)
    End If

        
    Do While Not E.EOF
    
                For I = 1 To LenMonth(DateValue("1/" & M & "/" & Y))
                    H = GetDayHoliday(DateValue(I & "/" & M & "/" & Y), E("EmployeeID"))
                    If Not IsNothing(H) Then
                        CurrentDb.Execute "UPDATE tbxMonthData SET Hol" & I & "=" & H & " WHERE [EmployeeID]=" & E("EmployeeID"), dbFailOnError
                    End If
                Next I
            Set RC = CurrentDb.OpenRecordset("SELECT EntryDate,HoursWorked,Overtime FROM tblTmesheet WHERE [EmployeeID]=" & E("EmployeeID") & " AND Month([EntryDate]) =" & M & " AND Year([EntryDate]) =" & Y, dbOpenSnapshot)
                With RC
                    Do While Not .EOF
                        CurrentDb.Execute "UPDATE tbxMonthData SET Time" & Format(RC!EntryDate, "d") & "=" & Chr(34) & Format(RC!HoursWorked, "hh:nn") & _
                        Format(RC!Overtime, "hh:nn") & Chr(34) & " WHERE [EmployeeID]=" & E("EmployeeID"), dbFailOnError
                    .MoveNext
                    Loop
                End With
                S = CalcTime(E("EmployeeID"), M, Y)
                SO = CalcOverTime(E("EmployeeID"), M, Y)
                CurrentDb.Execute "UPDATE tbxMonthData SET [TimeTotal]=" & Chr(34) & S & Chr(34) & ",[OvertimeTotal]=" & Chr(34) & SO & Chr(34) & " WHERE [EmployeeID]=" & E("EmployeeID"), dbFailOnError
        E.MoveNext
    Loop
    


HandleExit:
    Exit Sub
    
HandleErr:
    Select Case Err.Number
        Case 2501 'Cancel = True
            Exit Sub
        Case Else
            MsgBox Err.Number & vbCrLf & Err.Description
            Resume HandleExit
        Resume
    End Select
End Sub

Public Function GetHolDisplay(D As Date, I As Integer) As String
    'I Is Not Used but has been left as might be useful later
    
            GetHolDisplay = D & " " & DLookup("Comments", "QryPublicAndCompanyClosuresLookup", "HDate = " & Format(D, "\#mm\/dd\/yyyy\#"))  'update Info control

End Function

Private Function GetDayHoliday(D As Date, E As Long) As Integer
Dim SQL As DAO.Recordset

On Error GoTo HandleErr

        Set SQL = CurrentDb.OpenRecordset("SELECT * FROM QryHolidayChecker WHERE [EmployeeID]=" & E & " AND [StartDate] <=" & Format(D, "\#mm\/dd\/yyyy\#") & " AND [EndDate] >=" & Format(D, "\#mm\/dd\/yyyy\#"), dbOpenSnapshot)
        If SQL.RecordCount <> 0 Then GetDayHoliday = SQL("HolidayType")
        
SQL.Close
Set SQL = Nothing

HandleExit:
    Exit Function
    
HandleErr:
    Select Case Err.Number
        Case 2501 'Cancel = True
            Exit Function
        Case Else
            MsgBox Err.Number & vbCrLf & Err.Description
            Resume HandleExit
        Resume
    End Select
End Function
Other functions These need updating as I built them over 15 years ago any help there would be appreciated
Code: 
Function CalcTime(E As Long, M As Integer, YY As Long) As String
Dim Mins As String
Dim Hours As Integer
Dim m_Db As Database
Dim Pro As Recordset
Dim Y As Integer
Dim T As Integer

On Error GoTo HandleErr

Mins = 0
Hours = 0
    Set m_Db = CurrentDb()
    Set Pro = m_Db.OpenRecordset("SELECT Minutes FROM QryTimesheetFormatedHours WHERE [EmployeeID]=" & E & " AND [M] =" & M & " AND [Y] =" & YY, dbOpenSnapshot)
    Do While Not Pro.EOF
    If Not IsNull(Pro("Minutes")) Then
            Y = InStr(Pro("Minutes"), ".")
        If Y <> 0 Then
            If Left(Pro("Minutes"), 1) <> 0 Then Hours = Hours + Left(Pro("Minutes"), Y - 1)
            T = CInt(Mid(Pro("Minutes"), Y + 1, Len(Pro("Minutes"))))
            If T <> 0 Then
                If Len(Mid(Pro("Minutes"), Y + 1, Len(Pro("Minutes")))) = 1 Then
                    Mins = Mins + CInt((Mid(Pro("Minutes"), Y + 1, Len(Pro("Minutes"))) * 10))
                Else
                    Mins = Mins + CInt(Mid(Pro("Minutes"), Y + 1, Len(Pro("Minutes"))))
                End If
            End If
            Else
            'Hours Only
            Hours = Hours + Pro("Minutes")
            End If
            If Mins >= 60 Then
            Hours = Hours + 1
            Mins = Mins - 60
        End If
    End If
        Pro.MoveNext
    Loop
            If Mins < 10 Then Mins = "0" & Mins
            CalcTime = Hours & ":" & Mins
Pro.Close
Set Pro = Nothing
m_Db.Close
Set m_Db = Nothing

HandleExit:
    Exit Function
    
HandleErr:
    Select Case Err.Number
        Case 2501 'Cancel = True
            Exit Function
        Case Else
            MsgBox Err.Number & vbCrLf & Err.Description
            Resume HandleExit
        Resume
    End Select
End Function
Function CalcOverTime(E As Long, M As Integer, YY As Long) As String
Dim Mins As String
Dim Hours As Integer
Dim m_Db As Database
Dim Pro As Recordset
Dim Y As Integer
Dim T As Integer

On Error GoTo HandleErr

Mins = 0
Hours = 0
    Set m_Db = CurrentDb()
    Set Pro = m_Db.OpenRecordset("SELECT OMinutes FROM QryTimesheetFormatedHours WHERE [EmployeeID]=" & E & " AND [M] =" & M & " AND [Y] =" & YY, dbOpenSnapshot)
    Do While Not Pro.EOF
    If Not IsNull(Pro("OMinutes")) Then
            Y = InStr(Pro("OMinutes"), ".")
        If Y <> 0 Then
            If Left(Pro("OMinutes"), 1) <> 0 Then Hours = Hours + Left(Pro("OMinutes"), Y - 1)
            T = CInt(Mid(Pro("OMinutes"), Y + 1, Len(Pro("OMinutes"))))
            If T <> 0 Then
                If Len(Mid(Pro("OMinutes"), Y + 1, Len(Pro("OMinutes")))) = 1 Then
                    Mins = Mins + CInt((Mid(Pro("OMinutes"), Y + 1, Len(Pro("OMinutes"))) * 10))
                Else
                    Mins = Mins + CInt(Mid(Pro("OMinutes"), Y + 1, Len(Pro("OMinutes"))))
                End If
            End If
            Else
            'Hours Only
            Hours = Hours + Pro("OMinutes")
            End If
            If Mins >= 60 Then
            Hours = Hours + 1
            Mins = Mins - 60
        End If
    End If
        Pro.MoveNext
    Loop
            If Mins < 10 Then Mins = "0" & Mins
            CalcOverTime = Hours & ":" & Mins
Pro.Close
Set Pro = Nothing
m_Db.Close
Set m_Db = Nothing

HandleExit:
    Exit Function
    
HandleErr:
    Select Case Err.Number
        Case 2501 'Cancel = True
            Exit Function
        Case Else
            MsgBox Err.Number & vbCrLf & Err.Description
            Resume HandleExit
        Resume
    End Select
End Function
 

Attachments

  • 2019-08-17 (2).png
    2019-08-17 (2).png
    41 KB · Views: 736
  • 2019-08-17 (3).png
    2019-08-17 (3).png
    38.8 KB · Views: 629
Last edited:
I suspect too much vba code, too much conditional formatting.

For my calendars/planners etc I set 'conditional formatting' by using rich text to set either fore or back color, or both. This is determined in the underlying query

for example

Code: 
First('<font color="' & Switch([fDate]<#1/10/2019# Or [fDate]>#4/20/2019#,"#C0C0C0",[eventdate] Is Not Null,"#80FF00",[breakdate] Is Not Null,"#FF0000",Weekday([fDate],2) In (6,7),"#B9B9FF",True,"#7F7F7F") & '">' & Day([fDate]) & "</font>") AS fDay

the above is from a crosstab query and has hardcoded dates which you would substitute with a form parameter etc. When broken down, looks much like conditional formatting structure

[fDate]<#1/10/2019# Or [fDate]>#4/20/2019#,"#C0C0C0" - greys out dates which cannot be used

[eventdate] Is Not Null,"#80FF00" - highlights dates with an event on

[breakdate] Is Not Null,"#FF0000" - highlights dates where the facility is closed - so events cannot be booked

Weekday([fDate],2) In (6,7),"#B9B9FF" - sets a color for the weekend

True,"#7F7F7F" - default color

the click event for the control can reference the fore color to decide whether to ignore (i.e. disabled), open/refresh another form etc
 
Thanks CJ_London The Codes the exact amount needed but am still reviewing it.


I do like the rich text though but I would have to start from scratch to impement it at this stage.


I have played around with the U.I. Removing bits but to be honest I wanted to keep it in line with the other screens like Holiday Planner and diary.


I have removed fields with conditional formating with no effect as I think the conditional formating is only applied after the form is active not sure but makes sence as the conditional formating has to access the controls on a form and have noticed a lag in the condition formating on the diary.


I do have another object I intend adding which would suit your idear thanks mick
 
The back colours on public and company closures Don't use condtional formating but use:
F("Time" & I).BackColor = Rst!ChartColor 'and set color
 
Found what I have done wrong I.E. When checking for booked holidays I was checking All days for each employee but was in the bath and thought what about weekends lol, I use a working days system to show which days are worked so Have updated the code that looks for holidays to below:


There is another way of loading the holiday information thats by adding a button so the user can select when they want them displayed


I have also changed the open mod for those who have copies of this example you will know that admin can allways view all records or only those that depeatments that been assigned so instead of displaying all records on open I have chanded the L=True so now the default is departments assigned only.


so it now opens in 3-4 seconds which I'm happy with I've left the loading warning in place As I think there are a lot who wont know how to do that correctly so hopefully it will help.



Code: 
                For I = 1 To LenMonth(DateValue("1/" & M & "/" & Y))
                    'Check Its A Working Day Before Looking for holidays should save minimum of 8 days not needed to be checked 8xnumber of employees
                    WD = InStr(WDL, Format(DateValue(I & "/" & M & "/" & Y), "w")) <> 0 'If not 0 then this will return true
                        If WD = False Then
                            H = GetDayHoliday(DateValue(I & "/" & M & "/" & Y), E("EmployeeID"))
                            If Not IsNothing(H) Then
                                CurrentDb.Execute "UPDATE tbxMonthData SET Hol" & I & "=" & H & " WHERE [EmployeeID]=" & E("EmployeeID"), dbFailOnError
                            End If
                        End If
                Next I
 
Last edited:
You must log in or register to reply here.

Similar threads

MajP
Randomize Not Working
2
Replies
25
Views
811
Pat Hartman
P
K
How can I add this code to the storage location of my file before scanning and then convert it to a PDF file?
2
Replies
25
Views
950
The_Doc_Man
The_Doc_Man
T
Attache to email from attachment Field
Replies
2
Views
200
theinviter
T
J
Resize a control on a continuous form
Replies
4
Views
238
John Sh
J
S
Delete All controls from A Form
2
Replies
20
Views
735
Pat Hartman
P

Users who are viewing this thread

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