Tools/WinSN5.0Ver.iso/PVb5.0/VB/SAMPLES/VISDATA/DYNASNAP.FRM

Visual Basic Form | 1997-03-12 | 28.4 KB | 897 lines

VERSION 5.00
Begin VB.Form frmDynaSnap
   ClientHeight    =   3750
   ClientLeft      =   2730
   ClientTop       =   2610
   ClientWidth     =   5490
   HelpContextID   =   2016125
   Icon            =   "DYNASNAP.frx":0000
   KeyPreview      =   -1  'True
   LinkTopic       =   "Form1"
   LockControls    =   -1  'True
   MDIChild        =   -1  'True
   ScaleHeight     =   3733.906
   ScaleMode       =   0  'User
   ScaleWidth      =   5503.698
   ShowInTaskbar   =   0   'False
   Tag             =   "Recordset"
   Begin VB.PictureBox picViewButtons
      Align           =   1  'Align Top
      Appearance      =   0  'Flat
      BorderStyle     =   0  'None
      ForeColor       =   &H80000008&
      Height          =   840
      Left            =   0
      ScaleHeight     =   840
      ScaleMode       =   0  'User
      ScaleWidth      =   5487.272
      TabIndex        =   13
      TabStop         =   0   'False
      Top             =   0
      Width           =   5484
      Begin VB.CommandButton cmdMove
         Caption         =   "
(&M)"
         Height          =   345
         Left            =   2730
         MaskColor       =   &H00000000&
         TabIndex        =   7
         Top             =   375
         Width           =   1365
      End
      Begin VB.CommandButton cmdSort
         Caption         =   "
(&S)"
         Height          =   345
         Left            =   0
         MaskColor       =   &H00000000&
         TabIndex        =   5
         Top             =   372
         Width           =   1365
      End
      Begin VB.CommandButton cmdFilter
         Caption         =   "
(&I)"
         Height          =   345
         Left            =   1365
         MaskColor       =   &H00000000&
         TabIndex        =   6
         Top             =   375
         Width           =   1365
      End
      Begin VB.CommandButton cmdClose
         Cancel          =   -1  'True
         Caption         =   "
(&C)"
         Height          =   345
         Left            =   4095
         MaskColor       =   &H00000000&
         TabIndex        =   4
         TabStop         =   0   'False
         Top             =   15
         Width           =   1365
      End
      Begin VB.CommandButton cmdDelete
         Caption         =   "
(&D)"
         Height          =   345
         Left            =   2730
         MaskColor       =   &H00000000&
         TabIndex        =   3
         Top             =   15
         Width           =   1365
      End
      Begin VB.CommandButton cmdEdit
         Caption         =   "
(&E)"
         Height          =   345
         Left            =   1365
         MaskColor       =   &H00000000&
         TabIndex        =   2
         Top             =   15
         Width           =   1365
      End
      Begin VB.CommandButton cmdAdd
         Caption         =   "
(&A)"
         Height          =   345
         Left            =   0
         MaskColor       =   &H00000000&
         TabIndex        =   1
         Top             =   20
         Width           =   1365
      End
      Begin VB.CommandButton cmdFind
         Caption         =   "
(&F)"
         Height          =   345
         Left            =   4095
         MaskColor       =   &H00000000&
         TabIndex        =   8
         Top             =   375
         Width           =   1365
      End
   End
   Begin VB.PictureBox picChangeButtons
      Appearance      =   0  'Flat
      BorderStyle     =   0  'None
      ForeColor       =   &H80000008&
      Height          =   728
      Left            =   0
      ScaleHeight     =   790.471
      ScaleMode       =   0  'User
      ScaleWidth      =   5719.056
      TabIndex        =   14
      TabStop         =   0   'False
      Top             =   0
      Visible         =   0   'False
      Width           =   5655
      Begin VB.CommandButton cmdUpdate
         Caption         =   "
(&U)"
         Height          =   372
         Left            =   960
         MaskColor       =   &H00000000&
         TabIndex        =   11
         Top             =   48
         Width           =   1212
      End
      Begin VB.CommandButton cmdCancel
         Caption         =   "
(&C)"
         Height          =   372
         Left            =   2640
         MaskColor       =   &H00000000&
         TabIndex        =   12
         Top             =   48
         Width           =   1212
      End
   End
   Begin VB.PictureBox picFldHdr
      Appearance      =   0  'Flat
      BorderStyle     =   0  'None
      ForeColor       =   &H80000008&
      Height          =   240
      Left            =   0
      ScaleHeight     =   240
      ScaleMode       =   0  'User
      ScaleWidth      =   14948.92
      TabIndex        =   18
      TabStop         =   0   'False
      Top             =   840
      Width           =   14946
      Begin VB.Label lblFieldValue
         Caption         =   "
         Height          =   210
         Left            =   1680
         TabIndex        =   20
         Top             =   0
         Width           =   2295
      End
      Begin VB.Label lblFieldHdr
         Caption         =   "
         Height          =   210
         Left            =   120
         TabIndex        =   19
         Top             =   0
         Width           =   1212
      End
   End
   Begin VB.PictureBox picMoveButtons
      Align           =   2  'Align Bottom
      Appearance      =   0  'Flat
      BorderStyle     =   0  'None
      ForeColor       =   &H80000008&
      Height          =   288
      Left            =   0
      ScaleHeight     =   298.153
      ScaleMode       =   0  'User
      ScaleWidth      =   5493.878
      TabIndex        =   17
      TabStop         =   0   'False
      Top             =   3465
      Width           =   5484
      Begin VB.HScrollBar hsclCurrRow
         Height          =   255
         Left            =   0
         Max             =   100
         TabIndex        =   9
         Top             =   29
         Width           =   2895
      End
      Begin VB.Label lblStatus
         Height          =   255
         Left            =   3000
         TabIndex        =   21
         Top             =   38
         Width           =   1695
      End
   End
   Begin VB.VScrollBar vsbScrollBar
      Height          =   2250
      LargeChange     =   3000
      Left            =   5040
      SmallChange     =   300
      TabIndex        =   10
      Top             =   1080
      Visible         =   0   'False
      Width           =   255
   End
   Begin VB.PictureBox picFields
      Appearance      =   0  'Flat
      BorderStyle     =   0  'None
      ForeColor       =   &H80000008&
      Height          =   375
      Left            =   120
      ScaleHeight     =   372
      ScaleMode       =   0  'User
      ScaleWidth      =   4812
      TabIndex        =   15
      TabStop         =   0   'False
      Top             =   1080
      Width           =   4815
      Begin VB.TextBox txtFieldData
         BackColor       =   &H00FFFFFF&
         DataSource      =   "Data1"
         ForeColor       =   &H00000000&
         Height          =   288
         Index           =   0
         Left            =   1560
         TabIndex        =   0
         Top             =   0
         Visible         =   0   'False
         Width           =   3252
      End
      Begin VB.Label lblFieldName
         ForeColor       =   &H00000000&
         Height          =   255
         Index           =   0
         Left            =   0
         TabIndex        =   16
         Top             =   0
         Visible         =   0   'False
         Width           =   1575
      End
   End
Attribute VB_Name = "frmDynaSnap"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
'>>>>>>>>>>>>>>>>>>>>>>>>
Const BUTTON1 = "
(&A)"
Const BUTTON2 = "
(&E)"
Const BUTTON3 = "
(&D)"
Const BUTTON4 = "
(&C)"
Const BUTTON5 = "
(&S)"
Const BUTTON6 = "
(&I)"
Const BUTTON7 = "
(&M)"
Const BUTTON8 = "
(&F)"
Const BUTTON9 = "
(&C)"
Const BUTTON10 = "
(&U)"
Const Label1 = "
Const Label2 = "
Const MSG1 = "
Const MSG2 = "
Const MSG3 = "
Const MSG4 = "
Const MSG5 = "
Const MSG6 = "
Const MSG7 = "
Const MSG8 = "
Const MSG9 = "
Const MSG10 = "
Const MSG11 = "
Const MSG12 = "
Const MSG13 = "
Const MSG14 = "
'>>>>>>>>>>>>>>>>>>>>>>>>
Public mrsFormRecordset As Recordset
Dim msTableName As String      '
Dim mvBookMark As Variant       '
Dim mbNotFound As Integer      '
Dim mbEditFlag As Integer      '
Dim mbAddNewFlag As Integer    '
Dim mbDataChanged As Integer   '
Dim mfrmFind As New frmFindForm      '
Dim mlNumRows As Long          '
Private Sub cmdAdd_Click()
  On Error GoTo AddErr
  mrsFormRecordset.AddNew
  lblStatus.Caption = MSG1
  mbAddNewFlag = True
  If mrsFormRecordset.RecordCount > 0 Then
    mvBookMark = mrsFormRecordset.Bookmark
  Else
    mvBookMark = vbNullString
  End If
  picChangeButtons.Visible = True
  picViewButtons.Visible = False
  hsclCurrRow.Enabled = False
  ClearDataFields Me, mrsFormRecordset.Fields.Count
  txtFieldData(0).SetFocus
  mbDataChanged = False
  Exit Sub
AddErr:
  ShowError
End Sub
Private Sub cmdCancel_Click()
   On Error Resume Next
   picChangeButtons.Visible = False
   picViewButtons.Visible = True
   hsclCurrRow.Enabled = True
   mbEditFlag = False
   mbAddNewFlag = False
   mrsFormRecordset.CancelUpdate
   DBEngine.Idle dbFreeLocks
   DisplayCurrentRecord Me, mrsFormRecordset, mlNumRows, mbAddNewFlag
   mbDataChanged = False
End Sub
Private Sub cmdMove_Click()
  On Error GoTo MVErr
  Dim sBookMark As String
  Dim sRows As String
  Dim lRows As Long
  sRows = InputBox(MSG2 & vbCrLf & MSG3)
  If Len(sRows) = 0 Then Exit Sub
  lRows = CLng(sRows)
  mrsFormRecordset.Move lRows
  If mrsFormRecordset.EOF Then
    mrsFormRecordset.MoveLast
  ElseIf mrsFormRecordset.BOF Then
    mrsFormRecordset.MoveFirst
  End If
  sBookMark = mrsFormRecordset.Bookmark  '
  If mlNumRows > 32767 Then
    hsclCurrRow.Value = (mrsFormRecordset.PercentPosition * 32767) / 100 + 1
  ElseIf mlNumRows > 99 Then
    hsclCurrRow.Value = (mrsFormRecordset.PercentPosition * mlNumRows) / 100 + 1
  Else
    hsclCurrRow.Value = mrsFormRecordset.PercentPosition
  End If
  mrsFormRecordset.Bookmark = sBookMark
  Exit Sub
MVErr:
  ShowError
End Sub
Private Sub hsclCurrRow_Change()
  On Error GoTo SCRErr
  Static nPrevVal As Integer
  Dim rsTmp As Recordset
  On Error Resume Next
  Set rsTmp = mrsFormRecordset.Clone()
  rsTmp.MoveNext
  If mrsFormRecordset.RecordCount > mlNumRows Then
    mlNumRows = mrsFormRecordset.RecordCount
    SetScrollBar
  End If
  On Error GoTo SCRErr
  If mlNumRows > 0 Then
    If mlNumRows > 99 Then   '32767 Then
      '
 > 32767
 move
      '
 32767
      '
      '
      If hsclCurrRow.Value - nPrevVal = 1 Then
        mrsFormRecordset.MoveNext
      ElseIf hsclCurrRow.Value - nPrevVal = -1 Then
        mrsFormRecordset.MovePrevious
      Else
        If mlNumRows > 32767 Then
          mrsFormRecordset.PercentPosition = (hsclCurrRow.Value / 32767) * 100 + 0.005
        Else
          mrsFormRecordset.PercentPosition = (hsclCurrRow.Value / mlNumRows) * 100 + 0.005
        End If
      End If
      nPrevVal = hsclCurrRow.Value
'    ElseIf mlNumRows > 99 Then
'      '
 > 99
'      mrsFormRecordset.PercentPosition = (hsclCurrRow.Value / mlNumRows) * 100 + 0.005
    Else
      mrsFormRecordset.PercentPosition = hsclCurrRow.Value
    End If
  End If
  DisplayCurrentRecord Me, mrsFormRecordset, mlNumRows, mbAddNewFlag
  mbDataChanged = False
  Screen.MousePointer = vbDefault
  MsgBar vbNullString, False
  Exit Sub
SCRErr:
  ShowError
End Sub
Private Sub txtFieldData_Change(Index As Integer)
 false
  mbDataChanged = True
End Sub
Private Sub txtFieldData_KeyDown(Index As Integer, KeyCode As Integer, Shift As Integer)
  If KeyCode = &H73 Then   'F4
    lblFieldName_DblClick Index
  ElseIf KeyCode = 34 And vsbScrollBar.Visible Then
    '
 > 10
    vsbScrollBar.Value = vsbScrollBar.Value - 3000
  ElseIf KeyCode = 33 And vsbScrollBar.Visible Then
    '
 > 10
    vsbScrollBar.Value = vsbScrollBar.Value + 3000
  End If
End Sub
Private Sub txtFieldData_KeyPress(Index As Integer, KeyAscii As Integer)
  If mbEditFlag Or mbAddNewFlag Then
    If KeyAscii = 13 Then
      KeyAscii = 0
      SendKeys "{Tab}"
    End If
  ElseIf mbEditFlag = False And mbAddNewFlag = False Then
    KeyAscii = 0
  End If
End Sub
Private Sub txtFieldData_LostFocus(Index As Integer)
  On Error GoTo FldDataErr
  If mbDataChanged Then
    '
    mrsFormRecordset(Index) = txtFieldData(Index)
  End If
  mbDataChanged = False
  Exit Sub
FldDataErr:
  mbDataChanged = False
  ShowError
End Sub
Private Sub lblFieldName_DblClick(Index As Integer)
  On Error GoTo ZoomErr
  If mrsFormRecordset(Index).Type = dbText Or mrsFormRecordset(Index).Type = dbMemo Then
     If mrsFormRecordset(Index).Type = dbText Then
       gsZoomData = txtFieldData(Index).Text
     ElseIf mrsFormRecordset(Index).FieldSize() < gnGETCHUNK_CUTOFF Then
       gsZoomData = txtFieldData(Index).Text
     Else
       '
 getchunk
       MsgBar "
 Memo
", True
       Screen.MousePointer = vbHourglass
       gsZoomData = txtFieldData(Index).Text & _
         StripNonAscii(mrsFormRecordset(Index).GetChunk(gnGETCHUNK_CUTOFF, gnMAX_MEMO_SIZE))
       Screen.MousePointer = vbDefault
       MsgBar vbNullString, False
     End If
     frmZoom.Caption = Mid(lblFieldName(Index).Caption, 1, Len(lblFieldName(Index).Caption) - 1)
     If mbAddNewFlag Or mbEditFlag Then
       frmZoom.cmdSave.Visible = True
       frmZoom.cmdCloseNoSave.Visible = True
     Else
       frmZoom.cmdClose.Visible = True
     End If
     If mrsFormRecordset(Index).Type = dbText Then
       frmZoom.txtZoomData.Text = gsZoomData
       frmZoom.Height = 1125
     Else
       frmZoom.txtMemo.Text = gsZoomData
       frmZoom.txtMemo.Visible = True
       frmZoom.txtZoomData.Visible = False
       frmZoom.Height = 2205
     End If
     frmZoom.Show vbModal
     If (mbAddNewFlag Or mbEditFlag) And gsZoomData <> "__CANCELLED__" Then
       If mrsFormRecordset(Index).Type = dbText And Len(gsZoomData) > mrsFormRecordset(Index).Size Then
         Beep
         MsgBox MSG4, 48
         txtFieldData(Index).Text = Mid(gsZoomData, 1, mrsFormRecordset(Index).Size)
       Else
         txtFieldData(Index).Text = gsZoomData
       End If
       mrsFormRecordset(Index) = txtFieldData(Index).Text
       mbDataChanged = False
     End If
  End If
  Exit Sub
ZoomErr:
  ShowError
End Sub
Private Sub cmdClose_Click()
  DBEngine.Idle dbFreeLocks
  Unload Me
End Sub
Private Sub vsbScrollBar_Change()
  Dim nTop As Integer
  nTop = vsbScrollBar.Value
  If (nTop - 1080) Mod gnCTLARRAYHEIGHT = 0 Then
    picFields.Top = nTop
  Else
    picFields.Top = ((nTop - 1080) \ gnCTLARRAYHEIGHT) * gnCTLARRAYHEIGHT + 1080
  End If
End Sub
Private Sub cmdDelete_Click()
  On Error GoTo DelRecErr
  If MsgBox(MSG5, vbYesNo + vbQuestion) = vbYes Then
    mrsFormRecordset.Delete
    If gbTransPending Then gbDBChanged = True
    If mrsFormRecordset.EOF = False Then
      '
      mrsFormRecordset.MoveNext
      If mrsFormRecordset.EOF And (mrsFormRecordset.RecordCount > 0) Then
        '
        mrsFormRecordset.MoveLast
      End If
    End If
    mlNumRows = mlNumRows - 1
    SetScrollBar
    mlNumRows = mrsFormRecordset.RecordCount
    DisplayCurrentRecord Me, mrsFormRecordset, mlNumRows, mbAddNewFlag
    mbDataChanged = False
  End If
  Exit Sub
DelRecErr:
  ShowError
End Sub
Private Sub cmdEdit_Click()
   On Error GoTo EditErr
  Dim nDelay As Long
  Dim nRetryCnt As Integer
  Screen.MousePointer = vbHourglass
RetryEdit:
   mrsFormRecordset.Edit
   lblStatus.Caption = MSG6
   mbEditFlag = True
   txtFieldData(0).SetFocus
   mvBookMark = mrsFormRecordset.Bookmark
   picChangeButtons.Visible = True
   picViewButtons.Visible = False
   hsclCurrRow.Enabled = False
   Screen.MousePointer = vbDefault
   Exit Sub
EditErr:
  If Err = 3260 And nRetryCnt < gnMURetryCnt Then
    nRetryCnt = nRetryCnt + 1
    DBEngine.Idle dbFreeLocks
    '
 gnMUDelay
    nDelay = Timer
    While Timer - nDelay < gnMUDelay
      '
    Wend
    Resume RetryEdit
  Else
    ShowError
  End If
End Sub
Private Sub cmdFilter_Click()
  On Error GoTo FilterErr
  Dim sBookMark As String
  Dim recRecordset1 As Recordset, recRecordset2 As Recordset
  Dim sFilterStr As String
  If mrsFormRecordset.RecordCount = 0 Then Exit Sub
  sBookMark = mrsFormRecordset.Bookmark        '
  Set recRecordset1 = mrsFormRecordset            '
  sFilterStr = InputBox(MSG7)
  If Len(sFilterStr) = 0 Then Exit Sub
  Screen.MousePointer = vbHourglass
  MsgBar MSG8, True
  mrsFormRecordset.Filter = sFilterStr
  Set recRecordset2 = mrsFormRecordset.OpenRecordset(mrsFormRecordset.Type) '
  recRecordset2.MoveLast
  recRecordset2.MoveFirst
  Set mrsFormRecordset = recRecordset2            '
 recordset
  mlNumRows = mrsFormRecordset.RecordCount
  SetScrollBar
  hsclCurrRow.Value = 0
  DisplayCurrentRecord Me, mrsFormRecordset, mlNumRows, mbAddNewFlag
  mbDataChanged = False
  Screen.MousePointer = vbDefault
  MsgBar vbNullString, False
  Exit Sub
FilterRecover:
  On Error Resume Next
  Set mrsFormRecordset = recRecordset1            '
  mrsFormRecordset.Bookmark = sBookMark           '
  Exit Sub
FilterErr:
  ShowError
  Resume FilterRecover
End Sub
Private Sub cmdFind_Click()
  On Error GoTo FindErr
  Dim i As Integer
  Dim sBookMark As String
  Dim sTmp As String
  If mfrmFind.lstFields.ListCount = 0 Then
    For i = 0 To mrsFormRecordset.Fields.Count - 1
      mfrmFind.lstFields.AddItem Mid(lblFieldName(i).Caption, 1, Len(lblFieldName(i).Caption) - 1)
    Next
  End If
FindStart:
  gbFindFailed = False
  gbFromTableView = False
  mbNotFound = False
  MsgBar MSG9, False
  mfrmFind.Show vbModal
  MsgBar MSG10, True
  If gbFindFailed Then    '
    GoTo AfterWhile
  End If
  Screen.MousePointer = vbHourglass
  i = mfrmFind.lstFields.ListIndex
  sBookMark = mrsFormRecordset.Bookmark
  If mrsFormRecordset(i).Type = dbText Or mrsFormRecordset(i).Type = dbMemo Then
    sTmp = AddBrackets((mrsFormRecordset(i).Name)) & " " & gsFindOp & " '" & gsFindExpr & "'"
  Else
    sTmp = AddBrackets((mrsFormRecordset(i).Name)) + gsFindOp + gsFindExpr
  End If
  Select Case gnFindType
    Case 0
      mrsFormRecordset.FindFirst sTmp
    Case 1
      mrsFormRecordset.FindNext sTmp
    Case 2
      mrsFormRecordset.FindPrevious sTmp
    Case 3
      mrsFormRecordset.FindLast sTmp
  End Select
  mbNotFound = mrsFormRecordset.NoMatch
AfterWhile:
  Screen.MousePointer = vbDefault
  If gbFindFailed Then    '
    mrsFormRecordset.Bookmark = sBookMark
  ElseIf mbNotFound Then
    Beep
    MsgBox MSG11, 48
    mrsFormRecordset.Bookmark = sBookMark
    GoTo FindStart
  Else
    sBookMark = mrsFormRecordset.Bookmark  '
    '
    If mlNumRows > 99 Then
      hsclCurrRow.Value = (mrsFormRecordset.PercentPosition * mlNumRows) / 100 + 1
    Else
      hsclCurrRow.Value = mrsFormRecordset.PercentPosition
    End If
    mrsFormRecordset.Bookmark = sBookMark
  End If
  DisplayCurrentRecord Me, mrsFormRecordset, mlNumRows, mbAddNewFlag
  mbDataChanged = False
  MsgBar vbNullString, False
  Exit Sub
FindErr:
  Screen.MousePointer = vbDefault
  If Err <> gnEOF_ERR Then
    ShowError
  Else
    mbNotFound = True
    Resume Next
  End If
End Sub
Private Sub Form_Load()
  Dim sTmp As String             '
  Dim nFieldType As Integer      '
  Dim i As Integer, j As Integer '
  On Error GoTo DynasetErr
  cmdAdd.Caption = BUTTON1
  cmdEdit.Caption = BUTTON2
  cmdDelete.Caption = BUTTON3
  cmdClose.Caption = BUTTON4
  cmdSort.Caption = BUTTON5
  cmdFilter.Caption = BUTTON6
  cmdMove.Caption = BUTTON7
  cmdFind.Caption = BUTTON8
  cmdCancel.Caption = BUTTON9
  cmdUpdate.Caption = BUTTON10
  lblFieldHdr.Caption = Label1
  lblFieldValue.Caption = Label2
  'mrsFormRecordset
  If gsDataType = gsMSACCESS And mrsFormRecordset.Type <> dbOpenSnapshot Then
    mrsFormRecordset.LockEdits = gnMULocking
  End If
  With mrsFormRecordset
    If .RecordCount > 0 Then
      '
      .MoveNext
      .MovePrevious
    End If
    mlNumRows = .RecordCount
  End With
  SetScrollBar
  lblFieldName(0).Visible = True
  txtFieldData(0).Visible = True
  nFieldType = mrsFormRecordset(0).Type
  txtFieldData(0).Width = GetFieldWidth(nFieldType)
  If nFieldType = dbText Then txtFieldData(0).MaxLength = mrsFormRecordset(0).Size
  txtFieldData(0).TabIndex = 0
  For i = 1 To mrsFormRecordset.Fields.Count - 1
    picFields.Height = picFields.Height + gnCTLARRAYHEIGHT
    Load lblFieldName(i)
    lblFieldName(i).Top = lblFieldName(i - 1).Top + gnCTLARRAYHEIGHT
    lblFieldName(i).Visible = True
    Load txtFieldData(i)
    txtFieldData(i).Top = txtFieldData(i - 1).Top + gnCTLARRAYHEIGHT
    txtFieldData(i).Visible = True
    nFieldType = mrsFormRecordset.Fields(i).Type
    txtFieldData(i).Width = GetFieldWidth(nFieldType)
    If nFieldType = dbText Then txtFieldData(i).MaxLength = mrsFormRecordset(i).Size
    txtFieldData(i).TabIndex = i
  Next
  Me.Width = 5580
  If i <= 10 Then
    Me.Height = ((i + 1) * gnCTLARRAYHEIGHT) + 1600
  Else
    Me.Height = 4368
    Me.Width = Me.Width + 260
    vsbScrollBar.Visible = True
    vsbScrollBar.Min = 1080
    vsbScrollBar.Max = 1080 - (i * gnCTLARRAYHEIGHT) + 2240
  End If
  For i = 0 To mrsFormRecordset.Fields.Count - 1
    lblFieldName(i).Caption = mrsFormRecordset(i).Name & ":"
  Next
  DisplayCurrentRecord Me, mrsFormRecordset, mlNumRows, mbAddNewFlag
  mbDataChanged = False
  Me.Left = 1000
  Me.Top = 1000
  MsgBar vbNullString, False
  Exit Sub
DynasetErr:
  ShowError
  Unload Me
End Sub
Private Sub Form_Resize()
  On Error Resume Next
  Dim nHeight As Integer
  Dim i As Integer
  Dim nTotWidth As Integer
  Const nHeightFactor = 1420
  If WindowState <> 1 Then   '
    MsgBar MSG12, True
    '
    nHeight = Height
    If (nHeight - nHeightFactor) Mod gnCTLARRAYHEIGHT <> 0 Then
      Me.Height = ((nHeight - nHeightFactor) \ gnCTLARRAYHEIGHT) * gnCTLARRAYHEIGHT + nHeightFactor
    End If
    '
    picMoveButtons.Top = Me.Height - 650
    '
    vsbScrollBar.Height = picMoveButtons.Top - (picViewButtons.Top - picFldHdr.Height) - 1320
    vsbScrollBar.Left = Me.Width - 360
    If mrsFormRecordset.Fields.Count > 10 Then
      picFields.Width = Me.Width - 260
      nTotWidth = vsbScrollBar.Left - 20
    Else
      picFields.Width = Me.Width - 20
      nTotWidth = Me.Width - 50
    End If
    picFldHdr.Width = Me.Width - 20
    '
    For i = 0 To mrsFormRecordset.Fields.Count - 1
      lblFieldName(i).Width = 0.3 * nTotWidth
      txtFieldData(i).Left = lblFieldName(i).Width + 20
      If mrsFormRecordset(i).Type = dbText Or mrsFormRecordset(i).Type = dbMemo Then
        txtFieldData(i).Width = 0.7 * nTotWidth - 250
      End If
    Next
    lblFieldValue.Left = txtFieldData(0).Left
    hsclCurrRow.Width = picMoveButtons.Width \ 2
    lblStatus.Width = picMoveButtons.Width \ 2
    lblStatus.Left = hsclCurrRow.Width + 10
  End If
  MsgBar vbNullString, False
End Sub
Private Sub Form_Unload(Cancel As Integer)
  On Error Resume Next
  Unload mfrmFind   '
  mrsFormRecordset.Close          '
  DBEngine.Idle dbFreeLocks
  MsgBar vbNullString, False
End Sub
Private Sub cmdSort_Click()
  On Error GoTo SortErr
  Dim sBookMark As String
  Dim recRecordset1 As Recordset, recRecordset2 As Recordset
  Dim SortStr As String
  If mrsFormRecordset.RecordCount = 0 Then Exit Sub
  sBookMark = mrsFormRecordset.Bookmark        '
  Set recRecordset1 = mrsFormRecordset            '
  SortStr = InputBox(MSG13)
  If Len(SortStr) = 0 Then Exit Sub
  Screen.MousePointer = vbHourglass
  MsgBar MSG14, True
  mrsFormRecordset.Sort = SortStr
  Set recRecordset2 = mrsFormRecordset.OpenRecordset(mrsFormRecordset.Type)
  Set mrsFormRecordset = recRecordset2            '
 recordset
  mlNumRows = mrsFormRecordset.RecordCount
  hsclCurrRow.Value = 0
  DisplayCurrentRecord Me, mrsFormRecordset, mlNumRows, mbAddNewFlag
  mbDataChanged = False
  Screen.MousePointer = vbDefault
  MsgBar vbNullString, False
  Exit Sub
SortRecover:
  On Error Resume Next
  Set mrsFormRecordset = recRecordset1            '
  mrsFormRecordset.Bookmark = sBookMark        '
  Exit Sub
SortErr:
  ShowError
  Resume SortRecover
End Sub
Private Sub cmdUpdate_Click()
  On Error GoTo UpdateErr
  Dim nDelay As Long
  Dim nRetryCnt As Integer
  Screen.MousePointer = vbHourglass
RetryUpd:
  mrsFormRecordset.Update
  If gbTransPending Then gbDBChanged = True
  If mbAddNewFlag Then
    mlNumRows = mlNumRows + 1
    SetScrollBar
    '
    mrsFormRecordset.Bookmark = mrsFormRecordset.LastModified
  End If
  picChangeButtons.Visible = False
  picViewButtons.Visible = True
  hsclCurrRow.Enabled = True
  mbEditFlag = False
  mbAddNewFlag = False
  DisplayCurrentRecord Me, mrsFormRecordset, mlNumRows, mbAddNewFlag
  mbDataChanged = False
  DBEngine.Idle dbFreeLocks
  Screen.MousePointer = vbDefault
  Exit Sub
UpdateErr:
  If Err = 3260 And nRetryCnt < gnMURetryCnt Then
    nRetryCnt = nRetryCnt + 1
    mrsFormRecordset.Bookmark = mrsFormRecordset.Bookmark   '
    DBEngine.Idle dbFreeLocks
    nDelay = Timer
    '
 gnMUDelay
    While Timer - nDelay < gnMUDelay
      '
    Wend
    Resume RetryUpd
  Else
    ShowError
  End If
End Sub
Private Sub SetScrollBar()
  On Error Resume Next
  If mlNumRows < 2 Then
    hsclCurrRow.Max = 100
    hsclCurrRow.SmallChange = 1 '00
    hsclCurrRow.LargeChange = 100
  ElseIf mlNumRows > 32767 Then
    hsclCurrRow.Max = 32767
    hsclCurrRow.SmallChange = 1
    hsclCurrRow.LargeChange = 1000
  ElseIf mlNumRows > 99 Then
    hsclCurrRow.Max = mlNumRows
    hsclCurrRow.SmallChange = 1
    hsclCurrRow.LargeChange = mlNumRows \ 20
  Else
    '
 100
    hsclCurrRow.Max = 100
    hsclCurrRow.SmallChange = 100 \ (mlNumRows - 1)
    hsclCurrRow.LargeChange = (100 \ (mlNumRows - 1)) * 10
  End If
  txtFieldData(0).SetFocus
  hsclCurrRow.SetFocus
End Sub