Programming Tool Box/SIMS_2.iso/bp_6_93/bonus/dmsrc/dataform.txt

Text File | 1995-02-26 | 13KB | 535 lines

Dim FldArr() As control

Dim FDS As Dynaset
Dim numFlds As Integer
Dim CurrField As Integer
Dim JustUsedFind As Integer        'flag for find function
Dim fResizing As Integer           'flag to avoid resize recursion

Dim FldTop As Integer

Const EM_NOTHING = 0
Const EM_EDIT = 1
Const EM_ADDNEW = 2

Const FT_TRUEFALSE = 1
Const FT_BYTE = 2
Const FT_INTEGER = 3
Const FT_LONG = 4
Const FT_CURRENCY = 5
Const FT_SINGLE = 6
Const FT_DOUBLE = 7
Const FT_DATETIME = 8
Const FT_STRING = 10
Const FT_BINARY = 11
Const FT_MEMO = 12

Const YES = 6
Const MSGBOX_TYPE = 4 + 48

Sub AddBtn_Click ()
  On Error GoTo AddErr

    data1.Caption = "Entering New Record"
  If AddBtn.Tag = "Disabled" Then
    EnableAllControls
  End If
  data1.Recordset.AddNew
  FldArr(0).SetFocus
  Exit Sub

AddErr:
  MsgBox Error$
  Resume AddEnd
AddEnd:

End Sub

Sub cFieldPicture_Click (Index As Integer)
  'this toggles the size of a picture control
  'so it mat be viewed or compressed
  If cFieldPicture(Index).Height <= 280 Then
    cFieldPicture(Index).AutoSize = True
  Else
    cFieldPicture(Index).AutoSize = False
    cFieldPicture(Index).Height = 280
  End If
End Sub

Sub cFieldPicture_DblClick (Index As Integer)
  On Error GoTo PicErr

  st = InputBox("Enter Picture FilName:")
  If st <> "" Then
    cFieldPicture(Index).Picture = LoadPicture(st)
  End If

  GoTo PicEnd

PicErr:
  MsgBox Error$
  Resume PicEnd

PicEnd:

End Sub

Sub cScrollBar_Change ()
  Dim t As Integer

  t = cScrollBar
  If (t - FldTop) Mod 350 = 0 Then
    cFields.Top = t
  Else
    cFields.Top = ((t - FldTop) \ 350) * 350 + FldTop
  End If

End Sub

Sub Data1_Error (dataerr As Integer, response As Integer)
  If dataerr = 3021 Then
    response = 0
  ElseIf dataerr = 481 Or dataerr = 321 Then 'Invalid picture
    response = 0
  Else
    MsgBox "Error:  " + Error$(dataerr)
    response = 0
  End If
End Sub

Sub data1_Reposition ()
    'if not valid record and not in addnew mode
    If (data1.Recordset.BOF Or data1.Recordset.EOF) And data1.Caption <> "Entering New Record" Then
        DisableAllControls
    'otherwise, if form is disabled, then enable it
    ElseIf AddBtn.Tag = "Disabled" Then
        EnableAllControls
    Else
       If data1.Caption <> "Entering New Record" Then data1.Caption = "Editing Record"
    End If
End Sub

Sub Data1_Validate (Action As Integer, save As Integer)
On Error Resume Next
  'first check for a move from an addnew or edit record
  If Action < 5 Then
    If save = True Then      'data changed
      If data1.EditMode = EM_ADDNEW Then
        If MsgBox("Save New Record?", MSGBOX_TYPE) = YES Then
          data1.UpdateRecord
          If Err <> 0 Then
            MsgBox Error$, 0, "Data Manager"
            Action = 0: save = 0
          End If
          save = 0
        Else
            save = 0
        End If
      ElseIf MsgBox("Commit Changes?", MSGBOX_TYPE) <> YES Then
         save = False        'loose changes
      End If
    End If
  data1.Caption = "Editing Record"
  End If

  Select Case Action
    Case 1          'First
    Case 6          'Update
      If save = True Then
        If data1.EditMode = EM_ADDNEW Then
          If MsgBox("Save New Record?", MSGBOX_TYPE) = YES Then
            data1.UpdateRecord
            data1.Caption = "Editing Record"
          Else
            save = 0: Action = 0
          End If
        ElseIf MsgBox("Commit Changes?", MSGBOX_TYPE) = YES Then
          data1.UpdateRecord
        End If
      End If

    Case 10          'Close
      If save = True Then
        If MsgBox("Commit Changes before Closing?", MSGBOX_TYPE) = YES Then
        Else
          Cancel = True
        End If
      End If

  End Select


End Sub

Sub DeleteBtn_Click ()
  On Error GoTo DelErr

  If MsgBox("Delete Current Record?", MSGBOX_TYPE) = YES Then
    data1.Recordset.Delete
    data1.Recordset.MoveNext
    If AddBtn.Tag <> "Disabled" Then FldArr(0).SetFocus
  End If

  GoTo DelEnd

DelErr:
    If Err = 444 Then
        MsgBox "Can't delete this record.", 64, "Data Manager"
    ElseIf Err = 3021 Then
        DisableAllControls
    Else
        MsgBox Error$, 64, "Data Manager"
    End If
    If AddBtn.Tag <> "Disabled" Then FldArr(0).SetFocus
  Resume DelEnd

DelEnd:

End Sub

Sub DisableAllControls ()

    On Error GoTo disableerror
    'This handles the case of calls with empty tables before
    'call of loadfields.  Otherwise, you get subscript out of range.

   Dim i As Integer
   DeleteBtn.Enabled = False
   UpdateBtn.Enabled = False
'   FindBtn.Enabled = False
   For i = 0 To data1.Recordset.Fields.Count - 1
     FldArr(i).Visible = False
   Next i

    GoTo disableend
disableerror:
    Resume disableend
disableend:
   AddBtn.Tag = "Disabled"
   data1.Caption = "No Current Record"

End Sub

Sub EnableAllControls ()

   Dim i As Integer
   DeleteBtn.Enabled = True
   UpdateBtn.Enabled = True
'   FindBtn.Enabled = True

   For i = 0 To data1.Recordset.Fields.Count - 1
     FldArr(i).Visible = True
   Next i
   AddBtn.Tag = "Enabled"
   If data1.Caption <> "Entering New Record" Then
    data1.Caption = "Editing Record"
   End If
End Sub

Sub FindBtn_Click ()
  On Error GoTo FindErr
  Dim bm As String, findstr As String

  findstr = InputBox("Enter Search Expression:")
  If findstr = "" Then Exit Sub

  If Not data1.Recordset.BOF And Not data1.Recordset.EOF Then
    bm = data1.Recordset.Bookmark
  End If

  data1.Recordset.FindFirst findstr

  'return to old record if no match was found
  If data1.Recordset.NoMatch And bm <> "" Then
    data1.Recordset.Bookmark = bm
  End If

  GoTo FindEnd

FindErr:
  MsgBox Error$
  Resume FindEnd

FindEnd:
  If FldArr(0).Visible = True Then FldArr(0).SetFocus

End Sub

Sub Form_Load ()
  Dim ds2 As Dynaset

  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 mainform controls
  '-------------------------------------------------------
  Screen.MousePointer = 11 'wait cursor
  data1.DatabaseName = gDatabaseName
  data1.Connect = gDatabase.Connect
  Me.Caption = UCase(gDatabaseName) + " : " + UCase(mainForm.TableName)
  data1.RecordSource = mainForm.TableName
  '-------------------------------------------------------
  data1.Refresh

  LoadFields data1.Recordset, mainForm.TableName
  data1_Reposition 'This ensures that we enable the controls
  Me.Show
  If AddBtn.Tag = "Enabled" Then
    FldArr(0).SetFocus
  End If
  GoTo loadend
LoadErr:

  MsgBox Error$
  Unload Me
  Resume loadend

loadend:
  Screen.MousePointer = 0
End Sub

Sub Form_Resize ()
  On Error Resume Next

  If fResizing = True Then Exit Sub

  Dim h As Integer, i As Integer
  Dim totw As Integer

  fResizing = True
  If WindowState <> 1 And cFieldName(0).Visible = True Then 'not minimized
    'make sure the form is lined up on a field
    h = Height
    If (h - 1340) Mod 350 <> 0 Then
      Height = ((h - 1340) \ 350) * 350 + 1340
    End If
    'reset scroll
    If Height - 1340 >= cFields.Height - 1065 + 350 Then
        cScrollBar.Visible = False
    Else
        cScrollBar.Max = cScrollBar.Min + 350 * ((Height - 1340) \ 350) - (cFields.Height - 1065 + 350)
        cScrollBar.Visible = True
    End If
    'resize the status bar
    StatBox.Top = Height - 650
    'resize the scrollbar
    cScrollBar.Height = StatBox.Top - (FieldHeader.Top - FieldHeader.Height) - 600
    cScrollBar.Left = Width - 360
    If FDS.Fields.Count > 10 Then
      cFields.Width = Width - 260
      totw = cScrollBar.Left - 20
    Else
      cFields.Width = Width - 20
      totw = Width - 50
    End If
    FieldHeader.Width = Width - 20
    'widen the fields if possible
'    data1.Database.TableDefs(TableName).Fields.Refresh
'    For i = 0 To data1.Recordset.Fields.Count - 1
'      cFieldName(i).Width = .3 * totw
'       FldArr(i).Left = cFieldName(i).Width + 20
'      If data1.Recordset.Fields(i).Type > 9 Then
'        FldArr(i).Width = .7 * totw - 270
'      End If
'    Next
    FieldValueLabel.Left = FldArr(0).Left
  End If

  data1.Width = StatBox.Width
  fResizing = False

End Sub

Function GetFieldWidth (t As Integer)
  'determines the form control width
  'based on the field type
  Select Case t
    Case FT_TRUEFALSE
      GetFieldWidth = 850
    Case FT_BYTE
      GetFieldWidth = 650
    Case FT_INTEGER
      GetFieldWidth = 900
    Case FT_LONG
      GetFieldWidth = 1100
    Case FT_CURRENCY
      GetFieldWidth = 1800
    Case FT_SINGLE
      GetFieldWidth = 1800
    Case FT_DOUBLE
      GetFieldWidth = 2200
    Case FT_DATETIME
      GetFieldWidth = 2000
    Case FT_STRING
      GetFieldWidth = 3250
    Case FT_MEMO
      GetFieldWidth = 3250
    Case Else
      GetFieldWidth = 3250
  End Select

End Function

Sub LoadFields (t As Dynaset, tName)

'   Dim t As table
   Dim ft As Integer
   Dim i As Integer

   On Error GoTo LoadFieldsErr

'   Set t = db.OpenTable(tName)

   'load the controls on the dynaset form
   numFlds = t.Fields.Count

    If numFlds = 0 Then
        MsgBox "There are no fields in this table.  Cannot Edit Table Data", 64, "Data Manager"
        Unload Me
    End If

   ReDim FldArr(numFlds) As control
   cFieldName(0).Visible = True
   ft = t.Fields(0).Type
   If ft = FT_TRUEFALSE Then
     Set FldArr(0) = cFieldCheck(0)
   ElseIf ft = FT_BINARY Then
     Set FldArr(0) = cFieldPicture(0)
   Else
     Set FldArr(0) = cFieldData(0)
   End If
   FldArr(0).Visible = True
   FldArr(0).Top = 0
   FldArr(0).Width = GetFieldWidth(ft)
   FldArr(0).TabIndex = 0

   On Error Resume Next
   For i = 1 To t.Fields.Count - 1
     cFields.Height = cFields.Height + 350
     Load cFieldName(i)
     cFieldName(i).Top = cFieldName(i - 1).Top + 350
     cFieldName(i).Visible = True
     ft = t.Fields(i).Type
     If ft = FT_TRUEFALSE Then
       Load cFieldCheck(i)
       Set FldArr(i) = cFieldCheck(i)
     ElseIf ft = FT_BINARY Then
       Load cFieldPicture(i)
       Set FldArr(i) = cFieldPicture(i)
     Else
       Load cFieldData(i)
       Set FldArr(i) = cFieldData(i)
     End If
     FldArr(i).Top = FldArr(i - 1).Top + 350
     FldArr(i).Width = GetFieldWidth(ft)
     FldArr(i).TabIndex = i
   Next
   AddBtn.Tag = "Disabled"

   On Error GoTo LoadFieldsErr

   'resize main window
   cFields.Top = FieldHeader.Top + FieldHeader.Height
   FldTop = cFields.Top
   cScrollBar.Min = FldTop
   If i <= 10 Then
     Height = i * 350 + 1500
     cScrollBar.Visible = False
   Else
     Height = 5000
     Width = Width + 260
     cScrollBar.Visible = True
     cScrollBar.Max = FldTop - (i * 350) + 3500
     cScrollBar = FldTop
   End If

   'display the field names
   For i = 0 To t.Fields.Count - 1
     cFieldName(i) = UCase(t.Fields(i).Name) + ":"
   Next

   'bind the controls
   On Error Resume Next   'bind even if table is empty
   For i = 0 To t.Fields.Count - 1
     FldArr(i).DataField = t.Fields(i).Name
   Next

   GoTo LoadFieldsEnd

LoadFieldsErr:
   MsgBox Error$
   Resume LoadFieldsEnd

LoadFieldsEnd:

End Sub

Sub MoveBtn_Click (Index As Integer)
  On Error GoTo moveerr
  Dim bm As String

  If Not data1.Recordset.BOF And Not data1.Recordset.EOF Then
    bm = data1.Recordset.Bookmark
  End If
  Select Case Index
    Case 0
      If findval <> "" Then
        data1.Recordset.FindFirst findval
      Else
        data1.Recordset.MoveFirst
      End If
    Case 1
      If findval <> "" Then
        data1.Recordset.FindPrevious findval
      Else
        data1.Recordset.MovePrevious
      End If
    Case 2
      If findval <> "" Then
        data1.Recordset.FindNext findval
      Else
        data1.Recordset.MoveNext
      End If
    Case 3
      If findval <> "" Then
        data1.Recordset.FindLast findval
      Else
        data1.Recordset.MoveLast
      End If
  End Select
  'return to old record if no match was found
  If data1.Recordset.NoMatch And bm <> "" Then
    data1.Recordset.Bookmark = bm
  End If

  GoTo moveend

moveerr:
  MsgBox Error$
  Resume moveend

moveend:
  FldArr(0).SetFocus
End Sub

Sub RefreshBtn_Click ()
  data1.Refresh
End Sub

Sub UpdateBtn_Click ()
  On Error GoTo UpdErr

  data1.Recordset.Update

  GoTo UpdEnd
UpdErr:
  MsgBox Error$
  Resume UpdEnd

UpdEnd:

End Sub