On Hand/On_Hand_From_Softbank_1994_Release_2_Disc_2_1994.iso/00202/s/disk4/dataform.fr_/dataform.bin

Text File | 1993-04-28 | 21KB | 854 lines

VERSION 2.00
Begin Form fDataForm
   BackColor       =   &H00C0C0C0&
   ClientHeight    =   2520
   ClientLeft      =   1815
   ClientTop       =   3000
   ClientWidth     =   5700
   Height          =   2925
   Icon            =   DATAFORM.FRX:0000
   Left            =   1755
   LinkTopic       =   "Form2"
   MDIChild        =   -1  'True
   ScaleHeight     =   2520
   ScaleWidth      =   5700
   Tag             =   "Dynaset"
   Top             =   2655
   Width           =   5820
   Begin CommonDialog CMD1
      Left            =   4800
      Top             =   1800
   End
   Begin PictureBox StatBox
      Align           =   2  'Align Bottom
      BackColor       =   &H00C0C0C0&
      BorderStyle     =   0  'None
      Height          =   270
      Left            =   0
      ScaleHeight     =   282.462
      ScaleMode       =   0  'User
      ScaleWidth      =   5710.271
      TabIndex        =   6
      Top             =   2250
      Width           =   5700
      Begin Data Data1
         Connect         =   ""
         DatabaseName    =   ""
         Exclusive       =   0   'False
         Height          =   270
         Left            =   0
         Options         =   0
         ReadOnly        =   0   'False
         RecordSource    =   ""
         Top             =   0
         Width           =   5475
      End
   End
   Begin VScrollBar cScrollBar
      Height          =   2085
      LargeChange     =   3000
      Left            =   7665
      SmallChange     =   300
      TabIndex        =   15
      Top             =   630
      Visible         =   0   'False
      Width           =   255
   End
   Begin PictureBox cFields
      BackColor       =   &H00C0C0C0&
      BorderStyle     =   0  'None
      Height          =   1065
      Left            =   0
      ScaleHeight     =   1056.48
      ScaleMode       =   0  'User
      ScaleWidth      =   7600.262
      TabIndex        =   10
      TabStop         =   0   'False
      Top             =   630
      Width           =   7605
      Begin TextBox cFieldData
         BackColor       =   &H00FFFFFF&
         DataSource      =   "Data1"
         ForeColor       =   &H00000000&
         Height          =   285
         Index           =   0
         Left            =   1665
         TabIndex        =   13
         Top             =   0
         Visible         =   0   'False
         Width           =   3255
      End
      Begin CheckBox cFieldCheck
         BackColor       =   &H00C0C0C0&
         DataSource      =   "Data1"
         Height          =   282
         Index           =   0
         Left            =   1680
         TabIndex        =   12
         Top             =   735
         Visible         =   0   'False
         Width           =   3270
      End
      Begin PictureBox cFieldPicture
         DataSource      =   "Data1"
         Height          =   282
         Index           =   0
         Left            =   1680
         ScaleHeight     =   255
         ScaleWidth      =   3240
         TabIndex        =   11
         Top             =   315
         Visible         =   0   'False
         Width           =   3270
      End
      Begin Label cFieldName
         BackColor       =   &H00C0C0C0&
         ForeColor       =   &H00000000&
         Height          =   255
         Index           =   0
         Left            =   105
         TabIndex        =   14
         Top             =   0
         Visible         =   0   'False
         Width           =   1575
      End
   End
   Begin PictureBox FieldHeader
      Align           =   1  'Align Top
      BackColor       =   &H00C0C0C0&
      BorderStyle     =   0  'None
      Height          =   300
      Left            =   0
      ScaleHeight     =   300
      ScaleMode       =   0  'User
      ScaleWidth      =   5703.403
      TabIndex        =   7
      Top             =   330
      Width           =   5700
      Begin Label FieldValueLabel
         BackColor       =   &H00C0C0C0&
         Caption         =   " Value:"
         Height          =   252
         Left            =   1680
         TabIndex        =   9
         Top             =   30
         Width           =   2652
      End
      Begin Label FieldHdrLabel
         BackColor       =   &H00C0C0C0&
         Caption         =   "Field Name:"
         Height          =   252
         Left            =   120
         TabIndex        =   8
         Top             =   30
         Width           =   1212
      End
   End
   Begin PictureBox TopPic
      Align           =   1  'Align Top
      BackColor       =   &H00C0C0C0&
      BorderStyle     =   0  'None
      Height          =   330
      Left            =   0
      ScaleHeight     =   330
      ScaleWidth      =   5700
      TabIndex        =   0
      Top             =   0
      Width           =   5700
      Begin CommandButton CancelAddBtn
         Caption         =   "C&ancel"
         Height          =   330
         Left            =   0
         TabIndex        =   17
         Top             =   0
         Visible         =   0   'False
         Width           =   960
      End
      Begin CommandButton RefreshBtn
         Caption         =   "&Refresh"
         Height          =   330
         Left            =   3780
         TabIndex        =   16
         Top             =   0
         Width           =   960
      End
      Begin CommandButton FindBtn
         Caption         =   "&Find"
         Height          =   330
         Left            =   2835
         TabIndex        =   5
         Top             =   0
         Width           =   960
      End
      Begin CommandButton CloseBtn
         Cancel          =   -1  'True
         Caption         =   "&Close"
         Height          =   330
         Left            =   4725
         TabIndex        =   4
         Top             =   0
         Width           =   960
      End
      Begin CommandButton DeleteBtn
         Caption         =   "&Delete"
         Height          =   330
         Left            =   1890
         TabIndex        =   3
         Top             =   0
         Width           =   960
      End
      Begin CommandButton AddBtn
         Caption         =   "&Add"
         Height          =   330
         Left            =   0
         TabIndex        =   2
         Top             =   0
         Width           =   960
      End
      Begin CommandButton UpdateBtn
         Caption         =   "&Update"
         Height          =   330
         Left            =   945
         TabIndex        =   1
         Top             =   0
         Width           =   960
      End
   End
End
'============================================================================
' This is a fairly generic form that can be used in most cases with any
' table. I am sorry if it is confusing. There is a lot of paths to
' keep track on with adding, editing, browsing, deleting records
' on populated as well as empty tables. I have added flags where I
' felt there was no other way to achieve the correct functionality.
' I am sure that you can improve this form greatly with a little
' time and understanding of your spcific needs. There is also some
' recursion that could be trapped but hopefully, the form will be
' a good starting point for any data control app.
'============================================================================

Dim FldArr() As control

Dim FDS As dynaset
Dim FBM As String                  'form global bookmark
Dim numFlds As Integer
Dim CurrField As Integer
Dim CurrRec As Long
Dim TotRec As Long
Dim JustUsedFind As Integer        'flag for find function
Dim fResizing As Integer           'flag to avoid resize recursion
Dim CancelFlag As Integer          'flag to cancel an addnew

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.Recordset.AddNew
  Data1.Caption = "New Record"
  CancelAddBtn.Visible = True
  AddBtn.Visible = False
  If Data1.Recordset.RecordCount <> 0 Then
    FBM = Data1.Recordset.Bookmark
    FldArr(0).SetFocus
  End If

  GoTo AddEnd

AddErr:
  MsgBox Error$
  Resume AddEnd

AddEnd:

End Sub

Sub CancelAddBtn_Click ()
  On Error Resume Next

  CancelFlag = True
  If FBM <> "" Then
    Data1.Recordset.Bookmark = FBM
  End If
  If FDS.RecordCount > 0 Then
    SetRecNum
  End If

End Sub

Sub cFieldData_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

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

  CMD1.Filter = "Bitmaps (*.bmp)|*.bmp|Icons (*.ico)|*.ico|Metafiles (*.wmf)|*.wmf|All Files (*.*)|*.*"
  CMD1.DialogTitle = "Select a Picture File to Load"
  CMD1.FilterIndex = 1
  CMD1.Action = 1

  If CMD1.Filename <> "" Then
    cFieldPicture(Index).Picture = LoadPicture(CMD1.Filename)
  End If

  GoTo PicEnd

PicErr:
  MsgBox Error$
  Resume PicEnd

PicEnd:

End Sub

Sub CloseBtn_Click ()
  On Error Resume Next
  Unload Me
End Sub

Sub cScrollBar_Change ()
  Dim t As Integer

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

End Sub

Sub Data1_Error (DataErr As Integer, Response As Integer)
  MsgBox "Data error event hit err:" + Error$(DataErr)
End Sub

Sub Data1_RePosition ()
  Dim bm As String
  Dim ds As dynaset

  If Data1.Recordset.RecordCount = 0 And Data1.EditMode <> 2 Then
    Call AddBtn_Click
    Exit Sub
  End If

  If JustUsedFind = True Then
    Set ds = Data1.Recordset.Clone()
    bm = Data1.Recordset.Bookmark
    ds.MoveFirst
    CurrRec = 1
    While ds.Bookmark <> bm
      CurrRec = CurrRec + 1
      ds.MoveNext
    Wend
    JustUsedFind = False
  End If
  SetRecNum

End Sub

Sub Data1_Validate (Action As Integer, Save As Integer)
  On Error GoTo ValErr

  If CancelFlag Then
    Save = False
    CancelFlag = 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 Data1.EditMode = EM_ADDNEW Then
        If MsgBox("Save New Record?", MSGBOX_TYPE) = YES Then
          TotRec = TotRec + 1
        Else
          Save = False
        End If
      Else
        If MsgBox("Commit Changes?", MSGBOX_TYPE) <> YES Then
          Save = False        'loose changes
        End If
      End If
    End If
    SetRecNum
  End If

  Select Case Action
    Case 1          'First
      CurrRec = 1

    Case 2          'Previous
      If CurrRec = 1 Then Beep
      If CurrRec <> 1 Then CurrRec = CurrRec - 1

    Case 3          'Next
      If CurrRec = TotRec Then Beep
      If CurrRec <> TotRec Then CurrRec = CurrRec + 1

    Case 4          'Last
      CurrRec = TotRec

    Case 5          'AddNew
      'do nothing

    Case 6          'Update
      If Save = True Then
        If Data1.EditMode = EM_ADDNEW Then
          If MsgBox("Save New Record?", MSGBOX_TYPE) = YES Then
            TotRec = TotRec + 1
          Else
            Save = False
          End If
        Else
          If MsgBox("Commit Changes?", MSGBOX_TYPE) <> YES Then
            Save = False
          End If
        End If
      End If

    Case 7          'Delete
      TotRec = TotRec - 1
      SetRecNum

    Case 8
      'set the flag for use in the reposition event
      JustUsedFind = True

    Case 9          'BookMark
      'do nothing"

    Case 10          'Close
      If Save = True Then
        If MsgBox("Commit Changes before Closing?", MSGBOX_TYPE) <> YES Then
          Save = False
        End If
      End If

  End Select

  GoTo ValEnd

ValErr:
  ShowError
  Resume ValEnd

ValEnd:

End Sub

Sub DeleteBtn_Click ()
  On Error GoTo DelErr

  If MsgBox("Delete Current Record?", MSGBOX_TYPE) = YES Then
    Data1.Recordset.Delete
    Data1.Recordset.MoveNext
    FldArr(0).SetFocus
  End If

  GoTo DelEnd

DelErr:
  MsgBox Error$
  Resume DelEnd

DelEnd:

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 Data1.Recordset.RecordCount > 0 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:
  FldArr(0).SetFocus

End Sub

Sub Form_Load ()
  Dim ds2 As dynaset
  Dim Start, Finish

  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 gstDataType <> "ODBC" Then
    Data1.DatabaseName = gCurrentDB.Name
  End If
  Data1.Connect = gCurrentDB.Connect
  'determine if a table name or sql statement is used
  If gfFromSQL = True Then
    If gstDynaString = "" Then
      Data1.RecordSource = fSQL.cSQLStatement
    Else
      Data1.RecordSource = gstDynaString
    End If
    Caption = "Dynaset: SQL Statement"
  Else
    Data1.RecordSource = fTables.cTableList
    Caption = "Dynaset: " + UCase(fTables.cTableList)
  End If
  '-------------------------------------------------------
  If gfFromSQL = True And fSQL.cPassThru = 1 Then
    Data1.Options = VBDA_SQLPASSTHROUGH
  End If

  Start = Timer
  Data1.Refresh

  CurrRec = 1
  Set ds2 = Data1.Recordset.Clone()
  If ds2.BOF = False Then
    ds2.MoveLast
    TotRec = ds2.RecordCount
  Else
    TotRec = 0
  End If
  ds2.Close

  Width = 5805
  LoadFields
  Me.Show
  FldArr(0).SetFocus
  SetRecNum

  Finish = Timer
  If VDMDI.PrefShowPerf.Checked Then
    MsgBox CStr(TotRec) + " rows found in " + CStr(Finish - Start) + " seconds!", 48
  End If

  GoTo LoadEnd

LoadErr:
  ShowError
  Unload Me
  Resume LoadEnd

LoadEnd:

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 - 1320) Mod 300 <> 0 Then
      Height = ((h - 1320) \ 300) * 300 + 1320
    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
    For i = 0 To FDS.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 ()
   Dim t As dynaset
   Dim ds As String        'temp dynaset name string

   Dim ft As Integer
   Dim i As Integer

   On Error GoTo LoadFieldsErr

   Set FDS = Data1.Recordset
   Set t = FDS

   'load the controls on the dynaset form
   numFlds = t.Fields.Count
   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 + 300
     Load cFieldName(i)
     cFieldName(i).Top = cFieldName(i - 1).Top + 300
     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 + 300
     FldArr(i).Visible = True
     FldArr(i).Width = GetFieldWidth(ft)
     FldArr(i).TabIndex = i
   Next

   On Error GoTo LoadFieldsErr

   'resize main window
   cFields.Top = FieldHeader.Top + FieldHeader.Height
   FldTop = cFields.Top
   cScrollBar = FldTop
   If i <= 10 Then
     Height = i * 300 + 1500
     cScrollBar.Visible = False
   Else
     Height = 4500
     Width = Width + 260
     cScrollBar.Visible = True
     cScrollBar.Min = FldTop
     cScrollBar.Max = FldTop - (i * 300) + 3000
   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 ()
  On Error GoTo RefErr

  Data1.Refresh
  GoTo RefEnd

RefErr:
  ShowError
  Resume RefEnd

RefEnd:

End Sub

Sub SetRecNum ()
  If Data1.EditMode <> 2 Then
    If Data1.Recordset.BOF = True Then
      Data1.Caption = "Record BOF of " & TotRec
    ElseIf Data1.Recordset.EOF = True Then
      Data1.Caption = "Record EOF of " & TotRec
    Else
      Data1.Caption = "Record " & CurrRec & " of " & TotRec
    End If
  End If

  'reset buttons if needed
  If Data1.EditMode <> 2 Then
    CancelAddBtn.Visible = False
    AddBtn.Visible = True
  End If

End Sub

Sub UpdateBtn_Click ()
  On Error GoTo UpdErr
  Dim addflag As Integer

  addflag = Data1.EditMode
  Data1.Recordset.Update
  If addflag = 2 Then
    FDS.MoveLast
  End If

  GoTo UpdEnd

UpdErr:
  ShowError
  Resume UpdEnd

UpdEnd:

End Sub