Visual Basic 4 Unleashed/Visual_Basic_4_Unleashed_SAMS_Publishing_1995.iso/truegrid/disk1/tablevw/tablevw.$/TABLEVW.FRM

Visual Basic Form | 1995-02-17 | 10.8 KB | 336 lines

VERSION 2.00
Begin Form TableForm
   BackColor       =   &H00808080&
   Caption         =   "View Table Sample"
   ClientHeight    =   3150
   ClientLeft      =   1740
   ClientTop       =   2100
   ClientWidth     =   6090
   Height          =   3840
   Icon            =   TABLEVW.FRX:0000
   Left            =   1680
   LinkTopic       =   "Form1"
   ScaleHeight     =   3150
   ScaleWidth      =   6090
   Top             =   1470
   Width           =   6210
   Begin TrueGrid Table1
      AllowArrows     =   -1  'True
      AllowTabs       =   -1  'True
      BackColor       =   &H00C0C0C0&
      Editable        =   -1  'True
      EditDropDown    =   -1  'True
      ExposeCellMode  =   0  'Expose upon selection
      FetchMode       =   0  'By cell
      FontBold        =   0   'False
      FontItalic      =   0   'False
      FontName        =   "MS Sans Serif"
      FontSize        =   8.25
      FontStrikethru  =   0   'False
      FontUnderline   =   0   'False
      HeadingHeight   =   1
      Height          =   1815
      HorzLines       =   0  'None
      Layout          =   TABLEVW.FRX:0302
      LayoutIndex     =   1
      Left            =   120
      LinesPerRow     =   1
      MarqueeUnique   =   -1  'True
      SplitPropsGlobal=   -1  'True
      SplitTabMode    =   0  'Don't tab across splits
      TabCapture      =   0   'False
      TabIndex        =   0
      Top             =   120
      UseBookmarks    =   -1  'True
      Width           =   2775
      WrapCellPointer =   0   'False
   End
   Begin Menu ExitMenuOption
      Caption         =   "E&xit!"
   End
   Begin Menu IndexMenuOption
      Caption         =   "&Indexes"
      Visible         =   0   'False
      Begin Menu IndexMenu
         Index           =   0
      End
   End
   Begin Menu HelpMenuOption
      Caption         =   "&Help"
      Begin Menu HelpMenu
         Caption         =   "&Index"
         Index           =   0
      End
      Begin Menu HelpMenu
         Caption         =   "&Using Help"
         Index           =   1
      End
      Begin Menu HelpMenu
         Caption         =   "-"
         Index           =   2
      End
      Begin Menu HelpMenu
         Caption         =   "&About View Table..."
         Index           =   3
      End
   End
' Global values for Database and Table
Dim Db As Database
Dim Tb As Table
'Global constants that determine the size
'of the grid and it's current status
Const MAXROW = 1000
Dim CurrentRow As Long
Dim EndRow As Long
Sub CenterForm (F As Form)
' Center the specified form within the screen
    F.Move (Screen.Width - F.Width) \ 2, (Screen.Height - F.Height) \ 2
End Sub
Sub CheckForIndexes ()
    ' If Indexes exist then show Index menu option
    If Tb.Indexes.Count > 0 Then
        IndexMenuOption.Visible = True
        IndexMenu(0).Visible = True
        IndexMenu(0).Checked = True
        IndexMenu(0).Caption = "&None"

        ' Add Index menu option for each index
        For ct = 0 To Tb.Indexes.Count - 1
            Load IndexMenu(ct + 1)
            IndexMenu(ct + 1).Caption = Tb.Indexes(ct)
            IndexMenu(ct + 1).Checked = False
        Next ct
    End If
End Sub
Sub ExitApp ()
    ' Close database and table before exiting
    Tb.Close
    Db.Close
    End
End Sub
Sub ExitMenuOption_Click ()
    Unload Me
End Sub
Sub FieldLayout ()
    ' Get Field Layout to determine field display
    ' and data entry size
    For ct = 0 To Tb.Fields.Count - 1

        'Set display heading to database fieldname
        FldName = Tb.Fields(ct).Name
        Table1.ColumnName(ct + 1) = FldName

        'Get width of fieldname
        NameWidth = Len(FldName)
        'Get type of field to determine it's display size
        Select Case Tb.Fields(ct).Type
            Case 1, 10      'Text and Logic types
                FldSize = Tb.Fields(ct).Size
            Case 3          'Integer type
                FldSize = 7
            Case 4, 8       'Long and date types
                FldSize = 14
            Case 5, 6, 7    'Currency, Single, Double types
                FldSize = 10
            Case 11, 12     'Memo and binary types
                FldSize = 25
        End Select
        ' Use field width or the field name width whichever is larger
        If NameWidth > FldSize Then
            Table1.ColumnWidth(ct + 1) = NameWidth + 2
        Else
            Table1.ColumnWidth(ct + 1) = FldSize + 2
        End If
        ' Set data entry width to Field size
        Table1.ColumnSize(ct + 1) = FldSize
    Next ct
End Sub
Sub Form_Load ()
    'Center the sample on the screen
    CenterForm TableForm
    ' Open Database and Table functions
    OpenDb ("market.mdb")
    OpenTb ("Contact Information")
    ' Estimate begining size, put approx size in MAXROW
    EndRow = MAXROW
    ' Set grid Rows to estimated MAXROW
    Table1.Rows = MAXROW
    ' Set Current Row to one
    Temp = MoveToRow(1)
    ' Function to add indexes to the menu if any exist
    CheckForIndexes
    ' Function to setup grids columns
    FieldLayout
End Sub
Sub Form_Resize ()
    'Make the grid to the size of the form
    Table1.Move 0, 0, ScaleWidth, ScaleHeight
End Sub
Sub Form_Unload (Cancel As Integer)
    ExitApp
End Sub
Sub HelpMenu_Click (Index As Integer)
    'This event calls the WinHelp EXE and a location to goto based on which selection the user has chosen
    'Case 4 shows the about box for the Callback sample
    Select Case Index
        Case 0
            HelpContext TableForm, HELP_VIEWTABLE
        Case 1
            HelpOnHelp TableForm
        Case 3
            About.Show 1
    End Select
End Sub
Sub IndexMenu_Click (Index As Integer)
  If IndexMenu(Index).Checked <> True Then
    ' Set Index to whichever one the user chooses
    Select Case Index
        Case 0
            SetIndex ("")
        Case Else
            SetIndex (IndexMenu(Index).Caption)
    End Select
    ' Refresh grid, move to beginning, reset table row
    Table1.Refresh
    Table1.RowIndex = 1
    Temp = MoveToRow(1)
    ' Turn off all check marks
    For ct = 0 To Tb.Indexes.Count
        IndexMenu(ct).Checked = False
    Next ct
    ' Check value user choose
    IndexMenu(Index).Checked = True
  End If
End Sub
Function MoveToRow (NewRow As Long) As Long
Dim CurDiff, EndDiff, BeginDiff As Long
    ' Find differences between beginning, end and current position
    CurDiff = Abs(CurrentRow - NewRow)
    EndDiff = EndRow - NewRow
    BeginDiff = NewRow - 1
    ' If values are same no need to move db
    If CurrentRow = NewRow Then
        MoveToRow = CurrentRow
        Exit Function
    ' If moving forward in db
    ElseIf CurrentRow < NewRow Then
        ' Check to see if End is closer, if not
        ' move from current position to new position
        If EndDiff > CurDiff Then
            For ct = 1 To CurDiff
                Tb.MoveNext
                If Tb.EOF Then
                    CurrentRow = Tb.RecordCount
                    MoveToRow = CurrentRow
                    Exit Function
                Else
                    CurrentRow = CurrentRow + 1
                End If
            Next ct

        ' If end is closer move to the end of the database
        ' and go backwards to the new position
        Else
            Tb.MoveLast
            CurrentRow = Tb.RecordCount

            'Check to see if estimated equal actual, if not equal
            'exit function so CheckRows can set the actual EndRow value
            If EndRow = Tb.RecordCount Then
                For ct = 1 To EndDiff
                    Tb.MovePrevious
                    CurrentRow = CurrentRow - 1
                Next ct
            End If
        End If
    ' Moving backward in db
    Else
        ' If BeginDiff is greater than CurDiff then move
        ' from current position to new position
        If BeginDiff > CurDiff Then
            For ct = 1 To CurDiff
                Tb.MovePrevious
                If Tb.BOF Then
                    CurrentRow = 1
                    MoveToRow = CurrentRow
                    Exit Function
                Else
                    CurrentRow = CurrentRow - 1
                End If
            Next ct

        ' If beginning is closer then move from
        ' beginning to new position
        Else
            Tb.MoveFirst
            CurrentRow = 1
            For ct = 1 To BeginDiff
                Tb.MoveNext
                CurrentRow = CurrentRow + 1
            Next ct
        End If
    End If
    MoveToRow = CurrentRow
End Function
Sub OpenDb (DbName As String)
    ' Put your open database code here
    ChDir App.Path
    Set Db = OpenDatabase(DbName)
End Sub
Sub OpenTb (TableName As String)
    ' Put your open table code here
    Set Tb = Db.OpenTable(TableName)
End Sub
Sub SetIndex (IndexVal As String)
    ' If you database type supports multiple indexes
    ' set the index type you want to use here
    Tb.Index = IndexVal
End Sub
Sub Table1_CheckRows (RequestRows As Long, CurRows As Long)
    ' Move in table to value specified by RequestRows
    NewRow = MoveToRow(RequestRows)
    ' If table did not make it to the NewRow value
    ' i.e. NewRow was not attainable then
    ' end of db was reached
    If NewRow <> RequestRows Then
        ' Set CurRows to actual end of file
        CurRows = NewRow
        ' Set EndRow to actual end of file
        EndRow = NewRow
    End If
End Sub
Sub Table1_Fetch (row As Long, Col As Integer, Value As String)
    ' This condition should always be true because of the
    ' code in the CheckRows events but we double check
    NewRow = MoveToRow(row)
'    Debug.Print "OR=" & Str$(row)
'    Debug.Print "NR =" & Str$(NewRow)
    If NewRow = row Then

        ' If field is empty trap Null and use empty quotes instead
        If IsNull(Tb(Col - 1)) Then
            Value = ""
        Else
            Value = Tb(Col - 1)
        End If
    Else
        MsgBox "Error in navigating database"
    End If
End Sub
Sub Table1_Update (row As Long, Col As Integer, Value As String)
    ' This should always be true because of the code in the
    ' CheckRows but we double check anyways
    If MoveToRow(row) = row Then
        Call UpdateTable(Col, Value)
    Else
        MsgBox "Error updating value"
    End If
End Sub
Sub UpdateTable (Column As Integer, NewValue As String)
        ' There is no error checking so becareful
        ' of data mismatches!!!
        Tb.Edit
        Tb(Column - 1) = NewValue
        Tb.Update
End Sub