Visual Basic Source Code/Visual Basic Source Code.iso/vbsource/grdrtn/grid.bas

BASIC Source File | 1995-05-09 | 9.4 KB | 315 lines

DefInt A-Z

'This program is Copyright 1991 Nelson Ford, PsL.
'Some routines have been developed by or with the help of
'  others. (The Grid Clip technique came from Jim Dolson.)
'You may freely use the individual routines from this
'  Grid.Bas in your own applications.

'=========================================================
'Distribution of Grid.Bas source code to others is allowed
'  ONLY if no changes are made to this file, including
'  these notes.
'=========================================================

'If you have improvements, please send them to
'    Nelson Ford
'    Public (software) Library
'    P.O.Box 35705
'    Houston, TX 77235-5705
'    800-242-4PsL  (for info: 713-524-6394)
'    (The above are _NOT_ bbs numbers!)
'    CIS: 71355,470
'  Call or write for a free copy of our monthly shareware
'    magazine and catalog, which includes numerous other
'    routines for Visual Basic available for a low disk fee.
'  Click on each "Proc." for more documentation.

'The following is just for reference:
'Grid Parameters:
'   Grid1.Cols = # of columns
'   Grid1.Rows = # of rows
'   Grid1.Col = current column
'   Grid1.Row = current row
'   Grid1.ColWidth = width of the current column
'   Grid1.RowHeight = width of the current row
'   Grid1.ColAlignment = 0=L, 1=C, 2=R
'   Grid1.Text = contents of the current cell
'   .CellSelected = T/F
'   .SelStartRow = first selected row
'   .SelEndRow = last selected row
'   .SelStartCol = first selected column
'   .SelEndCol = last selected column
'   .TopRow = first visible row
'   .LeftCol = first visible column

'Put the following in the calling form if you use the
'  MoveCell routine: (These routines are already in the
'  GridInpt.Frm file.)

'Declare Function ControlhWnd Lib "ctlhwnd.dll" (Ctl As Control) As Integer
'Declare Sub SetWindowPos Lib "User" (ByVal hWnd As Integer, ByVal hWndInsertAfter As Integer, ByVal X As Integer, ByVal Y As Integer, ByVal cx As Integer, ByVal cy As Integer, ByVal wFlags As Integer)
'Declare Function GetWindow Lib "User" (ByVal hWnd As Integer, ByVal wCmd As Integer) As Integer
'Declare Function GetNextWindow Lib "User" (ByVal hWnd As Integer, ByVal wFlag As Integer) As Integer
'Declare Function GetWindowLong Lib "User" (ByVal hWnd As Integer, ByVal nIndex As Integer) As Long
'Declare Function SetWindowLong Lib "User" (ByVal hWnd As Integer, ByVal nIndex As Integer, ByVal dwNewLong As Long) As Long

'Const WS_CLIPSIBLINGS = &H4000000
'Const SWP_NOSIZE = &H1
'Const SWP_NOMOVE = &H2
'Const GW_HWNDNEXT = 2
'Const GW_CHILD = 5
'Const GWL_STYLE = (-16)

'Sub SetClipSiblingBit (ByVal hWndParent As Integer)
'  Dim hWndChild As Integer
'  Dim Style As Long
'  hWndChild = GetWindow(hWndParent, GW_CHILD)
'  Do
'    Style = GetWindowLong(hWndChild, GWL_STYLE)
'    Style = Style Or WS_CLIPSIBLINGS
'    Style = SetWindowLong(hWndChild, GWL_STYLE, Style)
'    If GetWindow(hWndChild, GW_CHILD) <> 0 Then
'      Call SetClipSiblingBit(hWndChild)
'    End If
'    hWndChild = GetNextWindow(hWndChild, GW_HWNDNEXT)
'  Loop Until hWndChild = 0
'End Sub

Sub ClearGrid (G As Control)
' Clears the entire grid.
  G.SelStartRow = 0
  G.SelStartCol = 0
  G.SelEndRow = G.Rows - 1
  G.SelEndCol = G.Cols - 1
  G.Clip = ""
  G.SelEndRow = 0
  G.SelEndCol = 0
End Sub

Sub DelRow (G As Control)
  If G.CellSelected = 0 Then
    If G.SelStartRow = G.SelEndRow Then
      G.row = G.SelStartRow
      G.Col = G.SelStartCol
    Else
      MsgBox "First click on a line to select it."
      Exit Sub
    End If
  End If
  G.SelStartRow = G.row
  G.SelStartCol = 0
  G.SelEndCol = G.Cols - 1
  X = MsgBox("Are you sure?", 52, "Delete Line")
  If X = 6 Then
    G.SelStartRow = G.row + 1
    G.SelEndRow = G.Rows - 1
    G.SelStartCol = 0
    G.SelEndCol = G.Cols - 1
    c$ = G.Clip
    G.SelStartRow = G.SelStartRow - 1
    G.SelEndRow = G.Rows - 2
    G.Clip = c$
    G.SelStartRow = G.row
    G.SelEndRow = G.row
    G.SelStartCol = 0
    G.SelEndCol = G.Cols - 2
  End If
  G.SetFocus
End Sub

Sub DelRowNoPrompt (G As Control)
  G.SelStartRow = G.row + 1
  G.SelEndRow = G.Rows - 1
  G.SelStartCol = 0
  G.SelEndCol = G.Cols - 1
  c$ = G.Clip
  G.SelStartRow = G.SelStartRow - 1
  G.SelEndRow = G.Rows - 2
  G.Clip = c$
  G.SelStartRow = G.row
  G.SelEndRow = G.row
  G.SelStartCol = 0
  G.SelEndCol = G.Cols - 2
End Sub

Sub Grid2Clip (G As Control)
  G.SelStartRow = 0
  G.SelStartCol = 0
  G.SelEndRow = G.Rows - 1
  G.SelEndCol = G.Cols - 1
  ClipBoard.SetText (G.Clip)
  G.SelStartRow = G.row
  G.SelStartCol = 0
  G.SelEndRow = G.row
  G.SelEndCol = 0

End Sub

Sub HiLiteRow (G As Control)
  G.SelStartRow = G.row
  G.SelEndRow = G.row
  G.SelStartCol = 0
  G.SelEndCol = G.Cols - 1
End Sub

Sub InsertRow (G As Control)
  G.SelStartRow = G.row
  G.SelStartCol = G.Col
  G.SelEndRow = G.Rows - 2
  G.SelEndCol = G.Cols - 1
  X$ = G.Clip
  G.SelStartRow = G.row + 1
  G.SelEndRow = G.Rows - 1
  G.Clip = X$
  c = G.Col
  For i = G.FixedCols To G.Cols - 1
    G.Col = i
    G.Text = ""
  Next
  G.Col = c
  G.SelStartRow = G.row
  G.SelEndRow = G.row
End Sub

Sub LoadGrid (G As Control, Fi$)
    Open Fi$ For Binary Access Read As 1 Len = 1
    X = LOF(1)
    Close #1
    Open Fi$ For Binary Access Read As 1 Len = X
    Temp$ = Space$(X)
    Get 1, 1, Temp$
    G.SelStartRow = G.FixedRows
    G.SelStartCol = G.FixedCols
    G.SelEndRow = G.Rows - 1
    G.SelEndCol = G.Cols - 1
    G.Clip = Temp$
    Close #1
    G.SelEndRow = G.SelStartRow
    G.SelEndCol = G.SelStartCol
End Sub

Sub MoveCell (G As Control, Cell As Control, KeyCode)
  'Notes:
  '  For some reason, VB does not allow the Text box to be
  '    as short as a Grid Row. VBTools' text box does.
  '  Alternatively, you can do a loop to set RowHeight to
  '    Text.Height for each row in the Grid.
  '  Or you can leave the oversized Text box, which is not
  '    all that bad looking.
  '  In this procedure, you will notice that I've had to
  '    use "fudge factors" (eg: -50, +15, +20). I don't
  '    know why this is necessary, but it is. I haven't
  '    tested this on other video types, so I don't know
  '    if these fudge factors are constant on all types.
  '  I've already put a lot of time into this and didn't
  '    have more time to get the Grid scroll bars to work
  '    with this. For example, setting G.TopRow back to 0
  '    will not move the vertical scroll bar marker back
  '    to the top. I assume that this coordination will
  '    require API calls.
  '  Another routine that needs to be added is the ability
  '    to click on a cell and have the Text box move to it.
  '  If I were making this shareware, which I considered,
  '    I would have polished up all these things, but hey,
  '    waddya want for nothing?
  '  If someone else adds these things, I hope you will
  '    likewise share.

  G.Text = Cell.Text
  Select Case KeyCode
  Case 40  'Down cursor
    If G.row < G.Rows - 1 Then
      If Cell.Top - G.Top + G.RowHeight * 2 > G.Height Then
        G.TopRow = G.TopRow + 1
      Else
        Cell.Top = Cell.Top + G.RowHeight + 15
      End If
      G.row = G.row + 1
    Else
      Beep ' alternatively, use the next two lines to wrap
      'G.Row = G.TopRow
      'Cell.Top = G.Top
    End If
  Case 38  'Up cursor
    If G.row > 0 Then
      If G.row <= G.TopRow And G.TopRow > 0 Then
        G.TopRow = G.TopRow - 1
      Else
        Cell.Top = Cell.Top - G.RowHeight - 15
      End If
      G.row = G.row - 1
    Else
      Beep
    End If
  Case 39  'Right cursor
    If G.Col = G.Cols - 1 Then
      Beep 'or wrap:
      'G.Col = G.LeftCol
      'Cell.Left = G.Left
      'Cell.Width = G.ColWidth + 20
    Else
      Cell.Left = Cell.Left + G.ColWidth + 20
      G.Col = G.Col + 1
      Cell.Width = G.ColWidth + 20
      If Cell.Left - G.Left + Cell.Width > G.Width Then
        G.LeftCol = G.LeftCol + 1
        Cell.Left = Cell.Left - G.ColWidth - 20
      End If
    End If
  Case 37  'Left Cursor
    If G.Col > 0 Then
      G.Col = G.Col - 1
      Cell.Width = G.ColWidth + 20
      If G.Col < G.LeftCol Then
        G.LeftCol = G.LeftCol - 1
        Cell.Left = G.Left
      Else
        Cell.Left = Cell.Left - G.ColWidth - 20
      End If
    Else
      Beep
      'G.Col = G.Cols - 1
      'Cell.Width = G.ColWidth + 20
    End If
  Case 36  'Home
    Cell.Left = G.Left
    Cell.Top = G.Top
    G.Col = G.LeftCol
    G.row = G.TopRow
  Case 35  'End
    'put in code for End, PgUp, PgDn,
    '   Ctrl-PgUp (top of Grid), Ctrl-PgDn, etc.
  End Select
  KeyCode = 0 'throw away the cursor movement
  Cell.Text = G.Text
  Cell.SelStart = 0
  Cell.SelLength = 32767
  'keep the Grid highlight under the Text box:
  G.SelStartCol = G.Col
  G.SelEndCol = G.Col
  G.SelStartRow = G.row
  G.SelEndRow = G.row
End Sub

Sub SaveGrid (G As Control, Fi$, Cancel)
' The Cancel is included for when you call SaveGrid from
'   a Form_Unload procedure.
  X = MsgBox("Save data to disk?", 35)
  If X = 2 Then
    Cancel = -1
    G.SetFocus
  ElseIf X = 6 Then
    G.SelStartRow = G.FixedRows
    G.SelEndRow = G.Rows - 1
    G.SelStartCol = G.FixedCols
    G.SelEndCol = G.Cols - 1
    Open Fi$ For Output As #1
    Print #1, G.Clip
    Close #1
    G.SelEndRow = G.SelStartRow
    G.SelEndCol = G.SelStartCol
  End If
End Sub