I am creating an application that displays schedules for aircrew members. The program gets a begin and end date from the user and then goes and gets the schedule information from the database. The information from the database in then turned into a graphical depiction using label controls. The label controls are created dynamically WithEvents (referred to as ControlItems and DutyItems in the code). Each label corresponds to an individual event for the crewmember. There are about 250 crewmembers. Since the labels are created WithEvents, it allows the user to click on them and get expanded informaton about each event.
The problem with the code I have created is that it runs unacceptably slow. It works and displays the data correctly, but it is very turtlish. I am not a professional programmer. I am sure there are a lot of experts out there who could offer some tips or solutions as to how to speed this up. I'm using VB6 connecting to an Access2000 .mdb. Thanks in advance...I appreciate any and all help you can offer!


Dim Nsql, Njoin, Ncriteria, Norder, ThePath As String
        Nsql = "SELECT tblPersonal.Last, tblPersonal.First, tblPersonal.SSAN, tblPersonal.DutyPosition "
        Njoin = "FROM tblPersonal "
        Ncriteria = "WHERE tblPersonal.DutyPosition = ? "
        Norder = "ORDER BY tblPersonal.DutyPosition DESC, tblPersonal.Last;"


        ' Create the Connection object.
        Dim Conn2, Conn3 As ADODB.Connection
        Dim CmdB, CmdC As ADODB.Command
        Dim Rst2, Rst3 As ADODB.Recordset
        Dim Param1, Param2, Param3, Param4, Param5, Param6, Param7, Param8, Param9, Param10, Param11 As ADODB.Parameter
        ThePath = "F:\ChiefPilotProject"

        Set Conn2 = New ADODB.Connection
        With Conn2
            ' Set the OleDB provider for the connection.
            .Provider = "Microsoft.JET.OLEDB.4.0"
            ' Open a connection to PK.mdb.
            .Open ThePath & "\97MHDB_04.mdb"
        End With

        ' Create Command Object.
        Set CmdB = New ADODB.Command
        Set CmdB.ActiveConnection = Conn2
        CmdB.CommandType = adCmdText
        CmdB.CommandText = Nsql & Njoin & Ncriteria & Norder

        ' Create Parameter Object.
        If obPilots.Value = True Then DutyP = "Pilot"
        If obFlightAttendants.Value = True Then DutyP = "FlightAttendant"
        Set Param1 = CmdB.CreateParameter(, adLongVarChar, adParamInput, 15)
        Param1.Value = DutyP
        CmdB.Parameters.Append Param1

        ' Open Recordset Object.
        Set Rst2 = New ADODB.Recordset
        Rst2.LockType = adLockReadOnly
        Rst2.CursorType = adOpenStatic
        Rst2.CursorLocation = adUseClient
        With Rst2
            ' Connect this recordset to the previously opened connection.
            .ActiveConnection = Conn2
            Set Rst2 = CmdB.Execute()
            ' Retrieve all records
        End With

        If Rst2.BOF = True Then GoTo line4903:

        Dim Slitter, Size, x As Integer
        Dim FullName, SSAN

        Slitter = 0 'This is how I count records, Recordcount fails for some reason
        Rst2.MoveFirst
        Do Until Rst2.EOF
            Rst2.MoveNext
            Slitter = Slitter + 1
        Loop

        Dim Prog As Long
        Prog = Slitter
        Load frmProg
        frmProg.Show
        frmProg.pbUpdate.Max = Prog
        frmProg.pbUpdate.Min = 0

        ReDim FullName(1 To Slitter)
        ReDim SSAN(1 To Slitter)

        Rst2.MoveFirst
        For x = 1 To Slitter
            FullName(x) = Rst2!Last & ", " & Left(Rst2!First, 1) & "."
            SSAN(x) = Rst2!SSAN
            Rst2.MoveNext
        Next x

        Rst2.Close

    'List names from array along side the frame

    Dim IntX, IntY As Integer
    Dim Ctrl As Control
    Dim CtrlItem As ControlItem
    Dim CtrlType As String
    Dim Properties As Collection
    Dim CustomProperties As Collection
    Dim Top As Single
    Dim PropItem As Variant
    Dim Items() As String
    Dim z, Width

    ' first, remove all controls added dynamically
    On Error Resume Next
    ' don't try a forward or a for Each loop
    For IntX = Controls.Count - 1 To 0 Step -1
        Controls.Remove IntX
    Next
    On Error GoTo 0

    Call DateBar 'Separate procedure that adds a calendar strip to form depending on the number of days selected to view

    ' start with a fresh ControlItems collection
    Set ControlItems = New ControlItems

    ' initial value for Top property
    Top = 500

    ' add controls corresponding to fields
    ' this demo program only supports a few field types

   ' Create new instance of virtual scrollbar, and
   ' assign it to HScroll1.
    Set hsb = New CLongScroll
    Set hsb.Client = VScroll1
    hsb.Max = 500 + (300 * Slitter)
    hsb.LargeChange = hsb.Max / 10
    hsb.SmallChange = hsb.Max / 100

    Dim Length, J As Integer, OrigSSN, FinalSSN, NextLtr As String, Chk As Boolean

    For IntX = 1 To Slitter
        CtrlType = ""
        Set Properties = New Collection
        Set CustomProperties = New Collection
          CtrlType = "Vb.Label"
                Properties.Add "Caption=" & UCase(FullName(IntX))

            ' now create the control
            OrigSSN = Trim(SSAN(IntX))
            Length = Len(OrigSSN)
            FinalSSN = ""
            For J = 1 To Length
                NextLtr = Mid(OrigSSN, J, 1)
                Chk = IsNumeric(Mid(OrigSSN, J, 1))
                If Chk = True Then FinalSSN = FinalSSN & NextLtr
            Next J
            Set Ctrl = Controls.Add(CtrlType, "Laber" & FinalSSN)
            Set Ctrl.Container = frmNames
            Ctrl.Move 295, Top, 1525, 200
            Ctrl.BackColor = RGB(171, 187, 204)
            Ctrl.Alignment = vbRightJustify

            ' set its other properties
            For Each PropItem In Properties
                ' split property name and value
                Items() = Split(PropItem, "=")
                CallByName Ctrl, Items(0), VbLet, Items(1)
            Next

            Ctrl.Visible = True

            ' add this control to the ControlItems collection
            ' this will enable to receive events from it
            Set CtrlItem = ControlItems.Add(Ctrl)

            ' move the actual width into the Custom Width property
            ' this is used in the Form_Resize event
            CtrlItem.Properties.Add Ctrl.Width, "Width"

            ' set its other custom properties
            For Each PropItem In CustomProperties
                ' split property name and value
                Items() = Split(PropItem, "=")
                CtrlItem.Properties.Add Items(1), Items(0)
            Next

            ' increment top


        Top = Top + Ctrl.Height + 120

    Next IntX

    'Establish scale of calendar
    Dim NoDays, DayLength, Starts, Ends As Long
    Dim FirstTime, BeginTime, EndTime, LastTime As Variant
    Dim LeftPosn, RightPosn, BarWidth As Double

    NoDays = (dtpEnd.Value - dtpBegin.Value) + 1
    DayLength = 30000 / NoDays

    'Get schedule for each person
    Dim Yctr As Long
    Yctr = 0
    Dim Xctr As Long
    x = 0
    Top = 500
    For IntY = 1 To Slitter

        Nsql = "SELECT * "
        Njoin = "FROM tblMSNHistory "
        'The criteria portion has to be setup with 11 parameters due to the way the database is designed...I did not design it
        Ncriteria = "WHERE tblMSNHistory.ACSSAN = ? Or tblMSNHistory.CoPilot1 = ? Or tblMSNHistory.CoPilot2 = ? Or tblMSNHistory.CoPilot3 = ? Or tblMSNHistory.CoPilot4 = ? Or tblMSNHistory.CoPilot5 = ? Or tblMSNHistory.FlightAttendant1 = ? Or tblMSNHistory.FlightAttendant2 = ? Or tblMSNHistory.FlightAttendant3 = ? Or tblMSNHistory.FlightAttendant4 = ? Or tblMSNHistory.FlightAttendant5 = ? "
        Norder = "ORDER BY tblMSNHistory.TakeoffDateAndTime;"

        ' Create Command Object.
        Set CmdB = New ADODB.Command
        Set CmdB.ActiveConnection = Conn2
        CmdB.CommandType = adCmdText
        CmdB.CommandText = Nsql & Njoin & Ncriteria & Norder

        ' Create Parameter Object.
        Set Param1 = CmdB.CreateParameter(, adLongVarChar, adParamInput, 15)
        Param1.Value = SSAN(IntY)
        CmdB.Parameters.Append Param1
        Set Param2 = CmdB.CreateParameter(, adLongVarChar, adParamInput, 15)
        Param2.Value = SSAN(IntY)
        CmdB.Parameters.Append Param2
        Set Param3 = CmdB.CreateParameter(, adLongVarChar, adParamInput, 15)
        Param3.Value = SSAN(IntY)
        CmdB.Parameters.Append Param3
        Set Param4 = CmdB.CreateParameter(, adLongVarChar, adParamInput, 15)
        Param4.Value = SSAN(IntY)
        CmdB.Parameters.Append Param4
        Set Param5 = CmdB.CreateParameter(, adLongVarChar, adParamInput, 15)
        Param5.Value = SSAN(IntY)
        CmdB.Parameters.Append Param5
        Set Param6 = CmdB.CreateParameter(, adLongVarChar, adParamInput, 15)
        Param6.Value = SSAN(IntY)
        CmdB.Parameters.Append Param6
        Set Param7 = CmdB.CreateParameter(, adLongVarChar, adParamInput, 15)
        Param7.Value = SSAN(IntY)
        CmdB.Parameters.Append Param7
        Set Param8 = CmdB.CreateParameter(, adLongVarChar, adParamInput, 15)
        Param8.Value = SSAN(IntY)
        CmdB.Parameters.Append Param8
        Set Param9 = CmdB.CreateParameter(, adLongVarChar, adParamInput, 15)
        Param9.Value = SSAN(IntY)
        CmdB.Parameters.Append Param9
        Set Param10 = CmdB.CreateParameter(, adLongVarChar, adParamInput, 15)
        Param10.Value = SSAN(IntY)
        CmdB.Parameters.Append Param10
        Set Param11 = CmdB.CreateParameter(, adLongVarChar, adParamInput, 15)
        Param11.Value = SSAN(IntY)
        CmdB.Parameters.Append Param11

        ' Open Recordset Object.
        Set Rst2 = New ADODB.Recordset
        Rst2.LockType = adLockOptimistic
        Rst2.CursorType = adOpenStatic
        Conn2.CursorLocation = adUseClient
        With Rst2
            ' Connect this recordset to the previously opened connection.
            .ActiveConnection = Conn2
            Set Rst2 = CmdB.Execute()
            ' Retrieve all records
        End With

        If Rst2.BOF = True Then GoTo line4803:

        Dim r As String
        r = "TakeoffDateAndTime >= #" & frmMain.dtpBegin.Value & "# And TakeoffDateAndTime <= #" & frmMain.dtpEnd.Value & "#"
        Rst2.Filter = "TakeoffDateAndTime >= #" & frmMain.dtpBegin.Value & "# And TakeoffDateAndTime <= #" & frmMain.dtpEnd.Value + 1 & "#"

        If Rst2.BOF = True Then GoTo line4803:

        Rst2.Sort = "AuthNumber, TakeoffDateAndTime"

        Dim CalendarInfo, Flitter As Integer, DUTYPeriod, DUTYStart, DUTYEnd As Date

        Flitter = 0
        Rst2.MoveFirst
        Do Until Rst2.EOF
            Flitter = Flitter + 1
            Rst2.MoveNext
        Loop

        ReDim CalendarInfo(1 To Flitter, 1 To 22)
        Dim AuthNum, RstAuthNum As String
        AuthNum = "XX"
        Flitter = 1
        Starts = 0
        Ends = 0
        DUTYPeriod = 0
        DUTYStart = 0
        Rst2.MoveFirst
        Do Until Rst2.EOF
            CalendarInfo(Flitter, 1) = Rst2!TakeoffDateAndTime
            CalendarInfo(Flitter, 2) = Rst2!landdateandtime
            CalendarInfo(Flitter, 3) = Rst2!ACSSAN
            CalendarInfo(Flitter, 4) = Rst2!Copilot1
            CalendarInfo(Flitter, 5) = Rst2!FlightAttendant1
            CalendarInfo(Flitter, 6) = Rst2!MissionNumber
            CalendarInfo(Flitter, 7) = Rst2!AuthNumber
            If Rst2!AuthNumber <> AuthNum Then
                If AuthNum = "XX" And (Rst2!From <> "KLAX" Or Rst2!From <> "KONT") Then CalendarInfo(Flitter, 13) = "Start"
                If AuthNum <> "XX" Then
                    If (CalendarInfo(Flitter - 1, 2) - DUTYStart) <= 0.75 Then
                        DUTYPeriod = DUTYPeriod
                        CalendarInfo(Flitter - 1, 13) = "End"
                        GoTo line2233:
                    End If
                    DUTYPeriod = (CalendarInfo(Flitter - 1, 2) - DUTYStart) + DUTYPeriod
                    CalendarInfo(Flitter - 1, 13) = "End"
                    Ends = Ends + 1
                    GoTo line2235:
line2233:
                End If
                DUTYStart = Rst2!TakeoffDateAndTime
line2235:
                CalendarInfo(Flitter, 13) = "Start"
                Starts = Starts + 1

            End If
            CalendarInfo(Flitter, 8) = Rst2!Remarks
            CalendarInfo(Flitter, 9) = Rst2!MSNType
            CalendarInfo(Flitter, 10) = Rst2!FlightNumber
            CalendarInfo(Flitter, 11) = Rst2!From
            CalendarInfo(Flitter, 12) = Rst2!To
            CalendarInfo(Flitter, 14) = Rst2!Copilot2
            CalendarInfo(Flitter, 15) = Rst2!Copilot3
            CalendarInfo(Flitter, 16) = Rst2!Copilot4
            CalendarInfo(Flitter, 17) = Rst2!Copilot5
            CalendarInfo(Flitter, 18) = Rst2!FlightAttendant1
            CalendarInfo(Flitter, 19) = Rst2!FlightAttendant2
            CalendarInfo(Flitter, 20) = Rst2!FlightAttendant3
            CalendarInfo(Flitter, 21) = Rst2!FlightAttendant4
            CalendarInfo(Flitter, 22) = Rst2!FlightAttendant5
            AuthNum = Rst2!AuthNumber
            Flitter = Flitter + 1
line5566:
            Rst2.MoveNext
        Loop
        If Flitter = 1 Then GoTo line4803:

        If (CalendarInfo(Flitter - 1, 2) - DUTYStart) <= 0.75 Then
            DUTYPeriod = DUTYPeriod
            GoTo line2234:
        End If
        DUTYPeriod = (CalendarInfo(Flitter - 1, 2) - DUTYStart) + DUTYPeriod
        CalendarInfo(Flitter - 1, 13) = "End"
        Ends = Ends + 1
line2234:

        Dim IntZ, IntA, IntB As Integer, Auth As String
        For IntZ = 1 To Flitter + Ends - 1

            If IntZ > Flitter - 1 Then GoTo line1112:

            'Establish position of Calendar bar
             FirstTime = dtpBegin.Value
             LastTime = dtpEnd.Value
             BeginTime = CalendarInfo(IntZ, 1)
             EndTime = CalendarInfo(IntZ, 2)
             LeftPosn = DayLength * (BeginTime - FirstTime)
             RightPosn = BeginTime - LastTime
             BarWidth = ((EndTime - BeginTime) * DayLength)
             If RightPosn > 0 Then GoTo line4703:
line1112:
            'Turn info in variable into calendar bars
            CtrlType = ""
            Set Properties = New Collection
            Set CustomProperties = New Collection
            CtrlType = "Vb.Label"
            If IntZ < Flitter Then
                  Properties.Add "Caption=" & CalendarInfo(IntZ, 10)
                  Else: GoTo line1114:
            End If
            ' now create the control

            Yctr = Yctr + 1

            Set Ctrl = Controls.Add(CtrlType, "Label" & Yctr & "X")

            Set Ctrl.Container = frmCalendar
line1114:
            If IntZ < Flitter Then
                Ctrl.Move LeftPosn, Top, BarWidth, 200
                Else
                    For IntA = 1 To Flitter - 1
                        If CalendarInfo(IntA, 13) = "Start" Then
                            BeginTime = CalendarInfo(IntA, 1)
                            Auth = CalendarInfo(IntA, 7)
                            For IntB = 1 To Flitter - 1
                                If CalendarInfo(IntB, 13) = "End" Then
                                    If CalendarInfo(IntB, 7) = Auth Then
                                        EndTime = CalendarInfo(IntB, 2)
                                        GoTo line1118:
                                    End If
                                End If
                            Next IntB
line1118:
                            LeftPosn = DayLength * (BeginTime - FirstTime)
                            RightPosn = BeginTime - LastTime
                            BarWidth = ((EndTime - BeginTime) * DayLength)
                            Properties.Add "Caption=" & UCase(CalendarInfo(IntA, 7))

                            Xctr = Xctr + 1
                            Set Ctrl = Controls.Add(CtrlType, "Label" & Xctr)
                            Set Ctrl.Container = frmCalendar
                            Ctrl.Move LeftPosn, Top, BarWidth, 200
                            Ctrl.BackColor = RGB(214, 232, 242)
                            Ctrl.ForeColor = RGB(214, 232, 242)
                            ' set its other properties
                            For Each PropItem In Properties
                                ' split property name and value
                                Items() = Split(PropItem, "=")
                                CallByName Ctrl, Items(0), VbLet, Items(1)
                            Next

                            Ctrl.Visible = True

                            ' add this control to the ControlItems collection
                            ' this will enable to receive events from it
                            Set CtrlItem = ControlItems.Add(Ctrl)

                            ' move the actual width into the Custom Width property
                            ' this is used in the Form_Resize event
                            CtrlItem.Properties.Add Ctrl.Width, "Width"

                            ' set its other custom properties
                            For Each PropItem In CustomProperties
                                ' split property name and value
                                Items() = Split(PropItem, "=")
                                CtrlItem.Properties.Add Items(1), Items(0)
                            Next
                        End If
                    Next IntA

                GoTo line1122:
            End If

            If CalendarInfo(IntZ, 9) = "Mission" Then
                Ctrl.BackColor = RGB(58, 188, 221)
                Ctrl.ForeColor = RGB(58, 188, 221)
            End If
            If CalendarInfo(IntZ, 9) = "Local" Then
                Ctrl.BackColor = RGB(101, 134, 222)
                Ctrl.ForeColor = RGB(101, 134, 222)
            End If
            Ctrl.Alignment = vbRightJustify

line1122:
            ' set its other properties
            For Each PropItem In Properties
                ' split property name and value
                Items() = Split(PropItem, "=")
                CallByName Ctrl, Items(0), VbLet, Items(1)
            Next

            Ctrl.Visible = True

            ' add this control to the ControlItems collection
            ' this will enable to receive events from it
            Set CtrlItem = ControlItems.Add(Ctrl)

            ' move the actual width into the Custom Width property
            ' this is used in the Form_Resize event
            CtrlItem.Properties.Add Ctrl.Width, "Width"

            ' set its other custom properties
            For Each PropItem In CustomProperties
                ' split property name and value
                Items() = Split(PropItem, "=")
                CtrlItem.Properties.Add Items(1), Items(0)
            Next

            ' increment top

line4703:
        Next IntZ


line4803:
        Top = Top + Ctrl.Height + 120
        frmProg.pbUpdate.Value = IntY / Prog
    Next IntY

line4903:

The basic thing that I think when I look at your code is that you are coding a lot of things which you could get for "free" by getting the database to do more of the work for you.

For example, you query tblPersonal, then for each row you query tblMSNHistory. That's a lot of queries. Since there is a relationship between the 2 tables, why don't you try JOIN-ing them to get back everything you need in just one query?

Also, you do other manipulations like trimming values and concatenting the names - these steps could also be incorporated into your query.

Another wasteful area is the repeated looping through recordsets to put them into arrays. You should just use ADO's GetRows() method instead - that will put the records straight into an array (watch out though because the resulting array is the "other way around" from what you would expect).

Finally, since you are only reading the records once you should use a forward-only cursor, its faster than a static cursor. And avoid using MoveFirst - sometimes the underlying result is to re-run the query!

hth
Phil

PgTips,

Wow, thanks for the tips! I will try out your recommendations and see what happens. Those are some things that I'd never considered or been aware of.
I'm still concerned that even if I eliminate all inefficiency in the way the I handle the database, that the real thing that may be slowing down this procedure is the adding of dynamic controls. Does anyone have any insight on that?

hi there..

others pointing:

Use of goto is forbiden (you can, but...) it's makes your code awfull and not easy to maintain... try to rethink that things...

Recourd count fails.. if you need the real count dont go throw all the RS, just do a query that counts the resultset... (like "select count(*) from table")

callbyname is the slowest function in VB.. why are you doing this?? i personally dont follow you...

HTH

Gonzalo

Gbianci,

Thanks for the help!

I don't really know how to get around using Goto. I'd love it if you could help me out with some other methods that would allow me to not have to use it.

The CallByName is from a code sample I got from another board on the internet. I personally don't understand how it works either, but it does. Again, I'd really appreciate it if you could show me a better, more efficient way to create dynamic controls with events.

Also, I managed with the help of some folks from Experts Exchange to figure out why Recordcount was failing. I was using a client side cursor. When I switched to a server side cursor, I was able to use it successfully. This is what I'm using now:
' Open Recordset Object.
        Set Rst2 = New ADODB.Recordset
        Rst2.LockType = adLockReadOnly
        Rst2.CursorLocation = adUseServer
        With Rst2
' Connect this recordset to the previously opened connection.
            .ActiveConnection = Conn2
            .Open CmdB, , adOpenStatic, adLockBatchOptimistic
            ' Retrieve all records
        End With

        RcdCt = Rst2.Recordcount

Thanks again! Would really love to hear any more advice you have.

hi there.. let's see...

this is just an example.. you can change this for....

for better use.. split your functions in little ones, that way you can avoid using goto...

also.. i still dont understand why use callbyname.. since you have an array of controls and when you add one you have the same function for it.. why you still need it???

HTH

Gonzalo

re getting rid of CallByName. Its used three times, in each case it seems to be just to change the caption of the control. For example, the first use of CallByName:
You could replace all of the above with this single line:
Also, you raised the question of whether the creation of many dynamic controls is what's really slowing it down. My gut feeling is 'no' - database reads involve reads from the filesystem which will be much slower than the in-memory work involved in creating dynamic controls. However, there is a Windows API call, I believe its LockWindow(...), that you can make to prevent your application trying to re-draw the screen during the control creation - look it up and try it out...

The bottom-line with questions like this is that unless you measure the time each operation (or group of operations) takes you'll never know for sure what is the main culprit. You'll be stuck with trial-and-error, which can result in a lot of code re-work for no perceivable benefit. The GetTickCount() Windows API function is useful for measuring elapsed time in millisecinds of parts of your code - just call it before and after each bit of code you want to time and take the difference. If you take measurements at certain intervals during your code execution you'll soon find out what's really causing the delays. Of course, the more structured and separated your code is in the first place, the easier it is to measure discrete operations.

hth
Phil

the problem of this code, if there are no records in your
table :
        Slitter = 0
        Rst2.MoveFirst
        Do Until Rst2.EOF
            Rst2.MoveNext
            Slitter = Slitter + 1
        Loop
analyse again your code, too much variables, loops and gosh. . .
you make all the code so complicated, check again your var's.
and i think you should use one variables Connection in your
programs ... bye