Visual Basic Source Code/Visual Basic Source Code.iso/vbsource/vbdb/definedb.frm

Visual Basic Form | 1995-09-06 | 20.0 KB | 667 lines

VERSION 2.00
Begin Form DefineDatabase
   BorderStyle     =   3  'Fixed Double
   Caption         =   "Define Database"
   ClientHeight    =   3930
   ClientLeft      =   2040
   ClientTop       =   1905
   ClientWidth     =   5760
   ControlBox      =   0   'False
   Height          =   4335
   Left            =   1980
   LinkMode        =   1  'Source
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   3930
   ScaleWidth      =   5760
   Top             =   1560
   Width           =   5880
   Begin CommandButton Command2
      Caption         =   "E&xit"
      Height          =   372
      Left            =   1920
      TabIndex        =   12
      Top             =   3480
      Width           =   972
   End
   Begin CommandButton Command1
      Caption         =   "C&reate Database"
      Height          =   372
      Left            =   120
      TabIndex        =   11
      Top             =   3480
      Width           =   1572
   End
   Begin TextBox Text1
      BackColor       =   &H00C0C0C0&
      Enabled         =   0   'False
      Height          =   732
      Left            =   -120
      TabIndex        =   23
      Top             =   3360
      Width           =   6012
   End
   Begin Frame Fields
      Caption         =   "Fields"
      Height          =   2292
      Left            =   4080
      TabIndex        =   13
      Top             =   960
      Width           =   1572
      Begin CommandButton Chk_Fld
         Caption         =   "&Validate"
         Height          =   372
         Left            =   360
         TabIndex        =   17
         Top             =   1800
         Width           =   852
      End
      Begin CommandButton Clear_Fld
         Caption         =   "&Clear"
         Height          =   372
         Left            =   360
         TabIndex        =   16
         Top             =   1320
         Width           =   852
      End
      Begin CommandButton Last_Fld
         Caption         =   "&Last"
         Height          =   372
         Left            =   360
         TabIndex        =   15
         Top             =   840
         Width           =   852
      End
      Begin CommandButton Next_Fld
         Caption         =   "&Next"
         Height          =   372
         Left            =   360
         TabIndex        =   14
         Top             =   360
         Width           =   852
      End
   End
   Begin Frame Frame1
      Caption         =   "Define Fields"
      Height          =   2292
      Left            =   120
      TabIndex        =   0
      Top             =   960
      Width           =   3852
      Begin TextBox Fld_Dec
         Enabled         =   0   'False
         Height          =   372
         Left            =   2040
         TabIndex        =   8
         Top             =   1680
         Width           =   612
      End
      Begin TextBox Fld_Log
         Enabled         =   0   'False
         Height          =   372
         Left            =   1320
         TabIndex        =   9
         Top             =   1680
         Width           =   612
      End
      Begin TextBox Fld_Len
         Height          =   372
         Left            =   2040
         TabIndex        =   5
         Top             =   1200
         Width           =   612
      End
      Begin TextBox WhichFld
         Height          =   372
         Left            =   1320
         TabIndex        =   19
         Text            =   "1"
         Top             =   1200
         Width           =   612
      End
      Begin ComboBox Fld_Type
         Height          =   288
         Left            =   1320
         Sorted          =   -1  'True
         TabIndex        =   4
         Text            =   "Combo1"
         Top             =   732
         Width           =   2292
      End
      Begin TextBox Fld_Name
         Height          =   372
         Left            =   1320
         TabIndex        =   1
         Top             =   252
         Width           =   2292
      End
      Begin Label Label4
         Caption         =   "&Decimals"
         Height          =   252
         Left            =   2760
         TabIndex        =   7
         Top             =   1800
         Width           =   852
      End
      Begin Label Label5
         Alignment       =   1  'Right Justify
         Caption         =   "Lo&gical"
         Height          =   252
         Left            =   480
         TabIndex        =   10
         Top             =   1800
         Width           =   732
      End
      Begin Label Label3
         Caption         =   "L&ength"
         Height          =   252
         Left            =   2760
         TabIndex        =   6
         Top             =   1320
         Width           =   612
      End
      Begin Label Label6
         Alignment       =   1  'Right Justify
         Caption         =   "&Field no."
         Height          =   252
         Left            =   360
         TabIndex        =   18
         Top             =   1320
         Width           =   852
      End
      Begin Label Label2
         Alignment       =   1  'Right Justify
         Caption         =   "Field &Type"
         Height          =   252
         Left            =   240
         TabIndex        =   3
         Top             =   768
         Width           =   972
      End
      Begin Label Label1
         Alignment       =   1  'Right Justify
         Caption         =   "Field &Name"
         Height          =   252
         Left            =   120
         TabIndex        =   2
         Top             =   324
         Width           =   1092
      End
   End
   Begin Frame Frame2
      Caption         =   "DBF Name"
      Height          =   732
      Left            =   120
      TabIndex        =   20
      Top             =   120
      Width           =   5532
      Begin TextBox DBF_Name
         Height          =   372
         Left            =   2040
         TabIndex        =   22
         Text            =   "NEW.DBF"
         Top             =   240
         Width           =   3012
      End
      Begin Label Label7
         Alignment       =   1  'Right Justify
         Caption         =   "Data&base name"
         Height          =   252
         Left            =   480
         TabIndex        =   21
         Top             =   360
         Width           =   1452
      End
   End
'Code for Visual Basic 1.0 and Windows 3.0
'(C)1991 Marquis Computing. All Rights Reserved.
'Form DefintDatabase
'-------------------
'Gets user input, performs entry validation, verifies structure and builds
'a FldInfo type array that may be used by other VBDB^ routines to create
'a dBASE* III+ compatible database.
'^VBDB(C)1991 Marquis Computing, parts (C)1990 Marquis Computing.
' VBDB is a tradmark of Marquis Computing.
'*dBASE and dBASE III+ are trademarks of Ashton-Tate.
    DefInt A-Z
    '
    'Fld() is an array which carries information to define a database
    'header. The constants are used to make using this easier. Fld() is
    'defined as follows --
    '
    'Element #:
    '
    '           1 = decimal flag (-1 or 0)
    '           2 = field length
    '           3 = field type (String * 1)
    '           4 = field name (String * 12)
    '           5 = location of field
    '
    Const Decimal = 1
    Const FLen = 2
    Const FType = 3
    Const FName = 4
    Const OffSet = 5
    Dim Fld() As String
Sub Chk_Fld_Click ()
    '
    'Verifies a flieds data
    '
    ThisFld = Val(WhichFld.Text)
    VerifyData Status, ThisFld
    If Not Status Then MsgBox "field definition ok", 64, "Validate Fields"
End Sub
Sub Clear_Fld_Click ()
    '
    'Clears out a fields data. If the current field is the last field,
    'and has data in it, then the data is reset to 0 (character
    'with length 0 and null field name), if the field is already 0,
    'and this is the last fiels, it is erased and focus is given to
    'the next field UNDER this one.
    '
    ThisFld = Val(WhichFld.Text)            'get this field no.
    ResetFld ThisFld                        'blow it out
    Fld_Name.SetFocus                       'set focus to name
    Fld_Name.SelStart = 0
    Fld_Name.Sellength = 256
    LastFld = GetLastFld()                  'get the last fld no.
    If LastFld < 1 Then LastFld = 1         'make up for 0 fld no.
    If ThisFld >= LastFld Then              'is this the last one?
        ResetFld ThisFld                    'yes, reset it
        DisplayFld LastFld                  're-display it with 0
    End If
End Sub
Sub Command1_Click ()
    '
    'Saves database definition into the Fld() type
    'and then create a database.
    '
    ThisFld = Val(WhichFld.Text)
    SaveFld ThisFld
    LastFld = GetLastFld()
    '--- copy down other fields
    For ThisFld = 1 To LastFld
      DisplayFld ThisFld
      VerifyData Status, ThisFld
      If Status Then Exit Sub
    Next
    '--- pointer wait
    MousePointer = 11
    '--- create a dbf
    Mode = 0    'normal create / open
    DBFName = DBF_Name.Text
    Fld(0, 0) = Str$(LastFld)
    CreateDBF DBFName, DBFHandle, Fld(), Mode, Status
    Unload DefineDatabase
End Sub
Sub Command2_Click ()
    Unload DefineDatabase
End Sub
Sub DisplayFld (ThisFld)
    '
    'Displays a fields data
    '
    '--- figure out field type
    Select Case Left$(Fld(ThisFld, FType), 1)
        Case "C"
            Fld_Type.Text = "Character"
        Case "D"
            Fld_Type.Text = "Date"
        Case "L"
            Fld_Type.Text = "Logical"
        Case "M"
            Fld_Type.Text = "Memo"
        Case "N"
            Fld_Type.Text = "Numeric"
    End Select
    '--- update the basic info regarding this field
    UpDateFlds
    '--- display its data
    Fld_Name.Text = RTrim$(LTrim$(Fld$(ThisFld, FName)))
    WhichFld.Text = Str$(ThisFld)
    Fld_Len.Text = Fld$(ThisFld, FLen)
    '--- set focus to top of form
    Fld_Name.SetFocus
    Fld_Name.SelStart = 0
    Fld_Name.Sellength = 256
End Sub
Sub DoDefError (Msg$)
    '
    'pops up an error message
    '
    MsgBox Msg$, 48, "Define Database Error"
End Sub
Sub Fld_Dec_Change ()
    '
    'Indicate that field info has changed
    '
    Changed = -1
End Sub
Sub Fld_Len_Change ()
    '
    'Indicate that field info has changed
    '
    Changed = -1
End Sub
Sub Fld_Log_Change ()
    '
    'Indicate that field info has changed
    '
    Changed = -1
End Sub
Sub Fld_Name_Change ()
    '
    'Indicate that field info has changed
    '
    Changed = -1
End Sub
Sub Fld_Name_KeyPress (KeyASCII As Integer)
    '
    'On enter key, goto next field
    '
    If KeyASCII = 13 Then
        Fld_Type.SetFocus
        Fld_Type.SelStart = 0
        Fld_Type.Sellength = 256
        KeyASCII = 0
    End If
End Sub
Sub Fld_Name_LostFocus ()
    Fld_Name.Text = UCase$(Fld_Name.Text)
End Sub
Sub Fld_Type_Change ()
    '
    'Indicate that field info has changed
    '
    Changed = -1
End Sub
Sub Fld_Type_KeyPress (KeyASCII As Integer)
    '
    'On enter key, goto next field
    '
    If KeyASCII = 13 Then
        Fld_Len.SetFocus
        Fld_Len.SelStart = 0
        Fld_Len.Sellength = 256
        KeyASCII = 0
    End If
End Sub
Sub Fld_Type_LostFocus ()
    '
    'Make sure data is correct for this type
    '
    UpDateFlds
End Sub
Sub Form_Load ()
    Screen.MousePointer = 11
    '--- center the window
    WinWidth = (Screen.Width - DefineDatabase.Width) \ 2
    WinHieght = (Screen.Height - DefineDatabase.Height) \ 2
    DefineDatabase.Move WinWidth, WinHieght
    '--- build combo box
    Fld_Type.AddItem "Character"
    Fld_Type.AddItem "Numeric"
    Fld_Type.AddItem "Date"
    Fld_Type.AddItem "Logical"
    Fld_Type.AddItem "Memo"
    '--- assign 0 values
    ReDim Fld(0 To 128, 0 To 5)
    dummy = DoEvents()
    ResetFld 1
    '--- reset pointer
    Screen.MousePointer = 0
End Sub
Function GetLastFld ()
    '
    'Returns the last valid field in a field
    'definition array
    '
    For Size = 1 To 128
        If Fld$(Size, FName) = "" Then
            GetLastFld = Size - 1
            If Size - 1 = 0 Then GetLastFld = Size
            Exit For
        End If
    Next
End Function
Sub Last_Fld_Click ()
    '--- is there another field?
    ThisFld = Val(WhichFld.Text)
    If ThisFld < 1 Then
        Fld_Name.SetFocus
        Fld_Name.SelStart = 0
        Fld_Name.Sellength = 256
        Exit Sub
    End If
    '--- save this data
    SaveFld ThisFld
    '--- determine NEXT field
    ThisFld = ThisFld - 1
    If ThisFld <= 0 Then ThisFld = 1
    WhichFld.Text = Str$(ThisFld)
    '--- display next data
    DisplayFld ThisFld
End Sub
Sub Next_Fld_Click ()
    '--- is there another field?
    ThisFld = Val(WhichFld.Text)
    '--- assign THIS field type
    SaveFld ThisFld
    '--- determine NEXT field
    ThisFld = ThisFld + 1
    If ThisFld > 255 Then ThisFld = 255
    WhichFld.Text = Str$(ThisFld)
    '--- display fields data
    DisplayFld ThisFld
End Sub
Sub ResetFld (ThisFld)
    '
    'Resets the field data for a new field
    '
    Fld_Type.Text = "Character"
    Fld_Type.ListIndex = 0
    Fld_Name.Text = String$(12, 0)
    Fld_Len.Text = "0"
    Fld_Len.Enabled = -1
    Fld_Dec.Text = "N/A"
    Fld_Dec.Enabled = 0
    Fld_Log.Text = "N/A"
    Fld_Log.Enabled = 0
    Fld(ThisFld, Decimal) = "0"
    Fld(ThisFld, FLen) = "0"
    Fld(ThisFld, FType) = ""
    Fld(ThisFld, FName) = ""
    DisplayFld ThisFld
    Changed = 0
End Sub
Sub SaveFld (ThisFld)
    '
    'Saves a fld definition into position
    'ThisFld of array
    '
    Fld(ThisFld, Decimal) = Fld_Dec.Text
    Fld(ThisFld, FLen) = Fld_Len.Text
    Fld(ThisFld, FType) = Fld_Type.Text
    Fld(ThisFld, FName) = Fld_Name.Text
    Changed = 0
End Sub
Sub UpDateFlds ()
    '
    'Updates the conditions of the various boxes
    'based on the type of box it its.
    '
    Select Case Fld_Type.Text
        Case "Character"
            Fld_Len.Enabled = -1
            Fld_Len.Text = "0"
            Fld_Dec.Enabled = 0
            Fld_Dec.Text = "N/A"

            Fld_Log.Enabled = 0
            Fld_Log.Text = "N/A"

        Case "Date"
            Fld_Len.Enabled = 0
            Fld_Len.Text = " 8"

            Fld_Dec.Enabled = 0
            Fld_Dec.Text = "N/A"

            Fld_Log.Enabled = 0
            Fld_Log.Text = "N/A"

        Case "Logical"
            Fld_Len.Enabled = 0
            Fld_Len.Text = " 1"

            Fld_Dec.Enabled = 0
            Fld_Dec.Text = "N/A"

            Fld_Log.Enabled = 0
            Fld_Log.Text = "TF"

        Case "Numeric"
            Fld_Len.Enabled = -1
            Fld_Len.Text = "0"
            Fld_Dec.Enabled = -1
            Fld_Dec.Text = "0"

            Fld_Log.Enabled = 0
            Fld_Log.Text = "N/A"

        Case "Memo"
            Fld_Len.Enabled = 0
            Fld_Len.Text = " 10"
            Fld_Dec.Enabled = 0
            Fld_Dec.Text = "N/A"
            Fld_Log.Enabled = 0
            Fld_Log.Text = "N/A"

    End Select
End Sub
Sub VerifyData (Status, ThisFld)
    '
    'Verifies the forms data. If anything is bogus, returns Status
    'as TRUE (-1) otherwise Status is FALSE (0).
    '
    '--- assume guilt
    Status = -1
    If DBF_Name.Text = "" Then
        DoDefError "file name invalid"
        DBF_Name.SetFocus
        DBF_Name.SelStart = 0
        DBF_Name.Sellength = 256
        Exit Sub
    End If
    '--- check for name
    fldname$ = Fld_Name.Text
    If fldname$ = "" Then
        DoDefError "field name invalid"
        Fld_Name.SetFocus
        Fld_Name.SelStart = 0
        Fld_Name.Sellength = 256
        Exit Sub
    End If
    '--- check names vailidty
    If Not VerifyField(fldname$, ThisFld) Then
        DoDefError "field name invalid"
        Fld_Name.SetFocus
        Fld_Name.SelStart = 0
        Fld_Name.Sellength = 256
        Exit Sub
    End If
    '--- check field name length
    If Len(fldname$) > 12 Then
        DoDefError "field name length invalid"
        Fld_Name.SetFocus
        Fld_Name.SelStart = 0
        Fld_Name.Sellength = 256
        Exit Sub
    End If
    '--- check field length
    If Val(Fld_Len.Text) <= 0 Or Val(Fld_Len.Text) > 255 Then
        DoDefError "field length invalid"
        Fld_Len.SetFocus
        Fld_Len.SelStart = 0
        Fld_Len.Sellength = 256
        Exit Sub
    End If
    '--- verify logical field is two characters
    If Fld_Log.Enabled And Len(Fld_Log.Text) <> 2 Then
        DoDefError "field length invalid"
        Exit Sub
    End If
    Status = 0
End Sub
Function VerifyField (fldname As String, ThisFld)
    '
    'Returns -1(-1) if field name is valid otherwize returns FALSE (0)
    '
    Bad$ = "-!@#$%^&*() "                        'bad items
    Count = Len(Bad$)                           'length

    '--- look for bad items
    For X = 1 To Count

      If InStr(fldname, Mid$(Bad$, X, 1)) Then  'bad?
        VerifyField = 0                         'set function FALSE
        Exit Function                           'exit
      End If
    Next
    '--- check field name for used
    Count = 0                                   'reset count to 0
    pFldName$ = String$(12, 0)                  'make a DBF fld name string
    LSet pFldName$ = fldname$                   'pad out FldName$
    fldname$ = pFldName$                        'swap 'em
    Do

        Count = Count + 1

        pFldName$ = Fld(Count, FName)
        If ThisFld <> Count And pFldName$ = fldname$ Then          'name used?
            VerifyField = 0                 'set function FALSE
            Exit Function                       'exit
        Else                                    'name not used
            Exit Do                             'exit loop
        End If
    Loop Until Fld(Count, FName) = "" Or Count = 128
    '--- if you got here the fld is good
    VerifyField = -1
End Function
Function VerifyType ()
    '
    'Check type
    '
    For X = 0 To Fld_Type.ListCount
        If Fld_Type.List(X) = Fld_Type.Text Then
            VerifyType = -1                     'set to no errors on
            Exit Function                       'form & exit.
        End If
    Next
    Fld_Type.SetFocus
    Fld_Type.SelStart = 0
    Fld_Type.Sellength = 256
End Function
Sub WhichFld_Change ()
    '
    'Indicate that field info has changed
    '
    Changed = -1
End Sub
Sub WhichFld_KeyPress (KeyASCII As Integer)
    'set fld
    If KeyASCII = 13 Then                       'enter key?

        KeyASCII = 0                            'for VB bug
        ThisFld = Val(WhichFld.Text)            'get fld no.

        If ThisFld > 0 And ThisFld < 256 Then   'in range for DBF?
            SaveFld ThisFld                     'save current field data
            DisplayFld ThisFld                  'display selected field
        Else                                    'no
            'DoMAXError 3006                     'set error "invalid field size"
        End If
    End If
End Sub