Solved

Speeding up Form Loading`

Posted on 2001-09-09
21
635 Views
Last Modified: 2008-03-24
    I have some rather complex forms which take 3-4 seconds to load. I don't mind that delay if it's a one-time shot, but users keep loading and unloading these forms, and the delays are becoming rather annoying.
     When a form is unloaded, is it retained in memory, or does VB have to go to disk to fetch it when it's re-loaded later on?
     In general, what can I do to speed up form loading?
0
Comment
Question by:GebhartBob
  • 5
  • 4
  • 3
  • +6
21 Comments
 
LVL 7

Accepted Solution

by:
Vbmaster earned 100 total points
Comment Utility
One way is, instead of unloading the form, just setting the Visible property to false. This way the form will not be unloaded (moved from meory) and re-loaded each time. Remember that doing this will keep the memory/resources used by the form locked at all times though, if the form is uses a lot of memory you might want to use another approach.
0
 
LVL 17

Expert Comment

by:inthedark
Comment Utility
One of the reasons that a form can take a long time to load is if there are a lot of controls to load.  With an amount of effort it is possible to reduce the number of controls to a minumum.

I created a form with a picture box and two textboxes.  The program displays the fields onto the picture box so that they loke identical to a picture box.  When the operators scrolls arround the screen or clicks into a textbox the real textbox is mad visible and handles the input. It took a bit of time to handle the virtual (scrollable) screen aspects of the form but it loads and displays 300 fields in less than 1 second.


0
 
LVL 17

Expert Comment

by:smozgur
Comment Utility
I agree with VBmmaster and inthedark

Another possible case;

To make invisible a control on a form during load (or during data retrieving time) and to make it visible after loading data makes faster then keeping it visible always.

If you have a control on form like that (loading data at the form load; for example a flex grid) then make it visible=false as default then make it visible after filling data.


Suat
0
 
LVL 17

Expert Comment

by:smozgur
Comment Utility
syntax err : then keeping ... = than keeping...

sorry for second post.

suat
0
 
LVL 12

Expert Comment

by:roverm
Comment Utility
Can you post the form (through notepad or so) so that we can try it ourselves ?

D'Mzzl!
RoverM
0
 
LVL 9

Expert Comment

by:Valliappan AN
Comment Utility
Also to avoid the user's anxiety, hope you change the mousepointer to vbHourglass and after loading, change back to vbDefault.
0
 
LVL 2

Expert Comment

by:nahumd
Comment Utility
Also, if you have many controls of the same type (for example: many textboxes), it is more efficient to have a control array rather than many independent controls.
0
 
LVL 17

Expert Comment

by:smozgur
Comment Utility
Nice comments. I like EE.

suat
0
 

Author Comment

by:GebhartBob
Comment Utility
    Thanks, guys, for all the good ideas.
     Concerning roverm's request ... Can you post the form (through notepad or so) so that we can try it ourselves ? ... I'd be glad to, but the problem is that I use a bunch of third party controls, like VSFlexGrid, etc., and can't share the .ocx's.
     I like these ideas that have been suggested:
     (1) VBMaster's idea of not unloading the form, but just hiding it, intrigues me. It never ocurred to me, but the idea makes a lot of sense. The only problem I see with it is that this is an MDI application. If I hide a form rather than unloading it, won't it appear in the list of windows? My users select a window via Alt-W, etc.; that's an important part of the application. Is there a way that I could suppress the listing of hidden windows? If so, I think hiding rather than unloading windows would solve the speed problem beautifully.
     The really attractive part of the idea is that there would be a one-time pause as I load all the commonly-used forms into memory and then hide them. After that, forms ought to come up quick like a bunny. And I wouldn't have to play any other optimization games.
     (2) Using control arrays (proposed by nahumd): I have a bunch of separately-named labels which I could certainly put into a control array. I'll do that. It will be interesting to find out how much difference it makes. I'll do that first, and let you know what it saves.
     (3) smozqur's idea of making controls, particularly grids, invisible initially and then making them visible only after filling them makes a lot of sense. I'll give it a try. I do have a bunch of rather large grids, and hiding them initially could very well make a sizable difference.
     (4) I hadn't thought about valli an's suggestion of the hourglass to avoid user anxiety, but of course it's a very good idea.
     I'll play around with all these ideas and see which ones have the biggest payoff. I haven't the vaguest idea of how to split up points fairly, or even if it's possible to split points. Suggestions?
     I'll report here on what I learn as I apply these ideas.
     Thanks again, very much, for the intelligent suggestions.

---Bob Gebhart
0
 
LVL 9

Expert Comment

by:Valliappan AN
Comment Utility
Hi Gebhart,

Nvm the ocxs. Just post the form code here in EE section. May be we could just look at your code. :)
0
Do You Know the 4 Main Threat Actor Types?

Do you know the main threat actor types? Most attackers fall into one of four categories, each with their own favored tactics, techniques, and procedures.

 
LVL 4

Expert Comment

by:trkcorp
Comment Utility
Bob, Re: item 1 in your last comment - Hiding the window will remove the entry from the windowlist.  Windows only appear on this list when they are minimized, maximized or normal; in other words, displayed.  I hide a lot of windows in my MDI apps.
0
 
LVL 9

Expert Comment

by:Valliappan AN
Comment Utility
If your form code is very big, can send to valli_an@softhome.net
0
 

Author Comment

by:GebhartBob
Comment Utility
   Ok, you asked for it! Here's the basic form code, followed immediately by the public code module:

Option Explicit

' Variables available to all functions within this form module.
Private adding As Boolean
Private changingRP As Boolean
Private correctingErrorOnTab As Boolean
Private editing As Boolean
Private fgrJustFilled As Boolean
Private firstComboBoxCodesIndexFromTable As Integer
Private PatNotesAdmDisplayInProgress As Boolean
Private PatientsPracticeContact As String
Private PatientsPracticeName As String
Private PatientsPracticePhone As String
Private RPHasBeenDisplayed As Boolean
Private RPHasJustBeenRestored As Boolean
Private rstPatientSearch As ADODB.Recordset
Private rstPatNotesAdm As ADODB.Recordset
Private rstThisPatient As ADODB.Recordset
Private rstThisRP As ADODB.Recordset
Private rstUsers As ADODB.Recordset
Private searchingForPatient As Boolean
Private searchingForRP As Boolean

' Constants defining the Patient Tabs.
Const TAB_FIRST As Integer = 0
Const TAB_BASICS As Integer = 0
Const TAB_RP As Integer = TAB_BASICS + 1
Const TAB_INSURANCE As Integer = TAB_RP + 1
Const TAB_MEDICAL As Integer = TAB_INSURANCE + 1
Const TAB_APPOINTMENTS As Integer = TAB_MEDICAL + 1
Const TAB_LAST As Integer = TAB_APPOINTMENTS

' Constant defining the Column # of Patient and RP Account #
' in the Search datagrids dgrPatientSearch and dgrRPSearch.
Const PATIENT_NAME_LAST As Integer = 0
Const PATIENT_NAME_FIRST As Integer = PATIENT_NAME_LAST + 1
Const PATIENT_NAME_MI As Integer = PATIENT_NAME_FIRST + 1
Const PATIENT_NAME_SUFFIX As Integer = PATIENT_NAME_MI + 1
Const PATIENT_ACT_NO As Integer = 7
Const RP_ACT_NO As Integer = 7

Public Sub ChangeEmploymentStatus(PatActNo As Long, newEmployeeStatus As String)
'
'     This sub is only called from the Employer form (frmMedtechEmployer),
'     when Employment status is changed on that form.
'

   ' Check for a change in the Patient's Employment Status.
   If PatActNo = rstThisPatient("ActNo") Then
      GetComboBox cmbBasicsEmployment, "EMP", newEmployeeStatus
   End If

   ' Check for a change in the RP's Employment Status.
   ' If the RP is "Self", we'll change both.
   If PatActNo = rstThisRP("ActNo") Then
      GetComboBox cmbRPEmployment, "EMP", newEmployeeStatus
   End If

End Sub

Private Sub cmbBasicsEmployment_GotFocus()

   cmbBoxKeyedSoFar = ""

End Sub

Private Sub cmbBasicsEmployment_KeyUp(KeyCode As Integer, Shift As Integer)

   ComboBox_KeyUp cmbBasicsEmployment, KeyCode, Shift, vbProperCase

End Sub

Private Sub cmbBasicsMarital_GotFocus()

   cmbBoxKeyedSoFar = ""

End Sub

Private Sub cmbBasicsMarital_KeyUp(KeyCode As Integer, Shift As Integer)

   ComboBox_KeyUp cmbBasicsMarital, KeyCode, Shift, vbProperCase

End Sub

Private Sub cmbBasicsProvider_GotFocus()

   cmbBoxKeyedSoFar = ""

End Sub

Private Sub cmbBasicsProvider_KeyUp(KeyCode As Integer, Shift As Integer)

   ComboBox_KeyUp cmbBasicsProvider, KeyCode, Shift, vbProperCase

End Sub

Private Sub cmbBasicsSex_GotFocus()

   cmbBoxKeyedSoFar = ""

End Sub

Private Sub cmbBasicsSex_KeyUp(KeyCode As Integer, Shift As Integer)

   ComboBox_KeyUp cmbBasicsSex, KeyCode, Shift, vbUpperCase

End Sub

Private Sub cmbBasicsState_GotFocus()

   cmbBoxKeyedSoFar = ""

End Sub

Private Sub cmbBasicsState_KeyUp(KeyCode As Integer, Shift As Integer)

   ComboBox_KeyUp cmbBasicsState, KeyCode, Shift, vbUpperCase

End Sub

Private Sub cmbBasicsStudent_GotFocus()

   cmbBoxKeyedSoFar = ""

End Sub

Private Sub cmbBasicsStudent_KeyUp(KeyCode As Integer, Shift As Integer)

   ComboBox_KeyUp cmbBasicsStudent, KeyCode, Shift, vbProperCase

End Sub

Private Sub cmbMedicalRefPhys_GotFocus()

   cmbBoxKeyedSoFar = ""

End Sub

Private Sub cmbMedicalRefPhys_KeyUp(KeyCode As Integer, Shift As Integer)

   ComboBox_KeyUp cmbMedicalRefPhys, KeyCode, Shift, vbProperCase

End Sub

Private Sub cmbRPEmployment_GotFocus()

   cmbBoxKeyedSoFar = ""

End Sub

Private Sub cmbRPEmployment_KeyUp(KeyCode As Integer, Shift As Integer)

   ComboBox_KeyUp cmbRPEmployment, KeyCode, Shift, vbProperCase

End Sub

Private Sub cmbRPMarital_GotFocus()

   cmbBoxKeyedSoFar = ""

End Sub

Private Sub cmbRPMarital_KeyUp(KeyCode As Integer, Shift As Integer)

   ComboBox_KeyUp cmbRPMarital, KeyCode, Shift, vbProperCase

End Sub

Private Sub cmbRPRPPatRel_GotFocus()

   cmbBoxKeyedSoFar = ""

End Sub

Private Sub cmbRPRPPatRel_KeyUp(KeyCode As Integer, Shift As Integer)

   ComboBox_KeyUp cmbRPRPPatRel, KeyCode, Shift, vbProperCase

End Sub

Private Sub cmbRPRPPatRel_LostFocus()

   If cmbRPRPPatRel.ListIndex = -1 Then
      IgnoreEnter = True
      MsgBox "The patient's relationship to the RP is required." & vbCrLf & vbCrLf & _
             "If you're not sure, select ""Self"" and correct it later."
      cmbRPRPPatRel.SetFocus
      Exit Sub
   End If

   rstThisPatient("RPPatRel") = comboBoxCodes(cmbRPRPPatRel.ItemData(cmbRPRPPatRel.ListIndex))
   
   If changingRP Then
      RPSearchInit
   End If

End Sub

Private Sub cmbRPSex_GotFocus()

   cmbBoxKeyedSoFar = ""

End Sub

Private Sub cmbRPSex_KeyUp(KeyCode As Integer, Shift As Integer)

   ComboBox_KeyUp cmbRPSex, KeyCode, Shift, vbUpperCase

End Sub

Private Sub cmbRPState_GotFocus()

   cmbBoxKeyedSoFar = ""

End Sub

Private Sub cmbRPState_KeyUp(KeyCode As Integer, Shift As Integer)

   ComboBox_KeyUp cmbRPState, KeyCode, Shift, vbUpperCase

End Sub

Private Sub cmdFX_Click(Index As Integer)
   
   CommandDispatcher Index

End Sub

Private Sub ComboBoxesPopulate()
   
   ComboBoxPopulate cmbBasicsEmployment, "EMP"
   ComboBoxPopulate cmbBasicsMarital, "MAR"
   ComboBoxPopulate cmbBasicsSex, "SEX"
   ComboBoxPopulate cmbBasicsState, "STA"
   ComboBoxPopulate cmbBasicsStudent, "STU"

   ComboBoxPopulate cmbRPEmployment, "EMP"
   ComboBoxPopulate cmbRPMarital, "MAR"
   ComboBoxPopulate cmbRPRPPatRel, "REL"
   ComboBoxPopulate cmbRPSex, "SEX"
   ComboBoxPopulate cmbRPState, "STA"

   firstComboBoxCodesIndexFromTable = comboBoxCodesIndex
   ComboBoxPopulateFromTable cmbBasicsProvider, "PRO", "Provider", "Name", "ActNo", _
                             "NameLast", "NameFirst", "NameMI", "NameSuffix"
   ComboBoxPopulateFromTable cmbMedicalProvider, "PRO", "Provider", "Name", "ActNo", _
                             "NameLast", "NameFirst", "NameMI", "NameSuffix"
   ComboBoxPopulateFromTable cmbMedicalRefPhys, "REF", "RefPhys", "Name", "ActNo", _
                             "NameLast", "NameFirst", "NameMI", "NameSuffix"

End Sub

Private Sub CommandDispatcher(Index As Integer)
'
'                 Command Dispatcher Sub
'
'        Passed: Integer Function Key Number
'                0-11 = Function Keys F1-F12
'
' Called by cmdFX_Click, picFX_Click, and Form_KeyUp on a function key, because
' no matter whether the user clicks on the picture of the function key, the command
' button itself, or presses the actual function key, we must honor the command.
'
   
   Select Case Index

      Case 0         ' F1 = Help

         MsgBox "F1 = Context-sensitive help, not the same as Alt-H: Not implemented yet."
     
      Case 1         ' F2 = Abort Add or Change
         
         If searchingForPatient Then
            MsgBox "No patient selected, F2 Abort Add or Change command ignored."
            Exit Sub
         End If
         If adding Then
            PatientSearchInit
         Else
            PatientDisplay
         End If
     
      Case 2         ' F3 = Add new Patient

         If PatientUpdate = False Then
            Exit Sub
         End If
         PatientAdd

      Case 3         ' F4 = Show Employer

         If searchingForPatient Then
            MsgBox "No patient selected, F7 Show Employer command ignored."
            Exit Sub
         End If
         If tabPatient.Tab = TAB_BASICS Then
            EmployerInfoDisplay txtPatientActNo
         ElseIf tabPatient.Tab = TAB_RP Then
            If lblRPActNoReadOnly = "" Then
               MsgBox "No RP selected, F7 Show Employer command ignored."
               Exit Sub
            Else
               EmployerInfoDisplay lblRPActNoReadOnly
            End If
         Else
            MsgBox "You must be on the Basics or RP Screen to show Employer information."
            Exit Sub
         End If

      Case 4         ' F5

      Case 5         ' F6

      Case 6         ' F7

      Case 7         ' F8 = Next Tab
         
            If tabPatient.Tab = TAB_LAST Then
               tabPatient.Tab = TAB_FIRST
            Else
               tabPatient.Tab = tabPatient.Tab + 1
            End If

      Case 8        ' F9 = Previous Tab

            If tabPatient.Tab = TAB_FIRST Then
               tabPatient.Tab = TAB_LAST
            Else
               tabPatient.Tab = tabPatient.Tab - 1
            End If

      Case 9        ' F10 = Next Patient (in alphabetical Name order)

         If PatientUpdate = False Then
            Exit Sub
         End If
         rstThisPatient.MoveNext
         If rstThisPatient.EOF Then
            MsgBox "At end of file: There are no more Patients."
            rstThisPatient.MovePrevious
         Else
            PatientDisplay
         End If

      Case 10       ' F11 = Previous Patient (in alphabetical Name order)
         
         If PatientUpdate = False Then
            Exit Sub
         End If
         rstThisPatient.MovePrevious
         If rstThisPatient.BOF Then
            MsgBox "At beginning of file: There are no more Patients."
            rstThisPatient.MoveNext
         Else
            PatientDisplay
         End If

      Case 11        ' F12 = Done

         If searchingForPatient Then
            ExitForm
         Else
            If PatientUpdate = False Then
               Exit Sub
            End If
            PatientSearchInit
         End If

   End Select

End Sub

Private Sub dgrPatientSearch_DblClick()
   
   PatientSelectedByName

End Sub

Private Sub dgrPatientSearch_KeyUp(KeyCode As Integer, Shift As Integer)

   If KeyCode = vbKeyReturn Then
      PatientSelectedByName
   End If

End Sub

Private Sub dgrPatientSearch_LostFocus()

   Set dgrPatientSearch.DataSource = Nothing
   dgrPatientSearch.ReBind

End Sub

Private Sub dgrRPSearch_DblClick()
   
   RPSelected (dgrRPSearch.Columns(RP_ACT_NO))

End Sub

Private Sub dgrRPSearch_KeyUp(KeyCode As Integer, Shift As Integer)
   
   If KeyCode = vbKeyReturn Then
      RPSelected (dgrRPSearch.Columns(RP_ACT_NO))
   End If

End Sub

Private Sub dgrRPSearch_LostFocus()

   Set dgrRPSearch.DataSource = Nothing
   dgrRPSearch.ReBind

End Sub

Public Sub DisplayFormCaption(caption As String)

   If PracticeCount > 1 Then
      caption = caption & " (" & PatientsPracticeName
      If Not PatientsPracticeContact = "" Then
         caption = caption & " - " & PatientsPracticeContact
      End If
      If Not PatientsPracticePhone = "" Then
         caption = caption & " - " & PatientsPracticePhone
      End If
      caption = caption & ")"
   End If
   
   Me.caption = caption

End Sub

Private Sub EmployerInfoDisplay(PatActNo As Long)

   Dim employmentStatus As String
   Dim frmEmployer As New frmMedtechEmployer

   If PatActNo = rstThisPatient("ActNo") Then
      PutComboBox employmentStatus, cmbBasicsEmployment
      frmEmployer.caption = "Employer Information for " & _
                            rstThisPatient("NameLast") & ", " & _
                            rstThisPatient("NameFirst")
   Else
      PutComboBox employmentStatus, cmbRPEmployment
      frmEmployer.caption = "Employer Information for " & _
                            rstThisRP("NameLast") & ", " & _
                            rstThisRP("NameFirst")
   End If
   
   ' Load Employer form, pass data to it, and show the form.
   ' *Note: LoadNewForm not used because size and position of form are non-standard.
   frmEmployer.Left = 150
   frmEmployer.Top = 5000
   frmEmployer.width = 9975
   frmEmployer.Height = 2400
   Load frmEmployer
   frmEmployer.Load Me, PatActNo, employmentStatus
   frmEmployer.show

End Sub

Private Sub ExitForm()

   rstThisPatient.Close
   rstThisRP.Close
   rstPatNotesAdm.Close
   rstUsers.Close
   ComboBoxDepopulateFromTable firstComboBoxCodesIndexFromTable
   Unload Me

End Sub

Private Sub fgrPatNotesAdm_AfterRowColChange(ByVal OldRow As Long, ByVal OldCol As Long, ByVal NewRow As Long, ByVal NewCol As Long)

   If Not fgrJustFilled Then
      fgrPatNotesAdm.EditCell
      fgrPatNotesAdm.EditSelStart = 0
   End If
   fgrJustFilled = False

End Sub

Private Sub Form_Activate()

   txtPatientLastName.SetFocus

End Sub

Private Sub Form_Initialize()
'
'     The Initialize event occurs immediately after the Form
'          object is created, and before it is loaded.
'
'          All Patient initialization is done here.
'

   ' Prevent the background color of frames from slopping
   ' over the tops of the frames.
   FramesKludge

   ' Set the colors for this form.
   ColorForm Me

   ' Save the Practice data for this patient.
   PatientsPracticeName = PracticeName
   PatientsPracticeContact = PracticeContact
   PatientsPracticePhone = PracticePhone
   
   ' Create the recordset objects we'll need.
   Set rstPatientSearch = New ADODB.Recordset
   Set rstPatNotesAdm = New ADODB.Recordset
   Set rstThisPatient = New ADODB.Recordset
   Set rstThisRP = New ADODB.Recordset
   Set rstUsers = New ADODB.Recordset

   ' Populate all of the combo boxes with the choices.
   ComboBoxesPopulate

   ' Open the Data Source for this patient, RP, and User
   ' (User to get the author of notes).
   ' These recordsets remain open as long as the Patient form is up.
   OpenForDirectAccess rstThisPatient, "Patient", "Name"
   OpenForDirectAccess rstThisRP, "Patient", "ActNo"
   OpenForDirectAccess rstPatNotesAdm, "PatNotesAdm", "PatActNo"
   OpenForDirectAccess rstUsers, "Users", "UserNo"

   ' Initialize to search for a patient.
   PatientSearchInit

End Sub

Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)

   ' If we're displaying Patient Notes, don't process the keystroke.
   If PatNotesAdmDisplayInProgress Then
      KeyCode = 0
      Exit Sub
   End If

   ' Don't allow the F4 to drop down Combo Boxes,
   ' and don't allow F10 to select the first menu item.
   ' Form_KeyUp still sees these and invokes the Get Next Record command.
   If KeyCode = vbKeyF4 Or KeyCode = vbKeyF10 Then
      KeyCode = 0
   End If

End Sub

Private Sub Form_KeyPress(KeyAscii As Integer)

   ' If we're displaying Patient Notes, don't process the keystroke.
   If PatNotesAdmDisplayInProgress Then
      KeyAscii = 0
      Exit Sub
   End If

End Sub

Private Sub Form_KeyUp(KeyCode As Integer, Shift As Integer)

   ' If we're displaying Patient Notes, check for another one.
   If PatNotesAdmDisplayInProgress Then
      PatientNotesAdmRedDisplay
      Exit Sub
   End If

   ' If the keystroke is a function key, sic the Command Dispatcher on it.
   If (KeyCode >= vbKeyF1) And (KeyCode <= vbKeyF12) Then
      CommandDispatcher (KeyCode - vbKeyF1)
      Exit Sub
   End If

   ' Abstract just the Ctrl, Shift and Alt Bits.
   Shift = Shift And (vbAltMask + vbCtrlMask + vbShiftMask)

   ' If you're on the SSTab control, the standard behavior
   ' is Ctrl-Tab goes forward one tab, Ctrl-Shift-Tab
   ' goes back one tab. If you're not on the SSTab, Ctrl-Tab
   ' and Ctrl-Shift Tab do nothing.
   ' This code exists to force Ctrl-Tab and Ctrl-Shift-Tab
   ' to work the same when you're not on the SSTab;
   ' i.e., so that Ctrl-Tab and Ctrl-Shift Tab work the
   ' same no matter where you are on the screen.
   If Not TypeOf Screen.ActiveControl Is SSTab Then

      ' Test for Ctrl-Tab to go forward one tab from anywhere.
      If (Shift = vbCtrlMask) And (KeyCode = vbKeyTab) Then
         If tabPatient.Tab = TAB_LAST Then
            tabPatient.Tab = TAB_FIRST
         Else
            tabPatient.Tab = tabPatient.Tab + 1
         End If
      End If

      ' Test for Ctrl-Shift-Tab to go backward one tab from anywhere.
      If (Shift = vbCtrlMask + vbShiftMask) And (KeyCode = vbKeyTab) Then
         If tabPatient.Tab = TAB_FIRST Then
            tabPatient.Tab = TAB_LAST
         Else
            tabPatient.Tab = tabPatient.Tab - 1
         End If
      End If
   End If

   ' If not in the Patient Selection Grid, treat Returns as Tabs,
   ' to advance from one field to another.
   If Not TypeOf Screen.ActiveControl Is DataGrid Then
      If KeyCode = vbKeyReturn Then
         If Screen.ActiveControl.TabIndex = 0 And txtPatientLastName = "" Then
            txtPatientLastName.SetFocus
         ElseIf IgnoreEnter Then
            IgnoreEnter = False
         Else
            SendKeys "{Tab}"
         End If
      End If
   End If

   ' Tab navigation is invoked with Ctrl.
   If Shift = vbCtrlMask Then
   
      Select Case KeyCode
         Case vbKeyA
            tabPatient.Tab = TAB_APPOINTMENTS
         Case vbKeyB
            tabPatient.Tab = TAB_BASICS
         Case vbKeyI
            tabPatient.Tab = TAB_INSURANCE
         Case vbKeyM
            tabPatient.Tab = TAB_MEDICAL
         Case vbKeyR
            tabPatient.Tab = TAB_RP
      End Select

   ' Field navigation is invoked with Ctrl-Shift.
   ElseIf Shift = (vbCtrlMask + vbShiftMask) Then
      If dgrPatientSearch.Visible Then                ' If Selecting a Patient,
                                                      ' navigate to Patient Name
         Select Case KeyCode
            Case vbKeyL
               txtPatientLastName.SetFocus
         End Select
     
      Else                                            ' If not selecting a Patient,
         Select Case tabPatient.Tab                   ' Navigation depends on
                                                      ' which tab you're on
     
            Case TAB_BASICS                           ' Tab #0 = Navigation for
               Select Case KeyCode                    ' Basics Tab
                  Case vbKeyA
                     txtBasicsAddress1.SetFocus
                  Case vbKeyC
                     txtBasicsCity.SetFocus
                  Case vbKeyD
                     txtBasicsDOB.SetFocus
                  Case vbKeyE
                     txtBasicsEmail.SetFocus
                  Case vbKeyH
                     txtBasicsHomePhone.SetFocus
                  Case vbKeyI
                     cmbBasicsMarital.SetFocus
                  Case vbKeyM
                     cmbBasicsEmployment.SetFocus
                  Case vbKeyN
                     fgrPatNotesAdm.SetFocus
                     fgrPatNotesAdm.Select 1, 1
                     fgrPatNotesAdm.EditCell
                     fgrPatNotesAdm.EditSelStart = 0
                  Case vbKeyP
                     cmbBasicsProvider.SetFocus
                  Case vbKeyS
                     txtBasicsSSN.SetFocus
                  Case vbKeyT
                     cmbBasicsState.SetFocus
                  Case vbKeyU
                     cmbBasicsStudent.SetFocus
                  Case vbKeyV
                     chkBasicsActive.SetFocus
                  Case vbKeyW
                     txtBasicsWorkPhone.SetFocus
                  Case vbKeyX
                     cmbBasicsSex.SetFocus
                  Case vbKeyZ
                     txtBasicsZip.SetFocus
               End Select

            Case TAB_RP                            ' Navigation for RP Tab
               Select Case KeyCode
                  Case vbKeyA
                     txtRPAddress1.SetFocus
                  Case vbKeyC
                     txtRPCity.SetFocus
                  Case vbKeyD
                     txtRPDOB.SetFocus
                  Case vbKeyE
                     txtRPEmail.SetFocus
                  Case vbKeyH
                     txtRPHomePhone.SetFocus
                  Case vbKeyI
                     cmbRPMarital.SetFocus
                  Case vbKeyL
                     txtRPLastName.SetFocus
                  Case vbKeyM
                     cmbRPEmployment.SetFocus
                  Case vbKeyN
                      MsgBox "This will be RP Administrative Notes."
                  Case vbKeyR
                     cmbRPRPPatRel.SetFocus
                  Case vbKeyS
                     chkRPSendStatement.SetFocus
                  Case vbKeyT
                     cmbRPState.SetFocus
                  Case vbKeyW
                     txtRPWorkPhone.SetFocus
                  Case vbKeyX
                     cmbRPSex.SetFocus
                  Case vbKeyY
                     chkRPSendStatement.SetFocus
                  Case vbKeyZ
                     txtRPZip.SetFocus
               End Select

            Case TAB_MEDICAL                       ' Navigation for Medical Tab
               Select Case KeyCode
                  Case vbKey1
                     txtMedicalDiagCode(0).SetFocus
                  Case vbKey2
                     txtMedicalDiagCode(1).SetFocus
                  Case vbKey3
                     txtMedicalDiagCode(2).SetFocus
                  Case vbKey4
                     txtMedicalDiagCode(3).SetFocus
                  Case vbKeyC
                     txtMedicalDateFirstConsulted.SetFocus
                  Case vbKeyD
                     txtMedicalDateDied.SetFocus
                  Case vbKeyL
                     txtMedicalDateFirstSymptom.SetFocus
                  Case vbKeyP
                     cmbMedicalProvider.SetFocus
                  Case vbKeyR
                     cmbMedicalRefPhys.SetFocus
                  Case vbKeyS
                     txtMedicalDateFirstSymptom.SetFocus
               End Select
     
         End Select
      End If
   End If

End Sub

Private Sub FramesKludge()
'
'     framesKludge Sub: Prevent the background color of
'                       frames from "slopping over" the tops
'                       of the frames.
'
'     Passed: Nothing
'
'     Called only once, when a form is activated.
'     This is a gimmick to avoid BackColor "slopping over"
' the top of the frame. Set Font to a True Type font
' (Arial will do) in the design-time Properties, and Font
' Size to 1. The "slop" is still there, but it's so tiny
' you don't notice it.
'     Microsoft screwed this up. Background color ought to
' apply to only the area within the frame.
'
   fraBasicsDemographics.FontSize = 1

   fraRPName.FontSize = 1
   fraRPDemographics.FontSize = 1
   fraRPNotes.FontSize = 1

   fraMedicalProvider.FontSize = 1
   fraMedicalDiagnoses.FontSize = 1
   fraMedicalDates.FontSize = 1
   fraMedicalNotes.FontSize = 1
   fraMedicalReferrals.FontSize = 1

   fraAppNextAppRecall.FontSize = 1
   fraAppPrevApp.FontSize = 1

End Sub
Private Function NewPatientBasicsOK() As Boolean

   Dim whereClause As String
   Dim userMsg As String
   Dim userReply As VbMsgBoxResult

   correctingErrorOnTab = False
   IgnoreEnter = True

   ' Make sure the new patient's basic info has been entered.
   If txtPatientLastName = "" Then
      correctingErrorOnTab = True
      tabPatient.Tab = TAB_BASICS
      MsgBox "Patient Last Name cannot be blank."
      txtPatientLastName.SetFocus
      NewPatientBasicsOK = False
      Exit Function
   End If

   If txtPatientFirstName = "" Then
      correctingErrorOnTab = True
      tabPatient.Tab = TAB_BASICS
      MsgBox "Patient First Name cannot be blank."
      NewPatientBasicsOK = False
      txtPatientFirstName.SetFocus
      Exit Function
   End If

   If txtBasicsAddress1 = "" Then
      correctingErrorOnTab = True
      tabPatient.Tab = TAB_BASICS
      MsgBox "The first line of the patient's address cannot be blank."
      txtBasicsAddress1.SetFocus
      NewPatientBasicsOK = False
      Exit Function
   End If

   If txtBasicsCity = "" Then
      correctingErrorOnTab = True
      tabPatient.Tab = TAB_BASICS
      MsgBox "The patient's City cannot be blank."
      txtBasicsCity.SetFocus
      NewPatientBasicsOK = False
      Exit Function
   End If

   If cmbBasicsState = "" Then
      correctingErrorOnTab = True
      tabPatient.Tab = TAB_BASICS
      MsgBox "The patient's State cannot be blank."
      cmbBasicsState.SetFocus
      NewPatientBasicsOK = False
      Exit Function
   End If

   If txtBasicsDOB = "" Then
      correctingErrorOnTab = True
      tabPatient.Tab = TAB_BASICS
      MsgBox "The patient's Date of Birth (DOB) cannot be blank."
      txtBasicsDOB.SetFocus
      NewPatientBasicsOK = False
      Exit Function
   End If

   ' See if any current patient matches the new patient's first and last name.
   whereClause = "NameLast = """ & txtPatientLastName & """"
   If Not txtPatientFirstName = "" Then
      whereClause = "NameLast = """ & txtPatientLastName & """"
   Else
      whereClause = "NameLast = """ & txtPatientLastName & """ And NameFirst = """ & txtPatientFirstName & """"""
   End If
   PatientOpen rstPatientSearch, whereClause, "NameLast, NameFirst, NameMI"
   
   ' If any existing patient matches the new patient's first and last name, check DOB.
   If rstPatientSearch.RecordCount <> 0 Then
      If rstPatientSearch("DOB") = txtBasicsDOB Then
         userMsg = "This may be a patient who is already on file." & vbCrLf & vbCrLf & _
                "Patient on File: " & rstPatientSearch("NameFirst") & " " & _
                                      rstPatientSearch("NameMI") & " " & _
                                      rstPatientSearch("NameLast") & " " & _
                                      rstPatientSearch("NameSuffix") & vbCrLf & _
                "        Address: " & rstPatientSearch("Address1") & vbCrLf & _
                "           City: " & rstPatientSearch("City") & " " & _
                                      rstPatientSearch("State") & " " & _
                                      rstPatientSearch("Zip") & vbCrLf & _
                "            DOB: " & rstPatientSearch("DOB") & vbCrLf & _
                "            SSN: " & rstPatientSearch("SSN") & vbCrLf & vbCrLf & _
                "Patient Entered: " & txtPatientFirstName & " " & _
                                      txtPatientMI & " " & _
                                      txtPatientLastName & " " & _
                                      txtPatientSuffix & vbCrLf & _
                "        Address: " & txtBasicsAddress1 & vbCrLf & _
                "           City: " & txtBasicsCity & " " & _
                                      cmbBasicsState & " " & _
                                      txtBasicsZip & vbCrLf & _
                "            DOB: " & txtBasicsDOB & vbCrLf & _
                "            SSN: " & txtBasicsSSN & vbCrLf & vbCrLf & _
                "Do you want to cancel adding this patient? If so, select ""Cancel"". If not, select ""OK""."
         userReply = MsgBox(userMsg, vbOKCancel, "Warning: Possible duplicate Patient record")
         If userReply = vbOK Then
            userMsg = "This certainly seems to be a duplicate patient record." & vbCrLf & vbCrLf & _
                      "You could be creating a troublesome duplicate." & vbCrLf & vbCrLf & _
                      "Are you sure you don't want to cancel adding this patient?" & vbCrLf & vbCrLf & _
                      "To cancel adding, select ""Cancel"". To go ahead and add it, select ""OK""."
            userReply = MsgBox(userMsg, vbOKCancel, "Are you absolutely sure this is right?")
         End If
         If userReply = vbCancel Then
            correctingErrorOnTab = True
            PatientAdd
         End If
      End If
   End If

End Function

Private Function NewPatientRPOK() As Boolean

   If cmbRPRPPatRel = "" Then
      correctingErrorOnTab = True
      tabPatient.Tab = TAB_RP
      MsgBox "The relationship of the patient to the RP must be entered."
      cmbRPRPPatRel.SetFocus
      NewPatientRPOK = False
      Exit Function
   End If

End Function

Private Sub PatientAdd()

   ' Title the form to indicate we're adding a patient.
   DisplayFormCaption "Pat.Add"

   ' Clear the data for the "Finder line" controls.
   txtPatientLastName = ""
   txtPatientFirstName = ""
   txtPatientMI = ""
   txtPatientSuffix = ""
   txtPatientActNo = ""
   txtPatientActNo.TabStop = False

   ' Clear the data for the Controls on the Basics Tab.
   txtBasicsAddress1 = ""
   txtBasicsAddress2 = ""
   txtBasicsCity = ""
   chkBasicsActive = vbChecked
   cmbBasicsState = ""
   txtBasicsZip = ""
   
   txtBasicsHomePhone = ""
   txtBasicsWorkPhone = ""
   txtBasicsEmail = ""
   cmbBasicsSex = ""
   
   txtBasicsSSN = ""
   txtBasicsDOB = ""
   cmbBasicsMarital = ""
   cmbBasicsEmployment = ""
   cmbBasicsStudent = ""


   ' Clear the data for the Controls on the RP Tab.
   RPScreenClear
   
   ' Clear the data for the Controls on the Medical Tab.
   txtMedicalDiagCode(0) = ""
   txtMedicalDiagCode(1) = ""
   txtMedicalDiagCode(2) = ""
   txtMedicalDiagCode(3) = ""
   txtMedicalDateFirstConsulted = ""
   txtMedicalDateFirstSymptom = ""
   txtMedicalDateDied = ""

   ' Make the Patient Search grid invisible,
   ' and the Patient data visible.
   dgrPatientSearch.Visible = False
   tabPatient.Visible = True
   tabPatient.Tab = TAB_BASICS
   txtPatientLastName.SetFocus

   searchingForPatient = False
   adding = True
   changingRP = True

End Sub

Private Sub PatientARDisplay()

   Dim col As Integer
   Dim DueIns(5) As Currency
   Dim DueInsTotalThisPatient As Currency
   Dim DueRP(5) As Currency
   Dim DueRPTotal As Currency
   Dim DueRPTotalThisPatient As Currency
   Dim i As Integer

   ' This will become a routine to compute this patient's A/R.
   ' For now, it just arbitrarily assigns some dummy values.
   DueRPTotal = 210
   DueRP(0) = 222222.22
   DueIns(2) = 35

   With fgrPatientAR
     
      .Redraw = False
      .Cell(flexcpFontBold, 0, 0, 1, 6) = False
      .Cell(flexcpFontBold, 2, 0) = False
      .Cell(flexcpFontBold, 3, 0) = False
      .MergeCells = flexMergeFixedOnly
      .MergeRow(0) = True
      .Cell(flexcpText, 0, 0, 0, 5) = "Accounts Receivable for This Patient Only   " & _
                                      "                               " & _
                                      "RP Total Due (See RP Screen)"
     
      .Cell(flexcpText, 1, 0) = "Due From"
      .Cell(flexcpAlignment, 1, 1, 1, 6) = flexAlignRightCenter
      .Cell(flexcpText, 1, 1) = "0-30"
      .Cell(flexcpText, 1, 2) = "31-60"
      .Cell(flexcpText, 1, 3) = "61-90"
      .Cell(flexcpText, 1, 4) = "91-120"
      .Cell(flexcpText, 1, 5) = "Over 120"
      .Cell(flexcpText, 1, 6) = "Total"
      .Cell(flexcpText, 2, 0) = "RP"
      .Cell(flexcpText, 3, 0) = "Insurance"

      ' Format the grid for Currency.
      .ColFormat(1) = "###,###.00\*"
      .ColFormat(2) = "Currency"
      .ColFormat(3) = "Currency"
      .ColFormat(4) = "Currency"
      .ColFormat(5) = "Currency"
      .ColFormat(6) = "Currency"

      ' Make the actual A/R data be in bold (headings in regular type).
      .Cell(flexcpFontBold, 0, 6) = True
      .Cell(flexcpFontBold, 2, 1, 3, 6) = True

      ' Display the total for the RP for all patients.
      .Cell(flexcpText, 0, 6) = DueRPTotal
     
      ' Display the A/R data for what the RP owes for this patient.
      For i = 0 To 5
         DueRPTotalThisPatient = DueRPTotalThisPatient + DueRP(i)
         If DueRP(i) > 0 Then
            .Cell(flexcpText, 2, i + 1) = DueRP(i)
         End If
      Next i
      .Cell(flexcpText, 2, 6) = DueRPTotalThisPatient

      ' Display the A/R data for what the Insurance companies owe for this patient.
      For i = 0 To 5
         DueInsTotalThisPatient = DueInsTotalThisPatient + DueIns(i)
         If DueIns(i) > 0 Then
            .Cell(flexcpText, 3, i + 1) = DueIns(i)
         End If
      Next i
      .Cell(flexcpText, 3, 6) = DueInsTotalThisPatient

      .Redraw = True
   
   End With

End Sub

Private Sub PatientDisplay()

   ' Change the title of this form, to "Pat.-Last Name, First Name", so that
   ' it will have a meaningful name in the list of windows currently open.
   DisplayFormCaption "Pat.-" & rstThisPatient("NameLast") & ", " & rstThisPatient("NameFirst")

   ' Get the data for the "Finder line" controls.
   txtPatientLastName = rstThisPatient("NameLast")
   txtPatientFirstName = rstThisPatient("NameFirst")
   txtPatientMI = rstThisPatient("NameMI") & vbNullString
   txtPatientSuffix = rstThisPatient("NameSuffix") & vbNullString
   txtPatientActNo = rstThisPatient("ActNo")

   ' Get the data for the Controls on the Basics Tab.
   txtBasicsAddress1 = rstThisPatient("Address1") & vbNullString
   txtBasicsAddress2 = rstThisPatient("Address2") & vbNullString
   txtBasicsCity = rstThisPatient("City") & vbNullString
   GetCheckBox chkBasicsActive, rstThisPatient("Active")
   GetComboBox cmbBasicsState, "STA", rstThisPatient("State") & vbNullString
   txtBasicsZip = rstThisPatient("Zip") & vbNullString
   
   txtBasicsHomePhone = rstThisPatient("HomePhone") & vbNullString
   txtBasicsWorkPhone = rstThisPatient("WorkPhone") & vbNullString
   txtBasicsEmail = rstThisPatient("Email") & vbNullString
   GetComboBox cmbBasicsSex, "SEX", rstThisPatient("Sex") & vbNullString
   
   txtBasicsSSN = rstThisPatient("SSN") & vbNullString
   GetDate txtBasicsDOB, rstThisPatient("DOB") & vbNullString
   GetComboBox cmbBasicsMarital, "MAR", rstThisPatient("Marital") & vbNullString
   GetComboBox cmbBasicsEmployment, "EMP", rstThisPatient("Employment") & vbNullString
   GetComboBox cmbBasicsStudent, "STU", rstThisPatient("Student") & vbNullString
   GetComboBox cmbBasicsProvider, "PRO", rstThisPatient("ProvID") & vbNullString

   ' Get the data for the Controls on the Medical Tab.
   GetComboBox cmbMedicalProvider, "PRO", rstThisPatient("ProvID") & vbNullString
   GetComboBox cmbMedicalRefPhys, "REF", rstThisPatient("RefPhysID") & vbNullString
   txtMedicalDiagCode(0) = rstThisPatient("Diag1") & vbNullString
   txtMedicalDiagCode(1) = rstThisPatient("Diag2") & vbNullString
   txtMedicalDiagCode(2) = rstThisPatient("Diag3") & vbNullString
   txtMedicalDiagCode(3) = rstThisPatient("Diag4") & vbNullString
   GetDate txtMedicalDateFirstConsulted, rstThisPatient("DateFirstConsulted") & vbNullString
   GetDate txtMedicalDateFirstSymptom, rstThisPatient("DateFirstSymptom") & vbNullString
   GetDate txtMedicalDateDied, rstThisPatient("DateDied") & vbNullString

   ' We have to set the RP's Act.No. and the Patient's Relation to the RP
   ' (both on the RP screen) to avoid an updating fault
   ' if the user never goes to the RP tab.
   lblRPActNoReadOnly = rstThisPatient("RPActNo")
   GetComboBox cmbRPRPPatRel, "REL", rstThisPatient("RPPatRel") & vbNullString

   ' Make the grid invisible and the tab containing all the data visible.
   dgrPatientSearch.Visible = False
   tabPatient.Visible = True
   tabPatient.Tab = TAB_BASICS

   ' Set the focus to the first Address line (Name will rarely be changed).
   txtBasicsAddress1.SetFocus

   ' Set flags indicating what's going on.
   searchingForPatient = False
   adding = False
   editing = True
   RPHasBeenDisplayed = False

   ' Show the Patient's A/R grid.
   PatientARDisplay

   ' If there are any Administrative Notes (table "PatNotesAdm") for this
   ' patient which are checked to show when the patient comes up,
   ' display all such messages in red.
   ' After that display, fill the Administrative Notes grid (fgrPatNotesAdm)
   ' with all of the notes for this Patient.
   rstPatNotesAdm.Seek Array(txtPatientActNo, "12/31/9999", 0), adSeekAfterEQ
   PatientNotesAdmRedDisplay

End Sub

Private Sub PatientNotesAdmDisplay()
'
'   Show all of the Administrative Notes for this patient, checked or not, in a grid.
'

   Dim noteText As String
   Dim textDate As String

   ' Close out the Red Notes display, set up to display all notes.
   PatNotesAdmDisplayInProgress = False
   txtBasicsRedNoteHeading.Visible = False
   txtBasicsRedNote.Visible = False
   fgrPatNotesAdm.Visible = True

   ' Display all of this patient's administrative notes.
   
   ' First position to the latest note for this patient, if there are any.
   rstPatNotesAdm.Seek Array(txtPatientActNo, "12/31/9999", 0), adSeekAfterEQ

   ' To optimize execution time, don't display until all notes have been processed.
   With fgrPatNotesAdm
      .Redraw = False
      .Cell(flexcpFontBold, 0, 1, 0, 2) = False
      .Rows = 1     ' 0 data rows, one column header row
      Do Until rstPatNotesAdm.EOF
         If rstPatNotesAdm("PatActNo") <> txtPatientActNo Then
            Exit Do
         End If
         rstUsers.Seek Array(rstPatNotesAdm("UserNo"))
         textDate = Format(rstPatNotesAdm("NoteDate"), "Short Date")
         noteText = rstPatNotesAdm("NoteText") & " [" & rstUsers("UserID") & " - " & textDate & "]"
         .AddItem "" & vbTab & noteText & vbTab & rstPatNotesAdm("AutoDisplay")
         rstPatNotesAdm.MoveNext
      Loop
   
      ' Create a multi-line, word-wrap display of the note in Column 1.
      .AutoSize 1

      .Select 0, 1, .Rows - 1, 2
      .CellBorder RGB(255, 255, 255), 1, 1, 1, 1, 1, 1
      .Redraw = True
   End With

      fgrJustFilled = True

End Sub

Private Sub PatientNotesAdmRedDisplay()
'
'     Show the Administrative Notes for this patient which are checked
'     to be shown as soon as the patient comes up, if there are any.
'
   Do
      If rstPatNotesAdm.EOF Then
         PatientNotesAdmDisplay      ' All red notes displayed, now show all notes in a grid.
         Exit Do
      End If
      If rstPatNotesAdm("PatActNo") <> txtPatientActNo Then
         PatientNotesAdmDisplay      ' All red notes displayed, now show all notes in a grid.
         Exit Do
      End If
      If rstPatNotesAdm("AutoDisplay") Then
         txtBasicsRedNote = rstPatNotesAdm("NoteText")
         fgrPatNotesAdm.Visible = False
         txtBasicsRedNoteHeading.Visible = True
         txtBasicsRedNote.Visible = True
         PatNotesAdmDisplayInProgress = True
         rstPatNotesAdm.MoveNext
         Exit Do
      End If
      rstPatNotesAdm.MoveNext
   Loop

End Sub

Private Sub PatientOpen(rstPat As Recordset, _
                        Optional whereClause As String = "", _
                        Optional orderByClause As String = "", _
                        Optional selectClause As String = "")

   ' Close the Recordset if it's open.
   If rstPat.State = adStateOpen Then
      rstPat.Close
   End If

   ' Build the connection string.
   rstPat.ActiveConnection = _
        "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & MedtechPracticePath & "\Medtech.mdb"
   If selectClause = "" Then
      rstPat.Source = "SELECT * FROM Patient"
   Else
      rstPat.Source = "SELECT " & selectClause & " FROM Patient"
   End If
   If whereClause <> "" Then
      rstPat.Source = rstPat.Source & " WHERE " & whereClause
   End If
   If orderByClause <> "" Then
      rstPat.Source = rstPat.Source & " ORDER BY " & orderByClause
   End If
   
   ' Set the cursor to the client.
   rstPat.CursorLocation = adUseClient
   
   ' Try to open the Recordset.
   On Error Resume Next
   Err.Clear
   rstPat.Open , , adOpenStatic, adLockOptimistic
   If Err.Number <> 0 Then
      MsgBox "Problem opening Patient file: " & _
             "Error # " & Str(Err.Number) & _
             " was generated by " & Err.Source & vbCrLf & _
             Err.Description, , "Error", Err.HelpFile, Err.HelpContext
      End
   End If

End Sub

Private Sub PatientSearch()

   Dim whereClause As String

   ' Get all the records which match the First and Last Names entered.
   If txtPatientFirstName = "" Then
      whereClause = "NameLast LIKE """ & txtPatientLastName & "%"""
   Else
      whereClause = "NameLast LIKE """ & txtPatientLastName & "%""" & _
                    " AND NameFirst LIKE """ & txtPatientFirstName & "%"""
   End If
   PatientOpen rstPatientSearch, whereClause, "NameLast, NameFirst, NameMI", _
               "NameLast,NameFirst,NameMI,NameSuffix,Address1,City,State,ActNo"

   ' If no records match, tell the user and let her try again.
   If rstPatientSearch.RecordCount = 0 Then
      MsgBox "No patient(s) found. Try again.", vbOKOnly + vbExclamation, "No matches!"
      txtPatientLastName = ""
      txtPatientFirstName = ""
      txtPatientLastName.SetFocus
      Exit Sub
   End If

   ' Bind the recordset to the grid.
   Set adcPatient.Recordset = rstPatientSearch
   Set dgrPatientSearch.DataSource = adcPatient

   ' Clear the other fields on the "Finder" line.
   txtPatientMI = ""
   txtPatientSuffix = ""
   txtPatientActNo = ""

   ' Set the focus to the grid, to let the user select a patient.
   dgrPatientSearch.SetFocus

End Sub

Private Sub PatientSearchInit()

   Static afterInitialization As Boolean

   Set dgrPatientSearch.DataSource = Nothing

   ' Make the Patient Name line editable.
   txtPatientLastName.TabStop = True
   txtPatientFirstName.TabStop = True
   txtPatientMI.TabStop = True
   txtPatientSuffix.TabStop = True
   txtPatientActNo.TabStop = True
   
   ' Make the Patient Search grid visible
   ' (but don't let it get the focus),
   ' and make the Patient data invisible.
   dgrPatientSearch.Visible = True
   dgrPatientSearch.TabStop = False
   tabPatient.Visible = False

   ' Clear the data for the "Finder line" controls.
   txtPatientLastName = ""
   txtPatientFirstName = ""
   txtPatientMI = ""
   txtPatientSuffix = ""
   txtPatientActNo = ""

   searchingForPatient = True
   adding = False

   DisplayFormCaption "Pat.Search"

   ' This subroutine is called by Form_Initialize, before any of the
   ' controls have been activated. Therefore we have to avoid referencing
   ' any of the controls at that time. The TabIndex of the txtPatientLastName
   ' control (0) will get the focus to it at Form_Initialize time.
   ' After that, we force the focus to Patient Last Name.
   If afterInitialization Then
      txtPatientLastName.SetFocus
   Else
      afterInitialization = True
   End If

End Sub

Private Sub PatientSelectedByActNo(PatientActNo As Long)

   Dim NameLast As String
   Dim NameFirst As String
   Dim NameMI As String
   Dim NameSuffix As String
   Dim actNo As String

   ' Fetch the patient's record.
   ' Note that this is done via "Seek" (an ISAM command) rather than SQL.
   ' "Seek" is much, much faster than SQL.
   rstThisPatient.Index = "ActNo"
   rstThisPatient.Seek Array(PatientActNo)
   If rstThisPatient.EOF Then
      MsgBox "Patient not found"
      rstThisPatient.Index = "Name"
   Else

      ' The patient record was found by Act.No.
      ' Now we have to position the Name Index so that
      ' the "Get Next" and "Get Previous" commands will work.
      ' First, save the name fields from the record found by Account Number.
      ' Setting the index to "Name" will get a different record.
      NameLast = rstThisPatient("NameLast")
      NameFirst = rstThisPatient("NameFirst")
      NameMI = rstThisPatient("NameMI")
      NameSuffix = rstThisPatient("NameSuffix")
      actNo = rstThisPatient("ActNo")
      rstThisPatient.Index = "Name"
      rstThisPatient.Seek Array(NameLast, NameFirst, NameMI, NameSuffix, actNo), _
                                adSeekFirstEQ
      If rstThisPatient.EOF Then
         MsgBox "Patient not found"
      Else
         PatientDisplay
      End If
   End If

End Sub

Private Sub PatientSelectedByName()

   ' Find the patient record by the Name Index
   ' (Name Index selected in Form_Initialize)
   rstThisPatient.Seek Array(dgrPatientSearch.Columns(PATIENT_NAME_LAST), _
                       dgrPatientSearch.Columns(PATIENT_NAME_FIRST), _
                       dgrPatientSearch.Columns(PATIENT_NAME_MI), _
                       dgrPatientSearch.Columns(PATIENT_NAME_SUFFIX), _
                       dgrPatientSearch.Columns(PATIENT_ACT_NO)), _
                       adSeekFirstEQ
   If rstThisPatient.EOF Then
      MsgBox "Patient not found"
   Else
      PatientDisplay
   End If

End Sub

Private Function PatientUpdate() As Boolean

   Dim Msg As String

   ' Set up error handling.
   On Error GoTo ErrorHandler   ' Defer error handling.
   Err.Clear
   
   ' Exit if no patient being updated.
   If searchingForPatient Then
      PatientUpdate = True
      Exit Function
   End If

   ' First, data-check to make sure the crucial fields are OK.
   ' Make sure there's a Patient Last Name.
   If Len(txtPatientLastName) = 0 Then
      MsgBox "Patient Last name cannot be blank. Please correct."
      txtPatientLastName.SetFocus
      PatientUpdate = False
      Exit Function
   End If

   ' Make sure there's a Patient First Name.
   If Len(txtPatientFirstName) = 0 Then
      MsgBox "First name cannot be blank. Please correct."
      txtPatientFirstName.SetFocus
      PatientUpdate = False
      Exit Function
   End If

   ' If adding, set up for a new patient.
   If adding Then
      rstThisPatient.AddNew
   End If
     
   ' Move the updated data from the screen controls to the record's fields.
   ' Start with the "Finder line" controls.
   rstThisPatient("NameLast") = txtPatientLastName
   rstThisPatient("NameFirst") = txtPatientFirstName
   rstThisPatient("NameMI") = txtPatientMI
   rstThisPatient("NameSuffix") = txtPatientSuffix

   ' Move the data from the Controls on the Basics Tab to the Patient record's fields.
   rstThisPatient("Address1") = txtBasicsAddress1
   rstThisPatient("Address2") = txtBasicsAddress2
   rstThisPatient("City") = txtBasicsCity
   rstThisPatient("Active") = chkBasicsActive
   rstThisPatient("State") = comboBoxCodes(cmbBasicsState.ItemData(cmbBasicsState.ListIndex))
   rstThisPatient("Zip") = txtBasicsZip

   rstThisPatient("HomePhone") = txtBasicsHomePhone
   rstThisPatient("WorkPhone") = txtBasicsWorkPhone
   rstThisPatient("Email") = txtBasicsEmail
   rstThisPatient("Sex") = comboBoxCodes(cmbBasicsSex.ItemData(cmbBasicsSex.ListIndex))
   
   rstThisPatient("SSN") = txtBasicsSSN
   PutDate rstThisPatient("DOB"), txtBasicsDOB
   rstThisPatient("Marital") = comboBoxCodes(cmbBasicsMarital.ItemData(cmbBasicsMarital.ListIndex))
   rstThisPatient("Employment") = comboBoxCodes(cmbBasicsEmployment.ItemData(cmbBasicsEmployment.ListIndex))
   rstThisPatient("Student") = comboBoxCodes(cmbBasicsStudent.ItemData(cmbBasicsStudent.ListIndex))
   PutComboBoxNumeric rstThisPatient("ProvID"), cmbBasicsProvider

   ' Move the data from the Controls on the Medical Tab to the Patient record's fields.
   PutComboBoxNumeric rstThisPatient("RefPhysID"), cmbMedicalRefPhys
   rstThisPatient("Diag1") = txtMedicalDiagCode(0)
   rstThisPatient("Diag2") = txtMedicalDiagCode(1)
   rstThisPatient("Diag3") = txtMedicalDiagCode(2)
   rstThisPatient("Diag4") = txtMedicalDiagCode(3)
   PutDate rstThisPatient("DateFirstConsulted"), txtMedicalDateFirstConsulted
   PutDate rstThisPatient("DateFirstSymptom"), txtMedicalDateFirstSymptom
   PutDate rstThisPatient("DateDied"), txtMedicalDateDied
   rstThisPatient("RPActNo") = lblRPActNoReadOnly
   rstThisPatient("RPPatRel") = comboBoxCodes(cmbRPRPPatRel.ItemData(cmbRPRPPatRel.ListIndex))

   ' Write out the updated Patient record
   rstThisPatient.Update

   ' If this RP is not "Self",
   ' update and write out the updated RP record if the RP screen has been displayed.
   If cmbRPRPPatRel <> "Self" And RPHasBeenDisplayed Then
     
      ' Move the data from the Controls on the RP Tab to the RP record's fields.
      rstThisRP("NameLast") = txtRPLastName
      rstThisRP("NameFirst") = txtRPFirstName
      rstThisRP("NameMI") = txtRPMI
      rstThisRP("NameSuffix") = txtRPSuffix
      rstThisRP("Address1") = txtRPAddress1
      rstThisRP("Address2") = txtRPAddress2
      rstThisRP("City") = txtRPCity
      rstThisRP("State") = comboBoxCodes(cmbRPState.ItemData(cmbRPState.ListIndex))
      rstThisRP("Zip") = txtRPZip
   
      rstThisRP("HomePhone") = txtRPHomePhone
      rstThisRP("WorkPhone") = txtRPWorkPhone
      rstThisRP("Email") = txtRPEmail
      rstThisRP("RPSendStatement") = chkRPSendStatement
      rstThisRP("Sex") = comboBoxCodes(cmbRPSex.ItemData(cmbRPSex.ListIndex))
      rstThisRP("SSN") = txtRPSSN
      PutDate rstThisRP("DOB"), txtRPDOB
      rstThisRP("Marital") = comboBoxCodes(cmbRPMarital.ItemData(cmbRPMarital.ListIndex))
      rstThisRP("Employment") = comboBoxCodes(cmbRPEmployment.ItemData(cmbRPEmployment.ListIndex))

      rstThisRP.Update

   End If

   ' Indicate there was no error in the PatientUpdate Sub.
   PatientUpdate = True
   Exit Function

   ' Error-handling routine.
ErrorHandler:
      If Err.Number <> 0 Then
         Msg = "Patient Update Problem: Error # " & Str(Err.Number) & " was generated by " _
               & Err.Source & vbCrLf & Err.Description
         MsgBox Msg, , "Error", Err.HelpFile, Err.HelpContext
      End If
      End

End Function

Private Sub Label1_Click()

End Sub

Private Sub picFX_Click(Index As Integer)

   CommandDispatcher Index

End Sub

Private Sub RPChange()

   Dim Response As VbMsgBoxResult

   If RPHasJustBeenRestored Then
      RPHasJustBeenRestored = False
      Exit Sub
   End If

   Response = MsgBox("You have changed the name of the Responsible Party." & vbCrLf & vbCrLf & _
                     "Do you mean to change the RP?", _
                     vbYesNo, "Possible Change of RP")
   If Response = vbYes Then
      RPScreenClear
      cmbRPRPPatRel.SetFocus
      changingRP = True
   Else
      Response = MsgBox("Do you want to change the RP's name?", _
                        vbYesNo, "Possible Change of RP's Name")
      If Response <> vbYes Then
         RPHasJustBeenRestored = True
         RPDisplay lblRPActNoReadOnly
      End If
   End If

End Sub

Private Sub RPDisplay(RPActNo As Long)

   ' Fetch the RP's Patient record.
   rstThisRP.Seek Array(RPActNo), adSeekFirstEQ
   If rstThisRP.EOF Then
      MsgBox "RP not found"
      Exit Sub
   End If

   GetComboBox cmbRPRPPatRel, "REL", rstThisPatient("RPPatRel") & vbNullString
   txtRPLastName = rstThisRP("NameLast")
   txtRPFirstName = rstThisRP("NameFirst")
   txtRPMI = rstThisRP("NameMI") & vbNullString
   txtRPSuffix = rstThisRP("NameSuffix") & vbNullString
   txtRPAddress1 = rstThisRP("Address1") & vbNullString
   txtRPAddress2 = rstThisRP("Address2") & vbNullString
   txtRPCity = rstThisRP("City") & vbNullString
   GetComboBox cmbRPState, "STA", rstThisRP("State") & vbNullString
   txtRPZip = rstThisRP("Zip") & vbNullString
   
   lblRPActNoReadOnly = rstThisRP("ActNo")
   txtRPHomePhone = rstThisRP("HomePhone") & vbNullString
   txtRPWorkPhone = rstThisRP("WorkPhone") & vbNullString
   txtRPEmail = rstThisRP("Email") & vbNullString
   GetCheckBox chkRPSendStatement, rstThisRP("RPSendStatement")
   GetComboBox cmbRPSex, "SEX", rstThisRP("Sex") & vbNullString
   
   txtRPSSN = rstThisRP("SSN") & vbNullString
   GetDate txtRPDOB, rstThisRP("DOB") & vbNullString
   GetComboBox cmbRPMarital, "MAR", rstThisRP("Marital") & vbNullString
   GetComboBox cmbRPEmployment, "EMP", rstThisRP("Employment") & vbNullString

   txtRPAddress1.SetFocus

   changingRP = False
   RPHasBeenDisplayed = True

End Sub

Private Sub RPScreenClear()

   cmbRPRPPatRel = ""
   txtRPLastName = ""
   txtRPFirstName = ""
   txtRPMI = ""
   txtRPSuffix = ""
   txtRPAddress1 = ""
   txtRPAddress2 = ""
   txtRPCity = ""
   cmbRPState = ""
   txtRPZip = ""

   lblRPActNoReadOnly = ""
   txtRPHomePhone = ""
   txtRPWorkPhone = ""
   txtRPEmail = ""
   chkRPSendStatement = vbChecked
   cmbRPSex = ""

   txtRPSSN = ""
   txtRPDOB = ""
   cmbRPMarital = ""
   cmbRPEmployment = ""

End Sub
                       
Private Sub RPSearch()

   Dim whereClause As String

   ' Get all the records which match the First and Last Names entered.
   If txtRPFirstName = "" Then
      whereClause = "NameLast LIKE """ & txtRPLastName & "%"""
   Else
      whereClause = "NameLast LIKE """ & txtRPLastName & "%""" & _
                    " AND NameFirst LIKE """ & txtRPFirstName & "%"""
   End If
   PatientOpen rstPatientSearch, whereClause, "NameLast, NameFirst, NameMI", _
               "NameLast,NameFirst,NameMI,NameSuffix,Address1,City,State,ActNo"

   ' If no records match, tell the user and let her try again.
   If rstPatientSearch.RecordCount = 0 Then
      MsgBox "No patient(s) found. Try again.", vbOKOnly + vbExclamation, "No matches!"
      txtRPLastName = ""
      txtRPFirstName = ""
      txtRPLastName.SetFocus
      Exit Sub
   End If

   ' Bind the recordset to the grid.
   Set adcPatient.Recordset = rstPatientSearch
   Set dgrRPSearch.DataSource = adcPatient

   ' Clear the other fields on the "Finder" line.
   txtRPMI = ""
   txtRPSuffix = ""
   lblRPActNoReadOnly = ""

   ' Set the focus to the grid, to let the user select a patient.
   dgrRPSearch.SetFocus

End Sub

Private Sub RPSearchInit()

   ' The patient's relation to the RP is a required field.
   If cmbRPRPPatRel = "" Then
      IgnoreEnter = True
      MsgBox "The Patient's relation to the RP is required."
      cmbRPRPPatRel.SetFocus
      Exit Sub
   End If

   ' If the Patient and the RP are the same person,
   ' we have a "no-brainer" situation.
   If cmbRPRPPatRel = "Self" Then
      RPSelfCopyBasicsToRP
      Exit Sub
   End If

   ' We have to search for the RP.
   ' Make the RP Search grid visible,
   ' (but don't let it get the focus),
   ' and make the RP data invisible.
   dgrRPSearch.Visible = True
   dgrRPSearch.TabStop = False
   fraRPDemographics.Visible = False
   fraRPAR.Visible = False
   fraRPNotes.Visible = False

   ' Clear the data for the "Finder line" controls.
   txtRPLastName = ""
   txtRPFirstName = ""
   txtRPMI = ""
   txtRPSuffix = ""
   lblRPActNoReadOnly = ""

   searchingForRP = True

   txtRPLastName.SetFocus

End Sub

Private Sub RPSelected(RPActNo As Long)

   ' Make the RP Search grid invisible, and the data visible.
   dgrRPSearch.Visible = False
   fraRPDemographics.Visible = True
   fraRPAR.Visible = True
   fraRPNotes.Visible = True

   ' Display the data in this RP record.
   RPDisplay RPActNo

End Sub

Private Sub RPSelfCopyBasicsToRP()

   If cmbRPRPPatRel = "Self" Then
      lblRPActNoReadOnly = txtPatientActNo
      txtRPLastName = txtPatientLastName
      txtRPFirstName = txtPatientFirstName
      txtRPMI = txtPatientMI
      txtRPSuffix = txtPatientSuffix
      txtRPAddress1 = txtBasicsAddress1
      txtRPAddress2 = txtBasicsAddress2
      txtRPCity = txtBasicsCity
      cmbRPState = cmbBasicsState
      txtRPZip = txtBasicsZip
   
      txtRPHomePhone = txtBasicsHomePhone
      txtRPWorkPhone = txtBasicsWorkPhone
      txtRPEmail = txtBasicsEmail
      If adding Then
         chkRPSendStatement = vbChecked
      Else
         GetCheckBox chkRPSendStatement, rstThisPatient("RPSendStatement")
      End If
      cmbRPSex = cmbBasicsSex
   
      txtRPSSN = txtBasicsSSN
      txtRPDOB = txtBasicsDOB
      cmbRPMarital = cmbBasicsMarital
      cmbRPEmployment = cmbBasicsEmployment
   End If

End Sub

Private Sub RPSelfCopyRPToBasics()

   If cmbRPRPPatRel = "Self" Then
      txtPatientLastName = txtRPLastName
      txtPatientFirstName = txtRPFirstName
      txtPatientMI = txtRPMI
      txtPatientSuffix = txtRPSuffix
      txtBasicsAddress1 = txtRPAddress1
      txtBasicsAddress2 = txtRPAddress2
      txtBasicsCity = txtRPCity
      cmbBasicsState = cmbRPState
      txtBasicsZip = txtRPZip
   
      txtBasicsHomePhone = txtRPHomePhone
      txtBasicsWorkPhone = txtRPWorkPhone
      txtBasicsEmail = txtRPEmail
      cmbBasicsSex = cmbRPSex
   
      txtBasicsSSN = txtRPSSN
      txtBasicsDOB = txtRPDOB
      cmbBasicsMarital = cmbRPMarital
      cmbBasicsEmployment = cmbRPEmployment
   End If

End Sub

Private Sub tabPatient_Click(PreviousTab As Integer)

   If correctingErrorOnTab Then
      correctingErrorOnTab = False
      Exit Sub
   End If
   
   If tabPatient.Tab = TAB_RP Then
      If Not (adding Or RPHasBeenDisplayed) Then
         RPDisplay lblRPActNoReadOnly
      End If
   End If
   
   Select Case PreviousTab
     
      Case TAB_BASICS
         If adding Then
            If Not NewPatientBasicsOK Then
               Exit Sub
            End If
         End If
         If Not searchingForPatient Then
            RPSelfCopyBasicsToRP
            cmbMedicalProvider.ListIndex = cmbBasicsProvider.ListIndex
         End If

      Case TAB_RP
         If adding Then
            If Not NewPatientRPOK Then
               Exit Sub
            End If
         End If
         If Not searchingForPatient Then
            RPSelfCopyRPToBasics
         End If
   
      Case TAB_MEDICAL
         If Not searchingForPatient Then
            cmbBasicsProvider.ListIndex = cmbMedicalProvider.ListIndex
         End If
   
   End Select

   If tabPatient.Tab <> TAB_BASICS Then
      txtPatientLastName.TabStop = False
      txtPatientFirstName.TabStop = False
      txtPatientMI.TabStop = False
      txtPatientSuffix.TabStop = False
      txtPatientActNo.TabStop = False
   End If

   Select Case tabPatient.Tab

      Case TAB_BASICS
         txtBasicsAddress1.SetFocus
     
      Case TAB_RP
         cmbRPRPPatRel.SetFocus
   
   End Select

End Sub

Private Sub tlgBasicsNotes_GotFocus()

   txtBasicsAddress1.SetFocus

End Sub

Private Sub tlgRPNotes_GotFocus()

   txtRPAddress1.SetFocus

End Sub

Private Sub txtPatientActNo_LostFocus()

   If Not txtPatientActNo = "" Then
      PatientSelectedByActNo (txtPatientActNo)
   End If

End Sub

Private Sub txtPatientMI_GotFocus()

   If adding Then
      Exit Sub
   End If

   If Not searchingForPatient Then
      Exit Sub
   End If

   If txtPatientLastName <> "" Then
      PatientSearch
   Else
      MsgBox "You must enter at least one letter of the patient's last name."
      txtPatientLastName.SetFocus
   End If

End Sub

Private Sub txtRPFirstName_Change()

   If RPHasBeenDisplayed Then
      RPChange
   End If

End Sub

Private Sub txtRPLastName_Change()

   If RPHasBeenDisplayed Then
      RPChange
   End If

End Sub

Private Sub txtRPMI_Change()

   If RPHasBeenDisplayed Then
      RPChange
   End If

End Sub

Private Sub txtRPMI_GotFocus()

   If Not searchingForRP Then
      Exit Sub
   End If

   If Not (txtRPLastName = "") Then
      RPSearch
   Else
      MsgBox "You must enter at least one letter of the RP's last name."
      txtRPLastName.SetFocus
   End If

End Sub

Private Sub txtRPSuffix_Change()

   If RPHasBeenDisplayed Then
      RPChange
   End If

End Sub




     And here's the Public Code Module:

Option Explicit

Private rstCfg As New ADODB.Recordset
Private rstGlobalFile As New ADODB.Recordset
Public rstGlobals As New ADODB.Recordset

' Global array of comboBox codes: An array of strings containing the Code from
' "rstGlobals". See the ComboBox Functions writeup below for more info.
Public comboBoxCodes()
Public comboBoxCodesIndex As Integer
Public comboBoxFromTableMnemonics()
Public comboBoxFromTableMnemonicsIndex As Integer

' Global constants defining child for position and size
Public Const CHILD_FORM_LEFT = -45
Public Const CHILD_FORM_TOP = -45
Public Const CHILD_FORM_HEIGHT = 7545
Public Const CHILD_FORM_WIDTH = 11865

' Miscellaneous Global Constants
Public Const NO_RECORDS_OK = True

' Global variables used throughout the application
Public cmbBoxKeyedSoFar As String
Public IgnoreEnter As Boolean
Public MedtechServerPath As String
Public MedtechPracticePath As String
Public PracticeContact As String
Public PracticeCount As Integer
Public PracticeName As String
Public PracticeNo As Long
Public PracticePhone As String
Public UserIDsRequired As Boolean
Public UserNameFirst As String
Public UserNameLast As String
Public UserNo As Long
Public UserPWsRequired As Boolean

' The following "UserPrivDefault" fields are the privileges
' from the current user's record. They are used to initialize
' the privileges when a new practice is added.
' See file "Users" in "MedtechGlobals".
Public UserPrivDefaultCharges As String
Public UserPrivDefaultLedger As String
Public UserPrivDefaultMasterFiles As String
Public UserPrivDefaultPatient As String
Public UserPrivDefaultPayments As String
Public UserPrivDefaultReports As String

' The following "UserPriv" fields are the privileges for the
' current user when accessing the current pactice.
' See file "UserPractices" in "MedtechGlobals".
Public UserPrivCharges As String
Public UserPrivLedger As String
Public UserPrivMasterFiles As String
Public UserPrivPatient As String
Public UserPrivPayments As String
Public UserPrivPracticeAdmin As Boolean
Public UserPrivReports As String

' The following field is the System Administrator flag.
' It applies to all Practices, over-rides everything.
Public UserPrivSysAdmin As Boolean

' The following are the colors to use on the forms, as specified
' in Medtech.cfg as the defaults, or as specified by the individual
' user in UserPreferences.
Public FormBackColor As Long
Public FormTextColor As Long
Public FrameBackColor As Long
Public FrameTextColor As Long
Public DefaultFormBackColor As Long
Public DefaultFormTextColor As Long
Public DefaultFrameBackColor As Long
Public DefaultFrameTextColor As Long
Public UserFormBackColor As Long
Public UserFormTextColor As Long
Public UserFrameBackColor As Long
Public UserFrameTextColor As Long

Sub Main()
'
'                           Startup Procedure
'

   Dim frmHome As New frmMedtechHome
   Dim i As Integer
   Dim userReply As VbMsgBoxResult

   ' Get all of the combo box parameters from "Lists" in "MedtechGlobals".
   GetCfgParameters

   ' Compute the number of practices now on this system.
   ' The count will be updated in frmMedtechPractices when
   ' practices are added and/or deleted.
   OpenGlobalFile "Practices", ""
   PracticeCount = rstGlobalFile.RecordCount
   rstGlobalFile.Close

   ' Main Loop to let a user log in, execute system functions, and log off.
   Do

      ' If Medtech.cfg specified that ID's are enabled,
      ' ask the user for his or her ID, and for his/her
      ' Password if passwords are enabled in Medtech.cfg.
      If UserIDsRequired Then
         frmMedtechLogin.show vbModal
         If Not frmMedtechLogin.LoginOK Then
            End
         End If
      End If

      ' OK, a user has logged on. Now load and show the main form,
      ' showing the splash form while the main form is loading.
      frmMedtechSplash.show
      frmMedtechSplash.Refresh
      Unload frmMedtechSplash
      frmMedtechMain.show

      ' Open the UserPractices file: It contains one record for every current
      ' (active) user for every current practice.
      ' Ignore records which do not have Access granted.
      OpenGlobalFile "UserPractices", "WHERE UserNo = " & UserNo & _
                                      " AND Access", NO_RECORDS_OK

      ' If this user is not authorized to access any practices,
      ' she can't log on.
      If rstGlobalFile.RecordCount = 0 Then
         MsgBox "You have no access to any practice." & vbCrLf & _
                "The system administrator must update the Practices file to correct this." & _
                vbCrLf & vbCrLf & _
                "Please ask the system adminstrator to make the required changes," & _
                vbCrLf & "then log on again."
         End
     
      ' If this user is authorized to access only one practice,
      ' log her on and let her update that one practice.
      ' There's no need to display the "Select Practice" screen.
      ElseIf rstGlobalFile.RecordCount = 1 Then
         PracticeNo = rstGlobalFile("PracticeNo")
         rstGlobalFile.Close
         SetPractice PracticeNo

      ' If this user is authorized to access two or more practices, show the
      ' "Select Practice" screen and let her select which practice to update.
      Else
         rstGlobalFile.Close
         frmMedtechSelectPractice.show vbModal
         If Not frmMedtechSelectPractice.PracticeSelectedOK Then
            End
         End If
         Unload frmMedtechSelectPractice
      End If

      ' Inner Loop, to handle a user changing her mind about logging off.
      Do

         ' Bring up the "Home" screen.
         ' The user can execute whatever system functions he or she cares to,
         ' from the MDI Main screen menu.
         ' When the user logs off (only possible from the "Home" screen),
         ' the "Create New Form frmHome" call returns. We must go back up to
         ' the top of this "Do" loop to log on a new user.
         ShowNewForm frmHome, "Welcome to Medtech", -2

         ' If the user has exited the entire application, Sayonara!
         If Forms.Count = 0 Then
            End
         End If

         ' The norm is to have just one form active, the MDI main form.
         ' If that's the situation, we just exit the inner Do loop
         ' and go back to the top of the outer Do loop to log on again.
         If Forms.Count = 1 Then
            Exit Do
         End If

         ' The user has not exited the entire application.
         ' There are multiple forms displayed.
         ' Warn the user and terminate them if so instructed.
         userReply = MsgBox("You have logged off, but one or more tasks are not yet completed." & _
                     vbCrLf & vbCrLf & _
                     "If these tasks are automatically terminated, you may lose some work." & _
                     vbCrLf & vbCrLf & _
                     "Do you want to automatically terminate the tasks and log off?", _
                     vbYesNo, "Open Tasks!")
         If userReply = vbYes Then
            For i = 0 To Forms.Count - 1
               If Forms(i).caption <> "Medtech" Then
                  Unload Forms(i)
                  If Forms.Count = 1 Then
                     Exit For
                  End If
                  i = i - 1
               End If
            Next i
            Exit Do
         End If
      Loop

   Loop

End Sub

Public Sub checkForFatalFileError(tableName As String)
'
'     Check to make sure a critical file was opened OK.
'
'     If not, tell the operator and exit the Medtech system.
'     The cause of the error must be diagnosed and corrected.
'
'     Passed: (1) Error Number (0 if no error)
'             (2) Table Name
'

   ' If there was an error, tell the operator and shut down.
   If Err.Number <> 0 Then
      MsgBox "Problem opening """ & tableName & """ file: " & _
             "Error # " & Str(Err.Number) & _
             " was generated by " & Err.Source & vbCrLf & _
             Err.Description, , "Error", Err.HelpFile, Err.HelpContext
      End
   End If

End Sub

Public Sub ColorForm(frm As Form)

   Dim ctl As Control
   Dim framePresent As Boolean

   ' First scan the controls to see if there is a frame,
   ' and color the frame(s) if there are any.
   For Each ctl In frm.Controls
      If TypeOf ctl Is Frame Then
         ctl.BackColor = FrameBackColor
         framePresent = True
      End If
   Next ctl

   ' Now scan to set colors to all controls except frames.
   For Each ctl In frm.Controls
      If TypeOf ctl Is Label Then
         If TypeOf ctl.Container Is Frame Then
            ctl.ForeColor = FrameTextColor
         Else
            If framePresent Then
               ctl.ForeColor = FormTextColor
            Else
               ctl.ForeColor = FrameTextColor
            End If
         End If
      ElseIf TypeOf ctl Is CheckBox Then
         If TypeOf ctl.Container Is Frame Then
            ctl.BackColor = FrameBackColor
         Else
            If framePresent Then
               ctl.BackColor = FormBackColor
            Else
               ctl.BackColor = FrameBackColor
            End If
         End If
      ElseIf TypeOf ctl Is VSFlexGrid Then
         With ctl
            .AllowBigSelection = False
            .AllowSelection = False
            .AllowUserFreezing = False
            .AllowUserResizing = False
            .AutoResize = False
            .AutoSearch = flexSearchNone
            .AutoSizeMode = flexAutoSizeRowHeight
            .AutoSizeMouse = False
            .BackColor = FrameBackColor
            .BackColorBkg = FrameBackColor
            .BackColorFixed = FormBackColor
            .ColWidthMax = 0
            .ColWidthMin = 0
            .ComboSearch = flexCmbSearchAll
            .DataMode = flexDMFree
            .Editable = flexEDKbd
            .Ellipsis = flexNoEllipsis
            .Enabled = True
            .ExplorerBar = flexExNone
            .ExtendLastCol = False
            .FillStyle = flexFillSingle
'           .FixedCols = 1                ' .FixedCols must be set up for each grid.
'           .FixedRows = 1                ' .FixedRows must be set up for each grid.
            .FontBold = True
            .FontName = "MS Sans Serif"
'           .FontSize = 10                ' .FontSize must be set up for each grid.
            .FontUnderline = False
            .ForeColor = FrameTextColor
            .ForeColorFixed = FormTextColor
            .FrozenCols = 0
            .FrozenRows = 0
            .GridColor = vbWhite
            .GridColorFixed = vbWhite
            .SheetBorder = vbWhite
            .MergeCells = flexMergeNever
            .MousePointer = flexDefault
            .OLEDragMode = flexOLEDragManual
            .OLEDropMode = flexOLEDropNone
            .RowHeightMax = 0
            .RowHeightMin = 0
'            .Rows = 4                    ' .Rows must be set up for each grid.
            .ScrollBars = flexScrollBarVertical
            .ScrollTips = False
            .ScrollTrack = False
            .ShowComboButton = True
            .TabBehavior = flexTabCells
            .VirtualData = True
            .WordWrap = True
            .FocusRect = flexFocusHeavy
            .HighLight = flexHighlightNever
            .SelectionMode = flexSelectionFree
         End With
      End If
   Next ctl

   If framePresent Then
      frm.BackColor = FormBackColor
   Else
      frm.BackColor = FrameBackColor
   End If

End Sub

Public Sub ComboBoxDepopulateFromTable(firstComboBoxCodesIndexFromTable)
'
'                           ComboBox Functions
'
'     ComboBoxPopulate: Called when a form is initialized, to populate a
'                       specific combo box on that form with the data from the
'                       MedtechGlobals database file "Lists".
'                       This function is called as many times as there are
'                       combo boxes on the form.
'
'     ComboBoxBindInput: Called after getting an input record, to bind a field
'                        of the input record to a ComboBox. Effectively, binding
'                        "translates" the code in the input record to the equivalent
'                        ComboBox ListIndex, so that the ComboBox displays the
'                        correct value.
'
'
'                  ---How the Combo Box Functions Work---
'
'     1. When the application is initialized in GetCfgParameters in this module,
' the "Lists" table of the "MedtechsGlobal" database is read into the "rstGlobals"
' recordset, which remains persistent in memory as long as the application runs on the
' client. After this has been done, the "rstGlobals" records contain these fields:
'     List = The title of the list, like "MAR" or "SEX"
'     Show = The data that shows in the ComboBox (Example: "Married")
'     Code = The data that is in the record (Example: "M")
'     ComboBoxIndex = Blank on disk, used in the program to record the ListIndex
'                     of this entry in its ComboBox. Not posted until the form
'                     containing the ComboBox for this record is loaded and the
'                     ComboBox is populated.
'     ComboBoxCodesIndex = A kludge, required because Microsoft set up ComboBoxes
'                          with a DataItem which has to be numeric. The codes we
'                          carry on disk are strings. To get around this very
'                          annoying and stupid problem, we set up the ComboBoxCodes
'                          array. This is just an array of strings containing the
'                          Code from "rstGlobals". The ComboBoxCodesIndex field of
'                          "rstGlobals" contains the index to the ComboBoxCodes array
'                          entry for this record.
'
'     2. When a form is initialized, if there are any ComboBoxes on the form, a
' "PopulateAllComboBoxes" Sub is called. It issues one ComboBoxPopulate call for
' each ComboBox on the form, to populate the ComboBoxes with entries to choose from.
' After that's done, we're ready to handle records.
'
'     3. After fetching the record to update, GetComboBox must be called for
' each field of the record which is displayed/maintained via a ComboBox. This
' subroutine finds the "rstGlobals" record for that type of ComboBox and for the
' code that's in the record. It then sets the item to display of the ComboBox as the
' ComboBoxIndex in the "rstGlobals" record. Essentially, it "translates" the code
' in the record to the corresponding ComboBox entry.
'
'     4. After updating all fields of the record, the F12 "Done" command calls an
' "Update" subroutine that "translates" the ComboBox items currently selected to the
' equivalent codes in the record. It does this with a single command. Example:
'  rstThisPatient("Sex") = comboBoxCodes(cmbBasicsSex.ItemData(cmbBasicsSex.ListIndex))
'     The ComboBoxCodes array index was stored as the DataItem for each of the items
' in the ComboBox. This array index is used to fetch the code to be written to the
' output record, from the ComboBox array.
'     Special subroutines (PutComboBox and PutDate) are required to output ComboBox
' codes and dates. See those subroutines in this module.
'
'     5. At run time, each keystroke entered by the user when in a Combo Box is
' passed to the ComboBox_KeyUp function in this module. It handles "Intellisense"-
' type processing, showing the Combo Box entry with the lowest key which matches
' the data keyed so far by the user.
'
'
'               ---ComboBoxDepopulateFromTable Subroutine---
'
'     Get rid of all of the comboBoxCodes array entries, and rstGlobals records,
' which were added via the ComboBoxPopulateFromTable subroutine. A "snapshot" of
' those entries is taken when a form is loaded, then deleted when the form is
' unloaded, so that it stays current.
'
'     Passed: The comboBoxCodes array index before any entries were added
'             via the ComboBoxPopulateFromTable subroutine. This is used
'             to delete the added entries from the comboBoxCodes array.
'

   Dim i As Integer

   ' Delete the comboBoxCodes array entries added via the
   ' ComboBoxPopulateFromTable subroutine.
Dim s0, s1, s2 As String
s0 = comboBoxFromTableMnemonics(0)
s1 = comboBoxFromTableMnemonics(1)
s2 = comboBoxFromTableMnemonics(2)
   comboBoxCodesIndex = firstComboBoxCodesIndexFromTable
   ReDim Preserve comboBoxCodes(comboBoxCodesIndex)

   ' Delete the rstGlobals records added via the ComboBoxPopulateFromTable
   ' subroutine.
   For i = 0 To comboBoxFromTableMnemonicsIndex - 1
      rstGlobals.filter = "List = '" & comboBoxFromTableMnemonics(i) & "'"
      rstGlobals.MoveFirst
      Do Until rstGlobals.EOF
         rstGlobals.Delete
         rstGlobals.MoveNext
      Loop
      rstGlobals.filter = adFilterNone
   Next i
   comboBoxFromTableMnemonicsIndex = 0

End Sub

Public Sub ComboBoxPopulate(cmbBox As ComboBox, list As String)
'
'        Populate a ComboBox with Entries from rstGlobals.
'
'        Passed: (1) The ComboBox object (i.e., "cmbBasicsSex")
'                (2) The List mnemonic (i.e., "SEX")
'
'        When Called: When a form is initialized, if there are ComboBoxes on the form.
'
'        Result: The comboBox is populated with all of the entries in "rstGlobals"
'                for the specified List.
'
   
   Dim comboBoxCodesIndexField As Field
   Dim comboBoxIndexField As Field
   Dim listField As Field
   Dim showField As Field

   Set comboBoxCodesIndexField = rstGlobals("comboBoxCodesIndex")
   Set comboBoxIndexField = rstGlobals("comboBoxIndex")
   Set listField = rstGlobals("List")
   Set showField = rstGlobals("Show")

   If rstGlobals.EOF = True Then
      rstGlobals.MoveFirst
   End If
   rstGlobals.Find "List = '" & list & "'", , , adBookmarkCurrent
   If rstGlobals.EOF = True Then
      rstGlobals.MoveFirst
      rstGlobals.Find "List = '" & list & "'", , , adBookmarkCurrent
   End If

   Do While listField.Value = list
      cmbBox.AddItem showField.Value
      cmbBox.ItemData(cmbBox.ListCount - 1) = comboBoxCodesIndexField.Value
      If comboBoxIndexField.Value = 0 Then
         comboBoxIndexField.Value = cmbBox.ListCount - 1
         rstGlobals.Update
      End If
      rstGlobals.MoveNext
   Loop

End Sub
Public Sub ComboBoxPopulateFromTable(cmbBox As ComboBox, listMnemonic As String, _
                                     tableName As String, indexName As String, _
                                     codeFieldName As String, ParamArray keyFields())
'
'          Populate a ComboBox with the contents of a specified table.
'

   Dim comboBoxIndexField As Field
   Dim i As Integer
   Dim keyElement As String
   Dim keyField As Variant
   Dim rs As New ADODB.Recordset
   Dim show As String

   ' Check to see if this list has already been populated from its table.
   ' If so, use the normal "ComboBoxPopulate" sub.
   For i = 0 To comboBoxFromTableMnemonicsIndex - 1
      If listMnemonic = comboBoxFromTableMnemonics(i) Then
         ComboBoxPopulate cmbBox, listMnemonic
         Exit Sub
      End If
   Next i

   ' "Remember" the mnemonic for these entries.
   ReDim Preserve comboBoxFromTableMnemonics(comboBoxFromTableMnemonicsIndex + 1)
   comboBoxFromTableMnemonics(comboBoxFromTableMnemonicsIndex) = listMnemonic
   comboBoxFromTableMnemonicsIndex = comboBoxFromTableMnemonicsIndex + 1

   ' Open the table for direct access.
   OpenForDirectAccess rs, tableName, indexName
   rs.MoveFirst

   ' Build a ComboBox entry for each record in the table.
   Do Until rs.EOF

       ' Enlarge the array to allow for this new entry.
      ReDim Preserve comboBoxCodes(comboBoxCodesIndex + 1)

      ' Set up to add a new entry to rstGlobals.
      rstGlobals.AddNew
      comboBoxCodes(comboBoxCodesIndex) = rs(codeFieldName)
      rstGlobals("List") = listMnemonic
      Set comboBoxIndexField = rstGlobals("comboBoxIndex")

      ' Concatenate all the key fields into one "Show" field.
      show = ""
      For Each keyField In keyFields
         keyElement = rs(keyField)
         If keyElement <> "" Then
            show = show & keyElement & " "
         End If
      Next keyField
      rstGlobals("Show") = Left(show, Len(show) - 1)

      rstGlobals("Code") = rs(codeFieldName)
      rstGlobals("ComboBoxCodesIndex") = comboBoxCodesIndex
      rstGlobals("ComboBoxIndex") = 0

      cmbBox.AddItem show
      cmbBox.ItemData(cmbBox.ListCount - 1) = comboBoxCodesIndex
      If comboBoxIndexField.Value = 0 Then
         comboBoxIndexField.Value = cmbBox.ListCount - 1
      End If
   
      rstGlobals.Update
      comboBoxCodesIndex = comboBoxCodesIndex + 1

      ' Get the next record from the table.
      rs.MoveNext
   
   Loop

   ' Sort the Globals Recordset by "List" and "Show"
   rstGlobals.Sort = "List, Show"

   rs.Close

End Sub

Public Sub ComboBox_KeyUp(cmbBox As ComboBox, KeyCode As Integer, _
                          Shift As Integer, caseType As Integer)
'
'     Perform "IntelliSense"-type processing of data keyed in Combo Boxes.
'     Show the Combo Box entry with the lowest key which matches the data
'                    keyed so far by the user.
'
'             See "Combo Box Functions" above.
'
'     Passed:  (1) ComboBox object
'              (2) Keystroke from user
'              (3) Alt-Ctrl-Shift flags
'              (4) How to handle case (vbUpperCase or vbProperCase)
'

   ' Ignore Ctrl-Shift Field Navigation commands.
   If (Shift And (vbCtrlMask + vbShiftMask)) = (vbCtrlMask + vbShiftMask) Then
      Exit Sub
   End If

   ' Handle Delete Field function.
   If KeyCode = vbKeyDelete Then
      cmbBoxKeyedSoFar = ""
      cmbBox = ""
      cmbBox.ListIndex = -1
      Exit Sub
   End If

   ' Handle Cursor Left or Backspace function (delete a keyed character).
   If KeyCode = vbKeyLeft Or KeyCode = vbKeyBack Then
      If cmbBoxKeyedSoFar <> "" Then
         cmbBoxKeyedSoFar = Left(cmbBoxKeyedSoFar, Len(cmbBoxKeyedSoFar) - 1)
         cmbBox = cmbBoxKeyedSoFar
         If cmbBoxKeyedSoFar = "" Then
            cmbBox = ""
            Exit Sub
         End If
      End If
   End If

   ' If keystroke not Cursor Left, Backspace, A-Z, or 0-9, ignore it.
   If Not (KeyCode = vbKeyLeft Or _
           KeyCode = vbKeyBack Or _
          (KeyCode >= vbKeyA And KeyCode <= vbKeyZ) Or _
          (KeyCode >= vbKey0 And KeyCode <= vbKey9)) Then
      Exit Sub
   End If

   ' Capitalize the key entered so far, per field specs.
   If Not ((KeyCode = vbKeyLeft) Or (KeyCode = vbKeyBack)) Then
      cmbBoxKeyedSoFar = cmbBoxKeyedSoFar & Chr(KeyCode)
   End If
   cmbBoxKeyedSoFar = StrConv(cmbBoxKeyedSoFar, caseType)
   cmbBox.Text = cmbBoxKeyedSoFar

   ' Search for the key in the ComboBox entries.
   ' If there is no matching entry, back off one character
   ' and re-match if any characters are left.
   ' A match is certain if any characters are left.
   If Not ComboBox_KeyUp_EntryFound(cmbBox, cmbBoxKeyedSoFar) Then
      IgnoreEnter = True
      MsgBox "No entry begins with """ & cmbBoxKeyedSoFar & """"
      cmbBoxKeyedSoFar = Left(cmbBoxKeyedSoFar, Len(cmbBoxKeyedSoFar) - 1)
      If cmbBoxKeyedSoFar <> "" Then
         ComboBox_KeyUp_EntryFound cmbBox, cmbBoxKeyedSoFar
      End If
   End If

   If cmbBoxKeyedSoFar = "" Then
      cmbBox.ListIndex = -1
      cmbBox.Text = ""
   End If

End Sub

Public Function ComboBox_KeyUp_EntryFound(cmbBox As ComboBox, cmbBoxKeyedSoFar As String) As Boolean
'
'     Find the Combo Box entry with the lowest key alphabetically,
'          which matches the data keyed so far by the user.
'
'           Function called only by ComboBox_KeyUp
'
'             See "Combo Box Functions" above.
'
'     Passed:  (1) ComboBox object
'              (2) String entered so far by the user
'
'     Returned: True if a matching Combo Box entry is found
'               False if no matching Combo Box entry is found
'

   Dim i As Integer
   Dim j As Integer

   ComboBox_KeyUp_EntryFound = False

   For i = 0 To cmbBox.ListCount - 1
      If cmbBoxKeyedSoFar = Left(cmbBox.list(i), Len(cmbBoxKeyedSoFar)) Then
     
         ' An entry has been found. Display it.
         cmbBox.ListIndex = i
         cmbBox.Text = cmbBox.list(i)
         ComboBox_KeyUp_EntryFound = True
         
         ' The following little routine does what these lines should do:
         ' cmbBox.SelStart = Len(cmbBoxKeyedSoFar)
         ' cmbBox.SelLength = Len(cmbBox.List(i)) - Len(cmbBoxKeyedSoFar)
         ' The routine selects the implied data (following the characters keyed so far)
         ' and leaves the data actually keyed un-selected.
         SendKeys ("{HOME}")
         Do Until j = Len(cmbBoxKeyedSoFar)
            SendKeys ("{RIGHT}")
            j = j + 1
         Loop
         SendKeys ("+{END}")
         Exit For
      End If
   Next i

End Function

Public Function ConvertFromSpecialHexStringToLong(hexString As String) As Long
'
' This function converts an abbreviated 3-byte string to a corresponding binary number.
'
'     Passed: 3-byte hexadecimal string, in which each byte is translated
'             to a corresponding byte by this rule:
'              ---Input Byte---  ---Output Byte---
'                 0-9               Hex x0, where x has the binary value of 0-9
'                 A-E               Hex x0, where x has the binary value of 10-14
'                 F                 Hex FF
'
'     The high order byte of the 4-byte number is always zero.
'

   Dim digit As Integer
   Dim i As Integer
   Dim inputByte As String
   Dim result As Long

   ' Convert the 3-byte hex string to a long.
   For i = 1 To 3
      result = result * 256
      inputByte = Mid(hexString, i, 1)
      digit = Asc(inputByte)
      digit = digit - 48
      If digit > 9 Then
         digit = digit - 17 + 10
      End If
      If digit = 15 Then
         result = result + 255
      Else
         result = result + (digit * 16)
      End If
   Next i
   ConvertFromSpecialHexStringToLong = result

End Function

Private Sub GetCfgBooleanParameter(header As String, globalBooleanParameter As Boolean)
'
'       Get a single Boolean ("Y" or "N") Medtech.cfg parameter.
'
'              Called only by GetCfgParameters
'
'     Passed: (1) Header string (for example, "IDs")
'             (2) Where to store the global Boolean variable (for example, UserIDsRequired)
'

   Dim parameter As String

   parameter = GetCfgStringParameter(header)
   parameter = UCase(parameter)
   If parameter = "Y" Then
      globalBooleanParameter = True
   ElseIf parameter = "N" Then
      globalBooleanParameter = False
   Else
      MsgBox "Medtech.cfg file invalid" & vbCrLf & vbCrLf & _
             "Line should end with ""=Y"" or ""=N"", but doesn't." & vbCrLf & vbCrLf & _
             "Line = " & parameter & vbCrLf & vbCrLf & _
             "Please correct Medtech.cfg and try again."
      End
   End If

End Sub

Private Sub GetCfgColorParameter(header As String, globalColorParameter As Long)
'
'       Get a single Boolean ("Y" or "N") Medtech.cfg parameter.
'
'              Called only by GetCfgParameters
'
'     Passed: (1) Header string (for example, "IDs")
'             (2) Field from Medtech.cfg (for example, "IDs=Y")
'

   Dim parameter As String

   parameter = GetCfgStringParameter(header)
   parameter = UCase(parameter)
   rstGlobals.filter = "List = 'COL' AND Show = '" & parameter & "'"
   If rstGlobals.RecordCount <> 1 Then
      MsgBox "Medtech.cfg file invalid" & vbCrLf & vbCrLf & _
             "Color specified is not in the standard list." & vbCrLf & vbCrLf & _
             "Standard list = Black, Cyan, Dark Blue, Green, Light Blue, Magenta, Red, White, Yellow" & _
             vbCrLf & vbCrLf & "Invalid line:  " & header & parameter & vbCrLf & vbCrLf & _
             "Please correct Medtech.cfg and try again."
      End
   End If
   globalColorParameter = ConvertFromSpecialHexStringToLong(rstGlobals("Code"))
   rstGlobals.filter = adFilterNone

End Sub

Private Sub GetCfgNoIDs()
'
'     When Medtech.cfg specifies that ID's are not required,
'     this function arbitrarily selects as the current user
'     the first user in "Users" who is a System Administrator.
'

   Dim rstUsers As New ADODB.Recordset

   ' Find the first System Administrator in the Users file,
   ' and use this user as the current user.
   On Error Resume Next   ' Defer error handling.
   Err.Clear
   rstUsers.ActiveConnection = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
                               "Data Source=" & MedtechServerPath & _
                               "\MedtechGlobals.mdb"
   rstUsers.Source = "SELECT * FROM Users WHERE SysAdmin = True"
   rstUsers.CursorLocation = adUseClient
   rstUsers.Open , , adOpenStatic, adLockOptimistic
   checkForFatalFileError "Users"
   If rstUsers.RecordCount = 0 Then
      MsgBox "There must be at least one System Administrator in the User file," & vbCrLf & _
             "but there isn't. Please correct and log on again."
      End
   Else
      SetUser rstUsers
   End If
   rstUsers.Close

End Sub

Private Sub GetCfgParameters()
'
'     Application Initialization: Read the configuration file "Medtech.cfg",
'                                 resident wherever the Medtech software is.
'
'     "Medtech.cfg" contains the following program-configuring lines:
'     (1) "IDs=Y" or "IDs=N" to indicate whether ID's are required.
'     (2) "PWs=Y" or "PWs=N" to indicate whether Passwords are required.
'     (3) "Server Path=" Full path to the global Medtech database on the server
'
'                   Sample Contents of Medtech.cfg:
'
'                             IDs=Y
'                             PWs=N
'                             Server Path=T:\Medtech
'
'     *Notes:
'        (1) IDs are normally required, but for system debugging purposes, it's
'            a nuisance to continually input ID's. The "IDs=" parameter permits
'            the Login screen to be bypassed altogether.
'        (2) Similarly, Passwords are normally required, but if the client
'            feels no need for system security, Passwords will not be prompted for.
'        (3) If there is no network, only a single computer, the "Server Path="
'            parameter would normally be "Server Path=C:\Medtech".
'

   On Error GoTo ErrorHandler
   Open "Medtech.cfg" For Input As #1
   GetCfgBooleanParameter "IDs=", UserIDsRequired
   GetCfgBooleanParameter "PWs=", UserPWsRequired
   MedtechServerPath = GetCfgStringParameter("Server Path=")
   GetGlobalParameters
   GetCfgColorParameter "FormBackColor=", FormBackColor
   DefaultFormBackColor = FormBackColor
   GetCfgColorParameter "FormTextColor=", FormTextColor
   DefaultFormTextColor = FormTextColor
   GetCfgColorParameter "FrameBackColor=", FrameBackColor
   DefaultFrameBackColor = FrameBackColor
   GetCfgColorParameter "FrameTextColor=", FrameTextColor
   DefaultFrameTextColor = FrameTextColor
   Close #1
   If Not UserIDsRequired Then
      GetCfgNoIDs
   End If
   Exit Sub
   
ErrorHandler:  MsgBox "The file """ & App.Path & "\Medtech.cfg"" doesn't exist." & _
                      vbCrLf & vbCrLf & _
                      "It should contain parameter lines. The last line should be the full path" & vbCrLf & _
                      "to the directory which contains the ""MedtechGlobals"" database." & _
                      vbCrLf & vbCrLf & _
                      "The line should normally be: ""Server Directory = (Server Drive Letter):\Medtech""" & _
                      vbCrLf + vbCrLf & _
                      "Please create this file and try again."
               End

End Sub

Private Function GetCfgStringParameter(header As String) As String
'
'            Get a single String Medtech.cfg parameter.
'
'              Called only by GetCfgParameters
'
'     Passed: (1) Header string (for example, "Server Path")
'             (2) Where to store the global String variable (for example, MedtechServerPath)
'

   Dim byteNo As Integer
   Dim cfgLine As String

   Input #1, cfgLine
   byteNo = InStr(cfgLine, header)
   If byteNo <> 1 Then
      MsgBox "Medtech.cfg file invalid" & vbCrLf & vbCrLf & _
             "Line should begin with " & header & vbCrLf & vbCrLf & _
             "Actual line: " & cfgLine & vbCrLf & vbCrLf & _
             "Please correct Medtech.cfg and try again."
      End
   End If
   GetCfgStringParameter = Mid(cfgLine, Len(header) + 1)

End Function

Public Sub GetCheckBox(chkBox As CheckBox, checkBoxValue As Boolean)
'
'     This function is used when a data record is read from disk.
'  It sets the CheckBox control to correspond to the data record field.
'
'     Passed: (1) CheckBox object
'             (2) Field from data record
'

   If checkBoxValue = True Then
      chkBox.Value = vbChecked
   Else
      chkBox.Value = vbUnchecked
   End If
End Sub

Public Sub GetComboBox(cmbBox As ComboBox, list As String, Code As Variant)
'
'  "Translate" the code in a data record field to the displayable text.
'  Set the ListIndex of the ComboBox, which forces the display of text.
'
'             See "Combo Box Functions" above.
'
'     Passed:  (1) ComboBox object
'              (2) Which "List" the Combo Box is for (i.e., "MAR" or "STA")
'              (3) The code contained in the data record field
'
   If Code = "" Or Code = 0 Then
      cmbBox = ""
      cmbBox.ListIndex = -1
   Else
      rstGlobals.filter = "List = '" & list & "' AND Code = '" & Code & "'"
      cmbBox.ListIndex = rstGlobals("comboBoxIndex")
      rstGlobals.filter = adFilterNone
   End If
End Sub

Public Sub GetDate(txtBox As TextBox, databaseDate As String)
'
'     This function is used when a data record is read from disk.
'  It sets a TextBox control to correspond to the data record field.
'
'     Passed: (1) TextBox object
'             (2) Date field from data record
'

 If IsDate(databaseDate) Then
    txtBox = databaseDate
 Else
    txtBox = ""
 End If

End Sub

Private Sub GetGlobalParameters()
'
'     This function gets all of the global parameters used in
'     drop-down lists from the "Lists" file of "MedtechGlobals.mdb".
'     We have to wait until the MedtechServerPath variable has been read
'     from "Medtech.cfg", since that's where "MedtechGlobals.mdb" is.
'

   rstGlobals.ActiveConnection = _
        "Provider=Microsoft.Jet.OLEDB.4.0;" _
      & "Data Source=" & MedtechServerPath & "\MedtechGlobals.mdb"
   rstGlobals.Source = "SELECT * FROM Lists ORDER BY List, Show"
   rstGlobals.CursorLocation = adUseClient
   rstGlobals.Open , , adOpenStatic, adLockOptimistic
   rstGlobals.ActiveConnection = Nothing

   Do While Not rstGlobals.EOF
      ReDim Preserve comboBoxCodes(comboBoxCodesIndex + 1)
      comboBoxCodes(comboBoxCodesIndex) = rstGlobals("Code")
      rstGlobals("ComboBoxCodesIndex") = comboBoxCodesIndex
      rstGlobals("ComboBoxIndex") = 0
      rstGlobals.Update
      comboBoxCodesIndex = comboBoxCodesIndex + 1
      rstGlobals.MoveNext
   Loop

End Sub

Public Sub LoadNewForm(frmForm As Form, caption As String, requiredPrivilege As Integer)
'
'                Load (but don't show) a new form.
'
' This special version of "ShowNewForm" is used when data must be passed to the new form.
'
'     Passed: (1) Form object
'             (2) Caption to display at the top of this form
'             (3) Privilege Level required to call this form
'                 0 (False) = Calling this form is illegal.
'                 1         = Only a System Administrator can call this form.
'                 -1 (True) = It's legal for this user to call this form.
'
' ---Proper Calling Sequence---             ---Example of Call---
' Dim frmNewForm As New frmTemplate         Dim frmPractices As New frmMedtechPractices
' LoadNewForm frmNewForm, "Caption", 1      LoadNewForm frmPractices, "Pract.Search", 1
' frmNewForm.Sub Parameters...              frmNewForm.Sub Parameters...
' frmNewForm.show                           frmNewForm.show
'

   If UserPrivSysAdmin Or UserPrivPracticeAdmin Then
      GoTo AccessGranted
   End If
   
   If requiredPrivilege = 1 Then
      MsgBox "Sorry, but only System Administrators may update this file."
      Exit Sub
   ElseIf requiredPrivilege = 0 Then
      MsgBox "Sorry, but you have not been granted this privilege." & _
             vbCrLf & vbCrLf & "Please refer this matter to your System Administrator."
      Exit Sub
   End If

AccessGranted:
   frmForm.caption = caption
   frmForm.Left = CHILD_FORM_LEFT
   frmForm.Top = CHILD_FORM_TOP
   frmForm.Height = CHILD_FORM_HEIGHT
   frmForm.width = CHILD_FORM_WIDTH
   Load frmForm

End Sub

Public Sub OpenForDirectAccess(rs As Recordset, tableName As String, indexName As String)

   ' Try to open the specified file, fault if it can't be done.
   On Error Resume Next
   Err.Clear
   rs.ActiveConnection = _
      "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & MedtechPracticePath & "\Medtech.mdb"
   rs.Source = tableName
   rs.CursorLocation = adUseServer
   rs.LockType = adLockOptimistic
   rs.Open Options:=adCmdTableDirect
   rs.Index = indexName
   checkForFatalFileError tableName

End Sub

Public Sub OpenForDirectAccessGlobal(rs As Recordset, tableName As String, indexName As String)

   ' Try to open the specified file, fault if it can't be done.
   On Error Resume Next
   Err.Clear
   rs.ActiveConnection = _
      "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & MedtechServerPath & "\MedtechGlobals.mdb"
   rs.Source = tableName
   rs.CursorLocation = adUseServer
   rs.LockType = adLockOptimistic
   rs.Open Options:=adCmdTableDirect
   If indexName <> "" Then
      rs.Index = indexName
   End If
   checkForFatalFileError tableName

End Sub

Public Sub OpenGlobalFile(tableName As String, whereClause As String, _
                          Optional NoRecordsOK As Boolean = False)
'
'   Open a Recordset of records from a table in MedtechGlobals.mdb.
'
'     Passed: (1) Table Name (for example, "Practices")
'             (2) Where clause (for example, "WHERE PracticeNo = " & PracticeNo)
'             (3) "No Records OK" Flag
'

   ' Try to open the specified file, fault if it can't be done.
   On Error Resume Next
   Err.Clear
   rstGlobalFile.ActiveConnection = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
                                    "Data Source=" & MedtechServerPath & _
                                    "\MedtechGlobals.mdb"
   rstGlobalFile.Source = "SELECT * FROM  " & tableName & " " & whereClause
   rstGlobalFile.CursorLocation = adUseClient
   rstGlobalFile.Open , , adOpenStatic, adLockOptimistic
   checkForFatalFileError tableName

   ' Make sure there's at least one record in the resulting recordset,
   ' unless "NoRecordsOK" parameter specified in the call.
   If rstGlobalFile.RecordCount = 0 And Not NoRecordsOK Then
      MsgBox "Problem opening """ & tableName & """ file " & vbCrLf & vbCrLf & _
             "There are no records which meet the following criteria:" & vbCrLf & vbCrLf & _
             whereClause
      End
   End If

End Sub

Public Sub PutComboBox(databaseField As Variant, cmbBox As ComboBox)
'
'          "Translate" the displayable text in a Combo Box
'        to the code to be written as the data record field.
'
'             See "Combo Box Functions" above.
'
'             Passed:  (1) Database field object
'                      (2) ComboBox object
'

   If cmbBox.Text = "" Then
      databaseField = ""
   Else
      databaseField = comboBoxCodes(cmbBox.ItemData(cmbBox.ListIndex))
   End If

End Sub

Public Sub PutComboBoxNumeric(databaseField As Field, cmbBox As ComboBox)
'
'          "Translate" the displayable text in a Combo Box
'        to the code to be written as the data record field.
'
'             See "Combo Box Functions" above.
'
'             Passed:  (1) Database field object
'                      (2) ComboBox object
'

   If cmbBox.Text = "" Then
      databaseField = 0
   Else
      databaseField = comboBoxCodes(cmbBox.ItemData(cmbBox.ListIndex))
   End If

End Sub

Public Sub PutDate(dateField As Field, dateToOutput As String)
'
'     Output the ASCII date in a TextBox as a data record field.
'             See "Combo Box Functions" above.
'
'     This subroutine is called in the "Record Update" function.
'
'             Passed:  (1) Database date field object
'                      (2) Date to output (string)
'
 
 If IsDate(dateToOutput) Then
    dateField = dateToOutput
 Else
    dateField = Null
 End If

End Sub

Public Sub SetColors()

   If UserFormTextColor = -1 Then
      OpenForDirectAccessGlobal rstCfg, "Cfg", ""
      rstCfg.MoveFirst
      FormBackColor = rstCfg("FormBackColor")
      FormTextColor = rstCfg("FormTextColor")
      FrameBackColor = rstCfg("FrameBackColor")
      FrameTextColor = rstCfg("FrameTextColor")
      rstCfg.Close
   Else
      FormBackColor = UserFormBackColor
      FormTextColor = UserFormTextColor
      FrameBackColor = UserFrameBackColor
      FrameTextColor = UserFrameTextColor
   End If

End Sub

Public Sub SetPractice(practiceNumber As Long)
'
'     Set up to process a specifified practice.
'
'     Passed: Practice Number
'

   PracticeNo = practiceNumber
   OpenGlobalFile "Practices", "WHERE PracticeNo = " & PracticeNo
   PracticeName = rstGlobalFile("PracticeName")
   PracticeContact = rstGlobalFile("Contact")
   PracticePhone = rstGlobalFile("Phone")
   MedtechPracticePath = rstGlobalFile("DBDirectory")
   rstGlobalFile.Close
   
   OpenGlobalFile "UserPractices", "WHERE UserNo = " & UserNo & _
                  " And PracticeNo = " & PracticeNo

   If Not rstGlobalFile("Access") Then
      MsgBox "Access not granted to this practice: " & PracticeName
      End
   End If
   If UserPrivSysAdmin Or rstGlobalFile("Admin") Then
      UserPrivPracticeAdmin = True
      UserPrivCharges = "U"
      UserPrivLedger = "U"
      UserPrivMasterFiles = "U"
      UserPrivPatient = "U"
      UserPrivPayments = "U"
      UserPrivReports = "U"
   Else
      UserPrivPracticeAdmin = False
      UserPrivCharges = rstGlobalFile("Charges")
      UserPrivLedger = rstGlobalFile("Ledger")
      UserPrivMasterFiles = rstGlobalFile("Files")
      UserPrivPatient = rstGlobalFile("Patient")
      UserPrivPayments = rstGlobalFile("Payments")
      UserPrivReports = rstGlobalFile("Reports")
   End If
   rstGlobalFile.Close

End Sub

Public Sub SetUser(rstUser As ADODB.Recordset)
'
'     Store the Privileges and all other data related
'          user who has just logged on.
'
'     Passed: Recordset of a single record, the new user.
'

   UserNameFirst = rstUser("NameFirst")
   UserNameLast = rstUser("NameLast")
   UserNo = rstUser("UserNo")
   UserFormBackColor = rstUser("FormBackColor")
   UserFormTextColor = rstUser("FormTextColor")
   UserFrameBackColor = rstUser("FrameBackColor")
   UserFrameTextColor = rstUser("FrameTextColor")
   SetColors
   UserPrivDefaultPatient = rstUser("Patient")
   UserPrivDefaultCharges = rstUser("Charges")
   UserPrivDefaultPayments = rstUser("Payments")
   UserPrivDefaultLedger = rstUser("Ledger")
   UserPrivDefaultMasterFiles = rstUser("Files")
   UserPrivDefaultReports = rstUser("Reports")
   UserPrivSysAdmin = rstUser("SysAdmin")
   If UserPrivSysAdmin Then
      UserPrivDefaultPatient = "U"
      UserPrivDefaultCharges = "U"
      UserPrivDefaultPayments = "U"
      UserPrivDefaultLedger = "U"
      UserPrivDefaultMasterFiles = "U"
      UserPrivDefaultReports = "U"
   End If

End Sub

Public Sub ShowNewForm(frmForm As Form, caption As String, requiredPrivilege As Integer)
'
'                      Show a new form.
'
'     Passed: (1) Form template (class)
'             (2) Caption to display at the top of this form
'             (3) Privilege Level required to call this form
'                 0 (False) = Calling this form is illegal.
'                 1         = Only a System Administrator can call this form.
'                 -1 (True) = It's legal for this user to call this form.
'
' ---Proper Calling Sequence---             ---Example of Call---
' Dim frmNewForm As New frmTemplate         Dim frmPractices As New frmMedtechPractices
' ShowNewForm frmNewForm, "Caption", 1      ShowNewForm frmPractices, "Pract.Search", 1
'

   If UserPrivSysAdmin Or UserPrivPracticeAdmin Then
      GoTo AccessGranted
   End If
   
   If requiredPrivilege = 1 Then
      MsgBox "Sorry, but only System Administrators may update this file."
      Exit Sub
   ElseIf requiredPrivilege = 0 Then
      MsgBox "Sorry, but you have not been granted this privilege." & _
             vbCrLf & vbCrLf & "Please refer this matter to your System Administrator."
      Exit Sub
   End If

AccessGranted:
   frmForm.caption = caption
   frmForm.Left = CHILD_FORM_LEFT
   frmForm.Top = CHILD_FORM_TOP
   frmForm.Height = CHILD_FORM_HEIGHT
   frmForm.width = CHILD_FORM_WIDTH
   frmForm.show
   
   If requiredPrivilege = -2 Then
      WaitForLogOff
   End If

End Sub

Public Function tlgGetCheckBox(databaseCheckBox As Boolean) As Integer

   If databaseCheckBox = False Then
      tlgGetCheckBox = 0
   Else
      tlgGetCheckBox = 1
   End If

End Function

Public Sub tlgInitCheckBox(tlg As TList, column As Integer, _
                            heading As String, width As Integer)

   With tlg.Grid

      .Cells(0, column).Value = heading
      .ColDefs(column).width = width
      .ColDefs(column).CellDef.EditInfo.Editable = TLEDITABLE_ALWAYS_ONCLICK
      .ColDefs(column).CellDef.EditInfo.Style = TLEDITINFO_CHECKBOX
   
   End With

End Sub

Public Sub tlgInitComboBox(tlg As TList, column As Integer, _
                            heading As String, width As Integer)

   With tlg.Grid

      .Cells(0, column).Value = heading
      .ColDefs(column).width = width
      .ColDefs(column).CellDef.EditInfo.Editable = TLEDITABLE_ALWAYS_ONCLICK
      .ColDefs(column).CellDef.EditInfo.Style = TLEDITINFO_COMBOBOX
      .ColDefs(column).CellDef.BackColor = RGB(0, 0, 255)
     
      With .ColDefs(column).CellDef.EditInfo.ComboBox.Items
         
         .Add "N"
         .Add "R"
         .Add "U"
     
      End With

   End With

End Sub

Public Sub tlgInitTextBox(tlg As TList, column As Integer, _
                           heading As String, width As Integer)

   With tlg.Grid

      .Cells(0, column).Value = heading
      .ColDefs(column).width = width
      .ColDefs(column).CellDef.EditInfo.Editable = TLEDITABLE_ALWAYS_ONCLICK
      .ColDefs(column).CellDef.EditInfo.Style = TLEDITINFO_TEXTBOX
   
   End With

End Sub

Public Sub WaitForLogOff()

   Dim i As Integer

   Do
      DoEvents
      For i = 0 To Forms.Count - 1
         If Left(Forms(i).caption, 7) = "Welcome" Then
            i = -1
            Exit For
         End If
      Next i
      If i <> -1 Then
         Exit Do
      End If
   Loop

End Sub
0
 

Author Comment

by:GebhartBob
Comment Utility
Guys and gals---

     This exercise will be worthwhile, at least for me, because it will teach me what matters and what doesn't. Thanks very much for your kindness and your interest.

     You asked for the code, and I sent it. Heh, heh, heh.

---Bob
0
 
LVL 12

Expert Comment

by:roverm
Comment Utility
.....Wow !
0
 
LVL 7

Expert Comment

by:Vbmaster
Comment Utility
The best way to find out what matters is putting some additional code into the Form_initialize event, something like this..

  Dim OldTimer As Single

  OldTimer = Timer()
    FramesKludge
  Me.Caption = Timer() - OldTimer
  Stop

  OldTimer = Timer()
    ColorForm Me
  Me.Caption = Timer() - OldTimer
  Stop

Now this will run the code just as before but will stop after any action is run, when the first part of the code is done, the 2nd and so on. Have a paper and pen ready to record the values stored in the caption bar. Now you see what parts takes time to run, and you also know which parts is fast enough. This will ensure you focus on the right parts, no need to speed things up that already is lightning fast.

If possible you should use something else than a database, as they are very slow to initialize. Doing a custom database would probably allow you to load the form instantly but then again you are perhaps dependant on 3rd party database.
0
 
LVL 9

Expert Comment

by:Valliappan AN
Comment Utility
:) I mentioned that if your code is big, you could mail me.

ok, fine. I feel that your way of accessing recordset, might make it slower. Also, may be it is in the Coloring or frame setting part, as VbMaster pointed out.

Look at this: (ComboPopulating procedure code)

  Dim comboBoxCodesIndexField As Field
  Dim comboBoxIndexField As Field
  Dim listField As Field
  Dim showField As Field

  Set comboBoxCodesIndexField = rstGlobals("comboBoxCodesIndex")
  Set comboBoxIndexField = rstGlobals("comboBoxIndex")
  Set listField = rstGlobals("List")
  Set showField = rstGlobals("Show")

  If rstGlobals.EOF = True Then
     rstGlobals.MoveFirst
  End If
  rstGlobals.Find "List = '" & list & "'", , , adBookmarkCurrent
  If rstGlobals.EOF = True Then
     rstGlobals.MoveFirst
     rstGlobals.Find "List = '" & list & "'", , , adBookmarkCurrent
  End If

  Do While listField.Value = list
     cmbBox.AddItem showField.Value
     cmbBox.ItemData(cmbBox.ListCount - 1) = comboBoxCodesIndexField.Value
     If comboBoxIndexField.Value = 0 Then
        comboBoxIndexField.Value = cmbBox.ListCount - 1
        rstGlobals.Update
     End If
     rstGlobals.MoveNext
  Loop

You can try changing it as follows. : (and check how it is)
  Dim comboBoxCodesIndexField As Field
  Dim comboBoxIndexField As Field
  Dim listField As Field
  Dim showField As Field

  Set comboBoxCodesIndexField = rstGlobals("comboBoxCodesIndex")
  Set comboBoxIndexField = rstGlobals("comboBoxIndex")
  Set listField = rstGlobals("List")
  Set showField = rstGlobals("Show")

  'COMMENT: the Find statements were executed twice, and no need
  'to check for EOF, since MoveFirst can be used
  'before Find.
  rstGlobals.MoveFirst
  rstGlobals.Find "List = '" & list & "'"

  Do While listField.Value = list
     cmbBox.AddItem showField.Value
     cmbBox.ItemData(cmbBox.ListCount - 1) = comboBoxCodesIndexField.Value
     If comboBoxIndexField.Value = 0 Then
        comboBoxIndexField.Value = cmbBox.ListCount - 1
        rstGlobals.Update  'COMMENT: why do you update the recordset here?
     End If
     rstGlobals.MoveNext
  Loop

--------

Also, I would suggest you use disconnected recordset,  if your settings won't change in run-time in the Globals table.

Also, check if you could use a WHERE condition instead of FIND, since I think it is faster. Use a temp. recordset, and open it with a WHERE condition, then you don't need a MoveFirst, Find etc.

Hope it helps.
0
 
LVL 22

Expert Comment

by:rspahitz
Comment Utility
I didn't really look through the code yet, but have some questions, which may lead you in a new direction to solve the problem:

1) Why do your users keep closing the app?  Is it because they don't need it?  Then why do they keep re-opening it?  Maybe this is more of a training issue: don't close things that you need because it takes time to re-open (kinda like: don't go to the store for milk, come home, then go back for bread, come home, then go back for meat!)

2a) Does the form_load process require having everything pre-loaded?  Maybe you need some sort of splash screen to load up so the users can quickly exit instead of waiting for everything to load.

2b) If what the users need is only a small piece of the load, maybe you could delay the load until it's needed.  For example, don't load report drivers unless the user intends to generate a report.  Similarly, don't read tons of records that the users don't need.

2z) Do some statistical research of your users to find out what data is most likely to be used, and only load that up front.

3) If the users only use one aspect of your app each time they start it up, maybe it should be broken into separate apps.  For example, if you have an app like MS Outlook, it has to load e-mail stuff, calendar stuff, scheduling stuff, etc, and takes a long time to do so.  If all that's needed is the calendar, they might be better off having a separate app to display the calendar only.  You could even make a "menu" app that gives them the options, then call the desired app and unloads itself.
0
 

Author Comment

by:GebhartBob
Comment Utility
Replies to questions from rspahitz:

1) Why do your users keep closing the app?  Is it because they don't need it?  Then why do they keep
re-opening it?  Maybe this is more of a training issue: don't close things that you need because it
takes time to re-open (kinda like: don't go to the store for milk, come home, then go back for bread,
come home, then go back for meat!)
     Answer: This is an MDI application, like MS Word. The user might be recording payments, and need to display the data concerning a particular patient. From the Payments screen (an MDI child), she invokes the Patient screen (also an MDI child). While she's looking at that data, the phone rings. A different patient has a question, so the user brings up another Patient screen, leaving the other two still open.
     I haven't yet thought through the idea of always keeping one or more instances of the commonly-used screens loaded,  but hidden when not in use. That is probably the best idea of all. Up front, after the user logs in, you load at least one copy of each common form, showing a Splash form to keep the user happy. After that, access ought to be virtually instantaneous. There are some problems with the idea, mainly how to handle multiple instances of a form, but it ought to work, I think.

2a) Does the form_load process require having everything pre-loaded?  Maybe you need some sort of splash
screen to load up so the users can quickly exit instead of waiting for everything to load.
     Answer: See my answer to 2b) below.

2b) If what the users need is only a small piece of the load, maybe you could delay the load until it's
needed.  For example, don't load report drivers unless the user intends to generate a report.  Similarly,
don't read tons of records that the users don't need.
     Answer: I play a few games like that. The Patient form has an SSTab control, and I paint the data on the various tabs only when the tab is displayed, not at Form_Load time. It doesn't help much.

2z) Do some statistical research of your users to find out what data is most likely to be used, and
only load that up front.
     Answer: I'm not loading large amounts of data, only a very few records. I changed from a SQL approach to one using Seek commands, and that improved performance radically after the form is loaded. But it made no difference at all to form load time.
     One thing is possible: I do open 5 or 6 files for direct access via Seeks when the form is loaded. It might take a while to do that. I'll check it. I don't know what I can do about it if open time is a problem, but I'll find out anyway.

3) If the users only use one aspect of your app each time they start it up, maybe it should be broken
into separate apps.  For example, if you have an app like MS Outlook, it has to load e-mail stuff, calendar
stuff, scheduling stuff, etc, and takes a long time to do so.  If all that's needed is the calendar,
they might be better off having a separate app to display the calendar only.  You could even make a
"menu" app that gives them the options, then call the desired app and unloads itself.
     Answer: That's an interesting point, and one I thought about during initial design. I can't see how it could take any longer, though, to load an MDI child form than to call the same form as a separate application. Do you agree? What I have now is one humongous application, with maybe 30 MDI child forms, loaded as needed.

     Thanks very much for your thoughts.
0
 
LVL 22

Expert Comment

by:rspahitz
Comment Utility
"What I have now is one humongous application"

Although that's not usually a big issue anymore (the new Win versions are much better at memory management) if the systems are slow or short on memory, that could impact the processing.  Win95/98/ME haev known memory leak problems and everytime they open close an app, they have less memory for next time, which means the system will start jumping to virtual (aka disk-based) memory, which is about 300x slower (or something like that.)

By using only small apps, the opportunity for memory leaks causing problems is reduced.

--
Just looked at the code--mostly looks pretty good (great compared to much of the cr*p I've seen in my career!)

I see that FramesKludge is setting a lot of frames, which means that there must be a lot of frames on the form.  This leads me to wonder if a gui redesign might be in order.

One problem I had on past projects is that the front-end was a rewrite of an old DOS-type data-entry form, and people didn't want to accept new gui designs, even when it made jobs easier.  This may be one of those cases where it may be more efficient to split that monster of a screen into multiple screens accessed with a defaulted OK button (and a [Back] button as needed.)  If they need to see all info in one place, a report (or "print preview") might be appropriate.

--
Beyond that, I'd personally follow Vbmaster's suggestion and find out where the slowdown is occurring, then concentrate on those areas first.  In some cases you'll find that there's one or two trouble spots, and then you can ask for a better way to handle them.
0
 

Author Comment

by:GebhartBob
Comment Utility
    Several excellent ideas were offered on this question, and I experimented with all of them. Nothing made much difference except VBMaster's suggestion of hiding the form rather than unloading it. No matter how complicated the form might be, if it's hidden and then made visible later, the form pops up virtually instantly, precisely what we want.
     "Pools" of available but hidden forms will have to be establishd, one pool for each common type of form. When a form is needed, a procedure will assign one. If none is available, then there will be a slowdown while a new one is created, so it's important to make the pools big enough.
     There are some initialization problems when re-activating a previously-hidden form, but nothing that can't be handled.
     Understand, we have by no means written all of this software yet, but now we know what should be written, and that's half the battle.
     I don't think memory will be a problem. Each copy of our most complex form takes about 2MB, so if we allow for a total of, say, 10 copies of the various forms, that's just 20MB, not a problem. We control the hardware at all of the installations which will install this system, and RAM is dirt cheap nowadays.
     Thanks, everybody, for the great ideas. And thanks especially to VBMaster for an idea that's a real winner!
0

Featured Post

How to improve team productivity

Quip adds documents, spreadsheets, and tasklists to your Slack experience
- Elevate ideas to Quip docs
- Share Quip docs in Slack
- Get notified of changes to your docs
- Available on iOS/Android/Desktop/Web
- Online/Offline

Join & Write a Comment

Suggested Solutions

Introduction I needed to skip over some file processing within a For...Next loop in some old production code and wished that VB (classic) had a statement that would drop down to the end of the current iteration, bypassing the statements that were c…
Have you ever wanted to restrict the users input in a textbox to numbers, and while doing that make sure that they can't 'cheat' by pasting in non-numeric text? Of course you can do that with code you write yourself but it's tedious and error-prone …
Get people started with the utilization of class modules. Class modules can be a powerful tool in Microsoft Access. They allow you to create self-contained objects that encapsulate functionality. They can easily hide the complexity of a process from…
Show developers how to use a criteria form to limit the data that appears on an Access report. It is a common requirement that users can specify the criteria for a report at runtime. The easiest way to accomplish this is using a criteria form that a…

771 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

12 Experts available now in Live!

Get 1:1 Help Now