Master 95 #1/MASTER95_1.iso/microsof/vbasic4/vb4-6.cab/dataform.frm

Visual Basic Form | 1995-07-26 | 29.6 KB | 904 lines

VERSION 4.00
Begin VB.Form frmDataControl
   ClientHeight    =   2160
   ClientLeft      =   4155
   ClientTop       =   2250
   ClientWidth     =   5670
   Height          =   2565
   HelpContextID   =   2016122
   Icon            =   "DATAFORM.frx":0000
   Left            =   4095
   LinkTopic       =   "Form2"
   LockControls    =   -1  'True
   MDIChild        =   -1  'True
   ScaleHeight     =   2160
   ScaleWidth      =   5670
   Tag             =   "Recordset"
   Top             =   1905
   Width           =   5790
   Begin VB.PictureBox picButtons
      Align           =   1  'Align Top
      Appearance      =   0  'Flat
      BorderStyle     =   0  'None
      ForeColor       =   &H80000008&
      Height          =   600
      Left            =   0
      ScaleHeight     =   600
      ScaleWidth      =   5670
      TabIndex        =   0
      Top             =   0
      Width           =   5670
      Begin VB.CommandButton cmdCancelAdd
         Caption         =   "C&ancel"
         Height          =   330
         Left            =   0
         TabIndex        =   13
         Top             =   0
         Visible         =   0   'False
         Width           =   960
      End
      Begin VB.CommandButton cmdRefresh
         Caption         =   "&Refresh"
         Height          =   330
         Left            =   3780
         TabIndex        =   12
         Top             =   0
         Width           =   960
      End
      Begin VB.CommandButton cmdFind
         Caption         =   "&Find"
         Height          =   330
         Left            =   2835
         TabIndex        =   5
         Top             =   0
         Width           =   960
      End
      Begin VB.CommandButton cmdClose
         Cancel          =   -1  'True
         Caption         =   "&Close"
         Height          =   330
         Left            =   4725
         TabIndex        =   4
         Top             =   0
         Width           =   960
      End
      Begin VB.CommandButton cmdDelete
         Caption         =   "&Delete"
         Height          =   330
         Left            =   1890
         TabIndex        =   3
         Top             =   0
         Width           =   960
      End
      Begin VB.CommandButton cmdAdd
         Caption         =   "&Add"
         Height          =   330
         Left            =   0
         TabIndex        =   2
         Top             =   0
         Width           =   960
      End
      Begin VB.CommandButton cmdUpdate
         Caption         =   "&Update"
         Height          =   330
         Left            =   960
         TabIndex        =   1
         Top             =   0
         Width           =   960
      End
      Begin VB.Label lblFieldHeader
         Caption         =   "Field Name:"
         Height          =   255
         Left            =   120
         TabIndex        =   15
         Top             =   360
         Width           =   1215
      End
      Begin VB.Label lblFieldValue
         Caption         =   " Value:"
         Height          =   255
         Left            =   1680
         TabIndex        =   14
         Top             =   360
         Width           =   2655
      End
   End
   Begin VB.Data datDataCtl
      Align           =   2  'Align Bottom
      Connect         =   ""
      DatabaseName    =   ""
      Exclusive       =   0   'False
      Height          =   300
      Left            =   0
      Options         =   0
      ReadOnly        =   0   'False
      RecordsetType   =   1  'Dynaset
      RecordSource    =   ""
      Tag             =   "OLE"
      Top             =   1860
      Width           =   5670
   End
   Begin VB.VScrollBar vsbScrollBar
      Height          =   2440
      LargeChange     =   3000
      Left            =   7665
      SmallChange     =   300
      TabIndex        =   11
      Top             =   630
      Visible         =   0   'False
      Width           =   255
   End
   Begin VB.PictureBox picFields
      Appearance      =   0  'Flat
      BorderStyle     =   0  'None
      ForeColor       =   &H80000008&
      Height          =   1065
      Left            =   0
      ScaleHeight     =   1056.479
      ScaleMode       =   0  'User
      ScaleWidth      =   7600.262
      TabIndex        =   6
      TabStop         =   0   'False
      Top             =   600
      Width           =   7605
      Begin VB.TextBox txtFieldData
         BackColor       =   &H00FFFFFF&
         DataSource      =   "datDataCtl"
         ForeColor       =   &H00000000&
         Height          =   285
         Index           =   0
         Left            =   1665
         TabIndex        =   9
         Top             =   0
         Visible         =   0   'False
         Width           =   3255
      End
      Begin VB.CheckBox chkFieldData
         DataSource      =   "datDataCtl"
         Height          =   282
         Index           =   0
         Left            =   1680
         TabIndex        =   8
         Top             =   735
         Visible         =   0   'False
         Width           =   3270
      End
      Begin VB.PictureBox picFieldData
         BackColor       =   &H00FFFFFF&
         DataSource      =   "datDataCtl"
         Height          =   285
         Index           =   0
         Left            =   1680
         ScaleHeight     =   225
         ScaleWidth      =   3210
         TabIndex        =   7
         Top             =   360
         Visible         =   0   'False
         Width           =   3270
      End
      Begin VB.OLE oleFieldData
         BackColor       =   &H00FFFFFF&
         DataSource      =   "datDataCtl"
         DisplayType     =   1  'Icon
         Height          =   300
         Index           =   0
         Left            =   1680
         TabIndex        =   16
         Top             =   360
         Visible         =   0   'False
         Width           =   3255
      End
      Begin VB.Label lblFieldName
         ForeColor       =   &H00000000&
         Height          =   195
         Index           =   0
         Left            =   105
         TabIndex        =   10
         Top             =   0
         Visible         =   0   'False
         Width           =   300
      End
   End
Attribute VB_Name = "frmDataControl"
Attribute VB_Creatable = False
Attribute VB_Exposed = False
Option Explicit
'============================================================================
' This is a fairly generic form that can be used in most cases with any
' table. It can be added to any app with a few changes denoted below
' with ---------.
' DATACONS.TXT and the data control section from CONSTANT.TXT
' are required for this form
'============================================================================
'----------------------------------------------------------------------------
'Uncomment the next line if it does not already exist in you app
'Declare Function OSTimeGetTime& Lib "MMSYSTEM.DLL" Alias "TimeGetTime" ()
'for 32 bit you need to use the following declare
'Declare Function OSTimeGetTime& Lib "WINMM.DLL" Alias "timeGetTime" ()
'----------------------------------------------------------------------------
Dim maFldArr() As Object
Dim mrecFDS As Recordset
Dim msBookMark As String         'form bookmark
Dim mnNumFields As Integer       'number of fields
Dim mlNumRows As Long            'recordcount for recordset
Dim mbJustUsedFind As Integer    'flag for find function
Dim mbResizing As Integer        'flag to avoid resize recursion
Dim mbCancel As Integer          'flag to cancel an addnew
Dim mnFieldTop As Integer        'top field position
Const mnMSGBOX_YES = 6
Const mnMSGBOX_TYPE = 4 + 48
Const mnCTLARRAYHEIGHT = 340
Private Sub chkFieldData_MouseUp(Index As Integer, Button As Integer, Shift As Integer, x As Single, Y As Single)
  If Button <> 2 Then Exit Sub
  ShowProperties "Field", mrecFDS.Fields(Index)
End Sub
Private Sub cmdAdd_Click()
  On Error GoTo AddErr
  datDataCtl.Recordset.AddNew
  datDataCtl.Caption = "New Record"
  cmdCancelAdd.Visible = True
  cmdAdd.Visible = False
  If datDataCtl.Recordset.RecordCount <> 0 Then
    msBookMark = datDataCtl.Recordset.Bookmark
    maFldArr(0).SetFocus
  End If
  Exit Sub
AddErr:
  ShowErrMsg
  Exit Sub
End Sub
Private Sub cmdCancelAdd_Click()
  On Error Resume Next
  mbCancel = True
  'go back to the previous current record
  If Len(msBookMark) > 0 Then
    datDataCtl.Recordset.Bookmark = msBookMark
  End If
End Sub
'----------------------------------------------------------
'this sub loads the Data Control property sheet
'comment it out for standalone use
'----------------------------------------------------------
Sub datDataCtl_MouseUp(Button As Integer, Shift As Integer, x As Single, Y As Single)
  On Error GoTo DCPErr
  Dim i As Integer
  Dim recClone As Recordset
  Dim sTmpRS As String
  Dim sTmpDB As String
  Dim sTmpTag As String
  If Button = 2 Then
    SetHourglass
    sTmpRS = datDataCtl.RecordSource
    sTmpDB = datDataCtl.DatabaseName
    sTmpTag = datDataCtl.Tag
    Set gDataCtlObj = datDataCtl
    frmDataCtlProp.Show vbModal
    If Not gDataCtlObj Is Nothing Then
      'check for a changed recordset, db or bound binary type
      'and clear the bound fields if one was changed
      If (sTmpRS <> gDataCtlObj.RecordSource Or sTmpDB <> gDataCtlObj.DatabaseName) _
         Or gDataCtlObj.Tag <> sTmpTag Then
        'clear the field names and unbind the controls
        For i = 0 To mnNumFields - 1
          lblFieldName(i).Caption = gsNULL_STR
          maFldArr(i).DataField = gsNULL_STR
          maFldArr(i).Visible = False
        Next
      End If
      datDataCtl.Refresh
      If (sTmpRS <> gDataCtlObj.RecordSource Or sTmpDB <> gDataCtlObj.DatabaseName) _
         Or gDataCtlObj.Tag <> sTmpTag Then
        Set recClone = datDataCtl.Recordset.Clone()
        If recClone.BOF = False And (datDataCtl.Options And dbForwardOnly) = 0 Then
          recClone.MoveLast
          mlNumRows = recClone.RecordCount
        Else
          mlNumRows = 0
        End If
        recClone.Close
        LoadFields
        SetRecNum
      Else
        'need to refresh the local recordset copy for
        'other operations that use it such as property access
        Set mrecFDS = datDataCtl.Recordset
        'if it is a forward only recordset, then we need to call SetRecNum
        'to display the correct data control caption
        If (datDataCtl.Options And dbForwardOnly) = dbForwardOnly Then
          SetRecNum
        End If
      End If
      gbSettingDataCtl = False
      If gDataCtlObj.Tag <> sTmpTag Then
        Form_Resize    'needed to set the left prop on newly loaded ctls
      End If
    End If
  End If
  Exit Sub
DCPErr:
  ShowError
  Unload Me
  Exit Sub
End Sub
Private Sub Form_Unload(Cancel As Integer)
  DBEngine.Idle dbFreeLocks
End Sub
Private Sub oleFieldData_MouseUp(Index As Integer, Button As Integer, Shift As Integer, x As Single, Y As Single)
  If Button <> 2 Then Exit Sub
  'this will display the dialog that allows
  'entry in to the ole field
  oleFieldData(Index).InsertObjDlg
'  ShowProperties "Field", mrecFDS.Fields(Index)
End Sub
Private Sub picFieldData_MouseUp(Index As Integer, Button As Integer, Shift As Integer, x As Single, Y As Single)
  If Button <> 2 Then Exit Sub
  ShowProperties "Field", mrecFDS.Fields(Index)
End Sub
Private Sub txtFieldData_KeyPress(Index As Integer, KeyAscii As Integer)
  'go to next field on an enter keypress
  If KeyAscii = 13 Then
    KeyAscii = 0
    SendKeys "{Tab}"
  End If
End Sub
Private Sub picFieldData_Click(Index As Integer)
  'this toggles the size of a picture control
  'so it mat be viewed or compressed
  If picFieldData(Index).Height <= 280 Then
    picFieldData(Index).AutoSize = True
  Else
    picFieldData(Index).AutoSize = False
    picFieldData(Index).Height = 280
  End If
End Sub
Private Sub picFieldData_DblClick(Index As Integer)
  On Error GoTo PicErr
  '----------------------------------------------------------
  ' For standalone operation, you must add a Common Dialog
  ' control called dlgCMD1 and remove the frmMDI references
  '----------------------------------------------------------
  With frmMDI.dlgCMD1
    .Filter = "Bitmaps (*.bmp)|*.bmp|Icons (*.ico)|*.ico|Metafiles (*.wmf)|*.wmf|All Files (*.*)|*.*"
    .DialogTitle = "Select a Picture File to Load"
    .FilterIndex = 1
  End With
  frmMDI.dlgCMD1.ShowOpen
  If Len(frmMDI.dlgCMD1.FileName) > 0 Then
    picFieldData(Index).Picture = LoadPicture(frmMDI.dlgCMD1.FileName)
  End If
  Exit Sub
PicErr:
  ShowErrMsg
  Exit Sub
End Sub
Private Sub cmdClose_Click()
  On Error Resume Next
  Unload Me
End Sub
Sub txtFieldData_MouseUp(Index As Integer, Button As Integer, Shift As Integer, x As Single, Y As Single)
  If Button <> 2 Then Exit Sub
  ShowProperties "Field", mrecFDS.Fields(Index)
End Sub
Private Sub vsbScrollBar_Change()
  Dim nCurrVal As Integer
  nCurrVal = vsbScrollBar
  If (nCurrVal - mnFieldTop) Mod mnCTLARRAYHEIGHT = 0 Then
    picFields.Top = nCurrVal
  Else
    picFields.Top = ((nCurrVal - mnFieldTop) \ mnCTLARRAYHEIGHT) * mnCTLARRAYHEIGHT + mnFieldTop
  End If
End Sub
Private Sub datDataCtl_Error(DataErr As Integer, Response As Integer)
  If DataErr = 481 Then  'throw away bad picture error
    Response = vbDataErrContinue
  Else
    MsgBox "Data error event hit Err:" & Error(DataErr)
  End If
End Sub
Private Sub datDataCtl_RePosition()
  On Error GoTo RepErr
  Dim sBookMark As String
  Dim recClone As Recordset
  'if we are resetting the data control, we need to skip this sub
  If gbSettingDataCtl = True Then Exit Sub
  'if the recordset is empty and we are not already in AddNew mode
  'we need to call the cmdAdd_Click routine to execute an AddNew
  If datDataCtl.Recordset.RecordCount = 0 And datDataCtl.EditMode <> dbEditAdd Then
    Call cmdAdd_Click
    Exit Sub
  End If
  SetRecNum
  Exit Sub
RepErr:
  ShowErrMsg
  Exit Sub
End Sub
Private Sub datDataCtl_Validate(Action As Integer, Save As Integer)
  On Error GoTo ValErr
  If mbCancel Then
    Save = False
    mbCancel = False
    Exit Sub
  End If
  'first check for a move from an addnew or edit record
  If Action < 5 Then
    If Save = True Then      'data changed
      If datDataCtl.EditMode = dbEditAdd Then
        If MsgBox("Save New Record?", mnMSGBOX_TYPE) = mnMSGBOX_YES Then
          mlNumRows = mlNumRows + 1
        Else
          Save = False
        End If
      Else
        If MsgBox("Commit Changes?", mnMSGBOX_TYPE) <> mnMSGBOX_YES Then
          Save = False        'loose changes
        End If
      End If
    End If
  End If
  Select Case Action
    Case vbDataActionMoveFirst
      'do nothing
    Case vbDataActionMovePrevious
      'do nothing
    Case vbDataActionMoveNext
      'do nothing
    Case vbDataActionMoveLast
      'do nothing
    Case vbDataActionAddNew
      'do nothing
    Case vbDataActionUpdate
       'moved to the cmdUpdate_click event code
    Case vbDataActionDelete
      'do nothing
    Case vbDataActionFind
      'set the flag for use in the reposition event
      mbJustUsedFind = True
    Case vbDataActionBookmark
      'do nothing"
    Case vbDataActionClose, vbDataActionUnload
      If Save = True Then
        If MsgBox("Commit Changes before Closing?", mnMSGBOX_TYPE) <> mnMSGBOX_YES Then
          Save = False
        End If
      End If
  End Select
  Exit Sub
ValErr:
  ShowErrMsg
  Exit Sub
End Sub
Private Sub cmdDelete_Click()
  On Error GoTo DELErr
  If MsgBox("Delete Current Record?", mnMSGBOX_TYPE) = mnMSGBOX_YES Then
    datDataCtl.Recordset.Delete
    mlNumRows = mlNumRows - 1
    datDataCtl.Recordset.MoveNext
    'move off the EOF condition if it occurs
    If datDataCtl.Recordset.RecordCount > 0 Then datDataCtl.Recordset.MoveLast
    maFldArr(0).SetFocus
  End If
  Exit Sub
DELErr:
  ShowErrMsg
  Exit Sub
End Sub
Private Sub cmdFind_Click()
  On Error GoTo FindErr
  Dim sBookMark As String
  Dim sFindStr As String
  If datDataCtl.Recordset.Type = dbOpenTable Then
    sFindStr = InputBox("Enter Seek Value:")
  Else
    sFindStr = InputBox("Enter Search Expression:")
  End If
  If Len(sFindStr) = 0 Then Exit Sub
  If datDataCtl.Recordset.RecordCount > 0 Then
    sBookMark = datDataCtl.Recordset.Bookmark
  End If
  If datDataCtl.Recordset.Type = dbOpenTable Then
    datDataCtl.Recordset.Seek "=", sFindStr
  Else
    datDataCtl.Recordset.FindFirst sFindStr
  End If
  'return to old record if no match was found
  If datDataCtl.Recordset.NoMatch And Len(sBookMark) > 0 Then
    datDataCtl.Recordset.Bookmark = sBookMark
  End If
  maFldArr(0).SetFocus
  Exit Sub
FindErr:
  ShowErrMsg
  maFldArr(0).SetFocus
  Exit Sub
End Sub
Private Sub Form_Load()
  Dim recTmp As Recordset
  Dim qdfTmp As QueryDef
  Dim bParmQry As Integer
  Dim Start1 As Long, Finish1 As Long, Start2 As Long, Finish2 As Long
  Dim sTmp As String
  On Error GoTo LoadErr
  '-------------------------------------------------------
  'this is where the data control properties get
  'set from whatever source they are coming from
  'in this case, it is form1 controls
  '-------------------------------------------------------
  If gsDataType <> gsSQLDB Then
    datDataCtl.DatabaseName = gdbCurrentDB.Name
  End If
  datDataCtl.Connect = gdbCurrentDB.Connect
  'determine if a table name or sql statement is used
  If gbFromSQL = True Then
    Set qdfTmp = gdbCurrentDB.CreateQueryDef(gsNULL_STR)
    If MsgBox("Is this a SQLPassThrough Query?", vbYesNo + vbQuestion + vbDefaultButton2) = vbYes Then
      sTmp = InputBox("Enter Connect property value:")
      If Len(sTmp) > 0 Then
        qdfTmp.Connect = sTmp
        qdfTmp.ReturnsRecords = True
      End If
    End If
    If Len(gsDynaString) = 0 Then
      datDataCtl.RecordSource = frmSQL.txtSQLStatement
      qdfTmp.SQL = frmSQL.txtSQLStatement
    Else
      datDataCtl.RecordSource = gsDynaString
      qdfTmp.SQL = gsDynaString
    End If
    If qdfTmp.PARAMETERS.Count > 0 Then
      bParmQry = True
    End If
  Else
    If frmTables.optTables.Value = True Then
      If frmMDI.optPassThru.Value = True Then
        datDataCtl.RecordSource = "select * from " & StripOwner((StripConnect(frmTables.lstTables.Text)))
      Else
        datDataCtl.RecordSource = StripConnect(frmTables.lstTables.Text)
      End If
    Else
      datDataCtl.RecordSource = frmTables.lstQueryDefs.Text
      Set qdfTmp = gdbCurrentDB.QueryDefs(frmTables.lstQueryDefs.Text)
      If qdfTmp.PARAMETERS.Count > 0 Then
        bParmQry = True
      End If
    End If
  End If
  'set the passthrough option if checked on the MDI form
  If frmMDI.optPassThru.Visible = True Then
    If frmMDI.optPassThru.Value = True Then
      datDataCtl.Options = dbSQLPassThrough
    End If
  End If
  'set the recordset type
  If frmMDI.optDynaset.Value = True Then
    datDataCtl.RecordsetType = vbRSTypeDynaset
  ElseIf frmMDI.optTable.Value = True Then
    datDataCtl.RecordsetType = vbRSTypeTable
  Else
    'this covers passthrough as well
    datDataCtl.RecordsetType = vbRSTypeSnapShot
  End If
  If bParmQry = True Then
    'parameterized query
    SetParams qdfTmp
    Start1 = OSTimeGetTime()
    Set datDataCtl.Recordset = qdfTmp.OpenRecordset( _
                             IIf(datDataCtl.RecordsetType = vbRSTypeDynaset, 2, 4) _
                             , datDataCtl.Options)
  Else
    Start1 = OSTimeGetTime()
    datDataCtl.Refresh
  End If
  '-------------------------------------------------------
  'for a standalone form, comment out the code above and
  'uncomment the lines below and add the needed info to them
  'datDataCtl.DatabaseName = ""
  'datDataCtl.Connect = ""
  'datDataCtl.RecordSource = ""
  'datDataCtl.RecordsetType = 1   'dynaset
  'datDataCtl.Options = 0
  'Start1 = OSTimeGetTime()
  'datDataCtl.Refresh
  '-------------------------------------------------------
  Finish1 = OSTimeGetTime()
  'set the locking type
  If gsDataType = gsJETMDB And datDataCtl.Recordset.Type <> dbOpenSnapshot Then
    datDataCtl.Recordset.LockEdits = gnMULocking
  End If
  Start2 = OSTimeGetTime()
  If datDataCtl.RecordsetType = vbRSTypeTable Then
    'need to set the index on a table if there is any
    If datDataCtl.Database(datDataCtl.RecordSource).Indexes.Count > 0 Then
      datDataCtl.Recordset.Index = datDataCtl.Database(datDataCtl.RecordSource).Indexes(0).Name
    End If
    mlNumRows = datDataCtl.Recordset.RecordCount
  Else
    'on dynasets and snapshots, we need to move last to get the recordcount
    Set recTmp = datDataCtl.Recordset.Clone()
    If recTmp.BOF = False And (datDataCtl.Options And dbForwardOnly) = 0 Then
      recTmp.MoveLast
      mlNumRows = recTmp.RecordCount
    Else
      mlNumRows = 0
    End If
    recTmp.Close
  End If
  Finish2 = OSTimeGetTime()
  If Len(datDataCtl.RecordSource) > 50 Then
    Me.Caption = "SQL Statement"
  Else
    Me.Caption = datDataCtl.RecordSource
  End If
  Me.Width = 5805
  LoadFields
  Me.Show
  maFldArr(0).SetFocus
  SetRecNum
  Finish2 = OSTimeGetTime()
  '-------------------------------------------------------
  'change the line below for a standalone form
  '-------------------------------------------------------
  If frmMDI.mnuPShowPerf.Checked Then
  '-------------------------------------------------------
    MsgBox CStr(mlNumRows) & " rows found in " & (Finish1 - Start1) / 1000 & " seconds!" & gsNewLine & (Finish2 - Start2) / 1000 & " seconds to Get Record Count!", 48
  End If
  Exit Sub
LoadErr:
  ShowErrMsg
  Unload Me
  Exit Sub
End Sub
Private Sub Form_Resize()
  On Error Resume Next
  If gbSettingDataCtl = True Then Exit Sub
  If mbResizing = True Then Exit Sub
  Dim nHeight As Integer
  Dim i As Integer
  Dim nTotalWidth As Integer
  mbResizing = True
  If Me.WindowState <> 1 And lblFieldName(0).Visible = True Then 'not minimized
    'make sure the form is lined up on a field
    nHeight = Me.Height
    If (nHeight - 1320) Mod mnCTLARRAYHEIGHT <> 0 Then
      Me.Height = ((nHeight - 1280) \ mnCTLARRAYHEIGHT) * mnCTLARRAYHEIGHT + 1280
    End If
    'resize the status bar
    datDataCtl.Top = Me.Height - 650
    'resize the scrollbar
    vsbScrollBar.Height = Me.Height - 1300
    vsbScrollBar.Left = Me.Width - 360
    If mrecFDS.Fields.Count > 10 Then
      picFields.Width = Me.Width - 260
      nTotalWidth = vsbScrollBar.Left - 20
    Else
      picFields.Width = Me.Width - 20
      nTotalWidth = Me.Width - 50
    End If
    picButtons.Width = Me.Width - 20
    'widen the fields if possible
    For i = 0 To mrecFDS.Fields.Count - 1
      lblFieldName(i).Width = 0.3 * nTotalWidth - 100
      maFldArr(i).Left = lblFieldName(i).Width + 200
      If datDataCtl.Recordset.Fields(i).Type > 9 Then
        maFldArr(i).Width = 0.7 * nTotalWidth - 270
      End If
    Next
    lblFieldValue.Left = maFldArr(0).Left
  End If
  mbResizing = False
End Sub
Private Function GetFieldWidth(rnType As Integer)
  'determines the form control width
  'based on the field type
  Select Case rnType
    Case dbBoolean
      GetFieldWidth = 850
    Case dbByte
      GetFieldWidth = 650
    Case dbInteger
      GetFieldWidth = 900
    Case dbLong
      GetFieldWidth = 1100
    Case dbCurrency
      GetFieldWidth = 1800
    Case dbSingle
      GetFieldWidth = 1800
    Case dbDouble
      GetFieldWidth = 2200
    Case dbDate
      GetFieldWidth = 2000
    Case dbText
      GetFieldWidth = 3250
    Case dbMemo
      GetFieldWidth = 3250
    Case Else
      GetFieldWidth = 3250
  End Select
End Function
Private Sub LoadFields()
   Dim recTmp As Recordset
   Dim nFldType As Integer
   Dim i As Integer
   On Error GoTo LoadFieldsErr
   Set mrecFDS = datDataCtl.Recordset
   Set recTmp = mrecFDS
   'load the controls on the recordset form
   mnNumFields = recTmp.Fields.Count
   ReDim maFldArr(mnNumFields) As Object
   lblFieldName(0).Visible = True
   nFldType = recTmp.Fields(0).Type
   If nFldType = dbBoolean Then
     Set maFldArr(0) = chkFieldData(0)
   ElseIf nFldType = dbLongBinary Then
     If datDataCtl.Tag = "OLE" Then
       Set maFldArr(0) = oleFieldData(0)
     Else
       Set maFldArr(0) = picFieldData(0)
     End If
   Else
     Set maFldArr(0) = txtFieldData(0)
   End If
   maFldArr(0).Visible = True
   maFldArr(0).Top = 0
   maFldArr(0).Width = GetFieldWidth(nFldType)
   If nFldType = dbText Then maFldArr(0).MaxLength = recTmp.Fields(0).Size
   maFldArr(0).TabIndex = 0
   On Error Resume Next
   For i = 1 To recTmp.Fields.Count - 1
     picFields.Height = picFields.Height + mnCTLARRAYHEIGHT
     Load lblFieldName(i)
     lblFieldName(i).Top = lblFieldName(i - 1).Top + mnCTLARRAYHEIGHT
     lblFieldName(i).Visible = True
     nFldType = recTmp.Fields(i).Type
     If nFldType = dbBoolean Then
       Load chkFieldData(i)
       Set maFldArr(i) = chkFieldData(i)
     ElseIf nFldType = dbLongBinary Then
       If datDataCtl.Tag = "OLE" Then
         Load oleFieldData(i)
         Set maFldArr(i) = oleFieldData(i)
       Else
         Load picFieldData(i)
         Set maFldArr(i) = picFieldData(i)
       End If
     Else
       Load txtFieldData(i)
       Set maFldArr(i) = txtFieldData(i)
     End If
     maFldArr(i).Top = maFldArr(i - 1).Top + mnCTLARRAYHEIGHT
     maFldArr(i).Visible = True
     maFldArr(i).Width = GetFieldWidth(nFldType)
     maFldArr(i).TabIndex = i
     If nFldType = dbText Then maFldArr(i).MaxLength = recTmp.Fields(i).Size
   Next
   On Error GoTo LoadFieldsErr
   'resize main window
   picFields.Top = picButtons.Top + picButtons.Height
   mnFieldTop = picFields.Top
   vsbScrollBar.Value = mnFieldTop
   If i <= 10 Then
     Height = i * mnCTLARRAYHEIGHT + 1500
     vsbScrollBar.Visible = False
   Else
     Height = 4500
     Width = Width + 260
     vsbScrollBar.Visible = True
     vsbScrollBar.Min = mnFieldTop
     vsbScrollBar.Max = mnFieldTop - (i * mnCTLARRAYHEIGHT) + 3000
   End If
   'display the field names
   For i = 0 To recTmp.Fields.Count - 1
     lblFieldName(i).Caption = recTmp.Fields(i).Name & ":"
   Next
   'bind the controls
   On Error Resume Next   'bind even if table is empty
   For i = 0 To recTmp.Fields.Count - 1
     maFldArr(i).DataField = recTmp.Fields(i).Name
   Next
   Exit Sub
LoadFieldsErr:
   ShowErrMsg
   Exit Sub
End Sub
Private Sub cmdRefresh_Click()
  On Error GoTo RefErr
  datDataCtl.Refresh
  Exit Sub
RefErr:
  ShowErrMsg
  Exit Sub
End Sub
Private Sub SetRecNum()
  On Error GoTo SRErr
  Dim sCurrStat As String
  Dim lCurrRec As Long
  Dim bNoInd As Integer
  If datDataCtl.EditMode <> dbEditAdd Then
    If datDataCtl.Recordset.BOF = True Then
      sCurrStat = "Record BOF of " & mlNumRows
    ElseIf datDataCtl.Recordset.EOF = True Then
      sCurrStat = "Record EOF of " & mlNumRows
    Else
      'check to see if a table w/ 0 indexes is in use
      If datDataCtl.Recordset.Type = dbOpenTable Then
        If datDataCtl.Database(datDataCtl.RecordSource).Indexes.Count = 0 Then
          bNoInd = True
        End If
      End If
      'if there are no indexes on a table or the recset if ForwardOnly
      'then the PercentPosition is unavailable
      If bNoInd = True Then
        sCurrStat = mlNumRows & " Rows"
      ElseIf (datDataCtl.Options And dbForwardOnly) = dbForwardOnly Then
        sCurrStat = mlNumRows & " Rows (Forward Only Recordset)"
      Else
        lCurrRec = (mlNumRows * (datDataCtl.Recordset.PercentPosition * 0.01)) + 1
        sCurrStat = "Row " & lCurrRec & " of " & mlNumRows
      End If
    End If
    If datDataCtl.Recordset.Updatable = False Then sCurrStat = sCurrStat & "  [Not Updatable]"
    datDataCtl.Caption = sCurrStat
  End If
  'reset buttons if needed
  If datDataCtl.EditMode <> dbEditAdd Then
    cmdCancelAdd.Visible = False
    cmdAdd.Visible = True
  End If
  Exit Sub
SRErr:
  If Err <> 3021 Then
    ShowErrMsg
  End If
  Exit Sub
End Sub
Private Sub cmdUpdate_Click()
  On Error GoTo UpdErr
  Dim bAddFlag As Integer
  Dim nDelay As Long
  Dim nRetryCnt As Integer
  bAddFlag = datDataCtl.EditMode
  If datDataCtl.EditMode = dbEditAdd Then
    If MsgBox("Save New Record?", mnMSGBOX_TYPE) = mnMSGBOX_YES Then
      SetHourglass
RetryUpd1:
      datDataCtl.UpdateRecord
      mlNumRows = mlNumRows + 1
    End If
  Else
    If MsgBox("Commit Changes?", mnMSGBOX_TYPE) = mnMSGBOX_YES Then
      SetHourglass
RetryUpd2:
      datDataCtl.UpdateRecord
    End If
  End If
  If bAddFlag = dbEditAdd Then
    mrecFDS.MoveLast
  End If
  DBEngine.Idle dbFreeLocks
  Screen.MousePointer = vbDefault
  Exit Sub
UpdErr:
  If Err = 3260 And nRetryCnt < gnMURetryCnt Then
    nRetryCnt = nRetryCnt + 1
    datDataCtl.Recordset.Bookmark = datDataCtl.Recordset.Bookmark   'Cancel the update
    DBEngine.Idle dbFreeLocks
    nDelay = Timer
    'Wait gnMUDelay seconds
    While Timer - nDelay < gnMUDelay
      'do nothing
    Wend
    If datDataCtl.EditMode = dbEditAdd Then
      Resume RetryUpd1
    Else
      Resume RetryUpd2
    End If
  Else
    Screen.MousePointer = vbDefault
    ShowErrMsg
    Exit Sub
  End If
End Sub
Private Sub ShowErrMsg()
  MsgBox "Error:" & Err & " " & Error
End Sub