Program Metropolis - Software Boutique 95/SOFTWARECD.iso/project4/disk6/gridfunc.ba_/gridfunc.bin

Text File | 1994-04-14 | 16.0 KB | 549 lines

'  GRIDFUNC.BAS  - Contains all the major Grid "properties", "methods",
'and validation functions.
'

Option Explicit
Option Compare Text

' This array determines which cells in the grid can be edited.  Each
'cell in the grid has a corresponding entry in the CellEditTable.
'Procedures that write values to the grid check the CellEditTable to
'see if a given cell is one that is allowed to be changed.  A "True"
'entry indicates that editing is allowed; "False" prevents editing.
Dim mabCellEditTable() As Integer

' This array is similar to mabCellEditTable, except that it indicates
'whether the user has changed the contents of a given cell.
Dim mabCellChangedTable() As Integer

' True if the grid is empty
Dim mbGridEmpty As Integer


' Grid title row (column headings)
 Const TITLE_ROW = 0

'  ColAlignment,FixedAlignment Properties
 Const GRID_ALIGNLEFT = 0
 Const GRID_ALIGNRIGHT = 1
 Const GRID_ALIGNCENTER = 2

'  Fillstyle Property
 Const GRID_SINGLE = 0
 Const GRID_REPEAT = 1

'  Contains the information from a grid row after the TInfo form has
'been edited by the user.
Type utRowRec
   nAUID As Integer              ' unique assignment id
   nTID As Integer               ' task id
   nActWork As Integer           ' actual resource work
   nRemWork As Integer           ' remaining resource work
   nAddWork As Integer           ' additional work
   bAddWorkDirty As Integer      ' indicates if user edited addwork field
   nETC As Integer               ' estimated work remaining
   bETCDirty As Integer          ' indicates if user edited etc field
   dtStart As Variant            ' resource start date on task
   bStartDirty As Integer        ' indicates if user edited start field
   dtFinish As Variant           ' resource finish date on task
   bFinishDirty As Integer       ' indicates if user edited finish field
End Type

'  This structure is used for the Edit Undo buffer in frmTaskInfo.
Type utUndo
   sUndo As String         ' string to restore.
   nRow As Integer         ' nRow and nCol store the grid coordinates
   nCol As Integer         'for the value in sUndo.
   nTag As Integer          ' type of control that contained the undo string. 0 = contents invalid, 1 = grid, 2 = textbox
End Type

' Makes an entry in the CellEditTable for the cell specified by iCol, iRow.
'The value of bEdit determines whether or not the specified cell may be
'edited; True = allow editing, False = don't allow editing.
'
'If iCol = -1 and iRow = -1, then AllowCellEditing uses the coordinates
'of the currently-selected cell in the grid.
'
Sub AllowCellEditing (ByVal iCol As Integer, ByVal iRow As Integer, bEdit As Integer)


   Dim F As frmTInfo
   Set F = frmTInfo

   ' Check the args
   Select Case iCol
      Case -1
         iCol = F!Grid.SelStartCol
      Case AUID To FINISH
         'ok
      Case Else
         'subscript out of range
         Error 9
   End Select
   Select Case iRow
      Case -1
         iRow = F!Grid.SelStartRow
      Case 1 To UBound(mabCellEditTable, 2)
         'ok
      Case Else
         'subscript out of range
         Error 9
   End Select

   mabCellEditTable(iCol, iRow) = bEdit

End Sub

Function CellIsDirty (ByVal iCol As Integer, ByVal iRow As Integer) As Integer

   Dim F As frmTInfo
   Set F = frmTInfo

   ' Check the args
   Select Case iCol
      Case -1
         iCol = F!Grid.SelStartCol
      Case ADDWORK To FINISH
         'ok
      Case Else
         'subscript out of range
         Error 9
   End Select
   Select Case iRow
      Case -1
         iRow = F!Grid.SelStartRow
      Case 1 To UBound(mabCellChangedTable, 2)
         'ok
      Case Else
         'subscript out of range
         Error 9
   End Select
   CellIsDirty = mabCellChangedTable(iCol, iRow)

End Function

' Returns the edit status from the CellEditTable for the given cell
'coordinates.  If iCol = -1 and iRow = -1, then the coordinates of the
'currently-selected cell in the grid will be used.
'
Function CellIsEditable (iCol, iRow) As Integer

   Dim F As frmTInfo
   Set F = frmTInfo

   ' Check the args
   Select Case iCol
      Case -1
         iCol = F!Grid.SelStartCol
      Case AUID To FINISH
         'ok
      Case Else
         'subscript out of range
         Error 9
   End Select
   Select Case iRow
      Case -1
         iRow = F!Grid.SelStartRow
      Case 1 To UBound(mabCellEditTable, 2)
         'ok
      Case Else
         'subscript out of range
         Error 9
   End Select

   CellIsEditable = mabCellEditTable(iCol, iRow)

End Function

'  Validates entries in the grid.  Returns True if the entry is valid;
'False if not.
'
Function CheckEdit () As Integer

   Dim F As frmTInfo
   Dim iRow As Integer
   Dim iCol As Integer
   Dim sGridText As String
   Dim iTmpCol As Integer
   Dim dtStart As Variant
   Dim dtFinish As Variant
   Dim tmp As Variant
   Dim nAddWork As Integer
   Dim nETC As Integer

   On Error GoTo CheckEditError

   Set F = frmTInfo
   iRow = F!Grid.Row
   iCol = F!Grid.Col
   sGridText = F!Grid.Text

   Select Case iCol
      Case ADDWORK
2010     nAddWork = goProjApp.DurationValue(sGridText)
         Select Case nAddWork
            Case Is < 0
            ' Invalid entry.
               Beep
               MsgBox MB_LESS_THAN_ZERO, MB_ICONEXCLAMATION, MB_TIMESHEET
               CheckEdit = False
            Case Is = 0
               ' Copy remaining work into ETC.
               F!Grid.Col = REMWORK
               tmp = F!Grid.Text
               F!Grid.Col = ETC
               F!Grid.Text = tmp
               F!Grid.Col = iCol
               CheckEdit = True
            Case Is > 0
               ' Subtract additional hours from remaining work and put the
               'result into ETC.
               F!Grid.Col = ETC
               tmp = goProjApp.DurationValue(F!Grid.Text)
               tmp = tmp - nAddWork

               If tmp > 0 Then
                  F!Grid.Text = goProjApp.DurationFormat(tmp, gnDefWorkUnit)
               Else
                  F!Grid.Text = "0" + gsDefWorkUnit
                  AllowCellEditing FINISH, -1, True
               End If
               F!Grid.Col = iCol
               CheckEdit = True
         End Select
      Case ETC
2020    nETC = goProjApp.DurationValue(sGridText)
        Select Case nETC
            Case Is < 0
            ' Invalid entry.
               Beep
               MsgBox MB_LESS_THAN_ZERO, MB_OK + MB_ICONEXCLAMATION, MB_TIMESHEET
               CheckEdit = False
            Case Is = 0
            ' If ETC = 0 then allow editing on finish
               AllowCellEditing FINISH, -1, True
               CheckEdit = True
            Case Is > 0
            ' A valid entry... probably.
               AllowCellEditing FINISH, -1, False
               CheckEdit = True
            Case Else
            ' Invalid entry.
               Beep
               MsgBox MB_UNRECOGNIZED_ENTRY, MB_OK + MB_ICONEXCLAMATION, MB_TIMESHEET
               CheckEdit = False
         End Select
      Case Start
2030     Select Case DateValue(sGridText)
            Case Is >= DateValue(goActiveProj.Start)
               CheckEdit = True
            Case Else
               Beep
               MsgBox MB_START_NOT_VALID, MB_OK + MB_ICONEXCLAMATION, MB_TIMESHEET
               CheckEdit = False
         End Select
      Case FINISH
         ' Check to make sure that the finish is greater than the start.
2040     dtFinish = DateValue(sGridText)
         F!Grid.Col = Start
2050     dtStart = DateValue(F!Grid.Text)
         If DateDiff("d", dtStart, dtFinish) < 0 Then
            Beep
            MsgBox MB_FINISH_NOT_VALID, MB_OK + MB_ICONEXCLAMATION, MB_TIMESHEET
            CheckEdit = False
         Else
            CheckEdit = True
         End If
         F!Grid.Col = iCol
   End Select
Exit Function

CheckEditError:
   Select Case Erl
      Case 2010, 2020
         ' Invalid entry.
         Beep
         MsgBox MB_UNRECOGNIZED_ENTRY, MB_OK + MB_ICONEXCLAMATION, MB_TIMESHEET
         CheckEdit = False
      Case 2030, 2040
         ' bad date format
         Beep
         MsgBox MB_BAD_DATE_FORMAT, MB_ICONEXCLAMATION, MB_TIMESHEET
         CheckEdit = False
      Case 2050
         ' bad date format
         F!Grid.Col = iTmpCol
         Beep
         MsgBox MB_BAD_DATE_FORMAT, MB_ICONEXCLAMATION, MB_TIMESHEET
         CheckEdit = False
      Case Else
         ' unanticipated error
         CheckEdit = False
   End Select
   Exit Function

End Function

'  Returns the count of rows placed into the autInfo array.  Modifies
'the autInfo array by redim'ing it.
'
Function GetGridInfo (autInfo() As utRowRec) As Integer

   Dim oApp As object               ' Winproj application object.
   Dim F As frmTInfo                ' frmTInfo form object.
   Dim nRows As Integer             ' The count of rows in the grid.
   Dim iRow As Integer              ' Loop counter, used to index grid rows.
   Dim iCol As Integer              ' Loop counter, used it index grid columns.
   Dim vntGVal As Variant           ' Text or value from the grid.
   Dim tmp As Variant               ' Scratch variable used to store sundry values.

   On Error GoTo GetGridInfoError

   Set oApp = goProjApp
   Set F = frmTInfo

   ' Check to see if the grid is empty, if so, exit.
   If mbGridEmpty Then
      GetGridInfo = 0
      Exit Function
   End If

   nRows = F!Grid.Rows
   ReDim autInfo(1 To nRows - 1) As utRowRec
   For iRow = 1 To nRows - 1
      For iCol = AUID To FINISH
         F!Grid.Row = iRow
         F!Grid.Col = iCol
         vntGVal = F!Grid.Text
         Select Case iCol
            Case AUID
               autInfo(iRow).nAUID = vntGVal
            Case TASKID
               autInfo(iRow).nTID = vntGVal
            Case TASKNAME
               ' We don't need the task name.
            Case ACTWORK
               tmp = oApp.DurationValue(vntGVal)
               autInfo(iRow).nActWork = CInt(tmp)
            Case REMWORK
               tmp = oApp.DurationValue(vntGVal)
               autInfo(iRow).nRemWork = CInt(tmp)
            Case ADDWORK
               tmp = oApp.DurationValue(vntGVal)
               autInfo(iRow).nAddWork = CInt(tmp)
               autInfo(iRow).bAddWorkDirty = CellIsDirty(iCol, iRow)
            Case ETC
               tmp = oApp.DurationValue(vntGVal)
               autInfo(iRow).nETC = CInt(tmp)
               autInfo(iRow).bETCDirty = CellIsDirty(iCol, iRow)
            Case Start
               autInfo(iRow).dtStart = vntGVal
               autInfo(iRow).bStartDirty = CellIsDirty(iCol, iRow)
            Case FINISH
               autInfo(iRow).dtFinish = vntGVal
               autInfo(iRow).bFinishDirty = CellIsDirty(iCol, iRow)
         End Select
      Next iCol
   Next iRow
   GetGridInfo = nRows

Exit Function

GetGridInfoError:
   Beep
   MsgBox MB_GENERIC_ERROR + " Err#" + Str$(Err), MB_ICONEXCLAMATION, MB_TIMESHEET
   TerminateApplication

End Function

Sub GridAddRow (utRowInfo As utAssignment)

   Dim iCurRow As Integer
   Dim oApp As object
   Dim F As frmTInfo
   Set F = frmTInfo
   Set oApp = goProjApp

   If mbGridEmpty Then
      F!Grid.Row = 1
   Else
      F!Grid.Rows = F!Grid.Rows + 1
      F!Grid.Row = F!Grid.Rows - 1
      ReDim Preserve mabCellEditTable(AUID To FINISH, TITLE_ROW To F!Grid.Row) As Integer
      ReDim Preserve mabCellChangedTable(ADDWORK To FINISH, 0 To F!Grid.Row) As Integer
   End If

   iCurRow = F!Grid.Row

   F!Grid.Col = AUID
   F!Grid.Text = utRowInfo.nAUID
   AllowCellEditing AUID, iCurRow, False

   F!Grid.Col = TASKID
   F!Grid.Text = utRowInfo.nTID
   AllowCellEditing TASKID, iCurRow, False

   F!Grid.Col = TASKNAME
   F!Grid.Text = utRowInfo.sTName
   AllowCellEditing TASKNAME, iCurRow, False

   F!Grid.Col = ACTWORK
   F!Grid.Text = oApp.DurationFormat(utRowInfo.nActWork, gnDefWorkUnit)
   AllowCellEditing ACTWORK, iCurRow, False

   F!Grid.Col = REMWORK
   F!Grid.Text = oApp.DurationFormat(utRowInfo.nRemWork, gnDefWorkUnit)
   AllowCellEditing REMWORK, iCurRow, False

   F!Grid.Col = ADDWORK
   F!Grid.Text = "0"
   AllowCellEditing ADDWORK, iCurRow, True
   MarkCellDirty ADDWORK, iCurRow, False

   F!Grid.Col = ETC
   F!Grid.Text = oApp.DurationFormat(utRowInfo.nRemWork, gnDefWorkUnit)
   AllowCellEditing ETC, iCurRow, True
   MarkCellDirty ETC, iCurRow, False

   F!Grid.Col = Start
   F!Grid.Text = utRowInfo.dtStart
   ' Allow the user to enter an actual start date only if
   'actual work is zero.
   If utRowInfo.nActWork > 0 Then
      AllowCellEditing Start, iCurRow, False
   Else
      AllowCellEditing Start, iCurRow, True
   End If
   MarkCellDirty Start, iCurRow, False

   F!Grid.Col = FINISH
   F!Grid.Text = utRowInfo.dtFinish
   ' Allow the user to enter an actual finish date only if
   'remaining work is zero.
   If utRowInfo.nRemWork > 0 Then
      AllowCellEditing FINISH, iCurRow, False
   Else
      AllowCellEditing FINISH, iCurRow, True
   End If
   MarkCellDirty FINISH, iCurRow, False

   mbGridEmpty = False

End Sub

' Clears the current contents of the grid, and sets the rows property
'back to 2.  Also alters mabCellEditTable and mbGridEmtpy. Does not
'affect the column titles.
'
Sub GridReset ()

   Dim iCol As Integer, iRow As Integer, i As Integer
   Dim F As frmTInfo
   Set F = frmTInfo

   F!Grid.Rows = 2
   F!Grid.Row = 1
   For i = AUID To FINISH
      F!Grid.Col = i
      F!Grid.Text = ""
   Next i

   ' Update the Cell Edit Table
   ReDim mabCellEditTable(AUID To FINISH, TITLE_ROW To 1) As Integer
   For iCol = AUID To FINISH
      For iRow = TITLE_ROW To 1
         mabCellEditTable(iCol, iRow) = False
      Next iRow
   Next iCol

   ' Update the Cell Changed Table
   ReDim mabCellChangedTable(ADDWORK To FINISH, TITLE_ROW To 1) As Integer
   For iCol = ADDWORK To FINISH
      For iRow = TITLE_ROW To 1
         mabCellChangedTable(iCol, iRow) = False
      Next iRow
   Next iCol

   ' Indicate that the grid is now empty
   mbGridEmpty = True

End Sub

' Sets the column headings and column widths for the Grid control.
'Also sets the initial values in mabCellEditTable and mbGridEmtpy.
'InitializeGrid is called from the TInfo form load procedure.
'
Sub InitializeGrid ()

Dim F As frmTInfo, iGCol As Integer, iCol As Integer, iRow As Integer
Set F = frmTInfo

Const TITLE_ROW = 0

   F!Grid.Row = TITLE_ROW
   F!Grid.Col = AUID
   F!Grid.Text = "auid"
   F!Grid.Col = TASKID
   F!Grid.Text = GRID_TASKID
   F!Grid.Col = TASKNAME
   F!Grid.Text = GRID_TASKNAME
   F!Grid.Col = ACTWORK
   F!Grid.Text = GRID_ACTWORK
   F!Grid.Col = REMWORK
   F!Grid.Text = GRID_REMWORK
   F!Grid.Col = ADDWORK
   F!Grid.Text = GRID_ADDWORK
   F!Grid.Col = ETC
   F!Grid.Text = GRID_ETC
   F!Grid.Col = Start
   F!Grid.Text = GRID_START
   F!Grid.Col = FINISH
   F!Grid.Text = GRID_FINISH

   F!Grid.RowHeight(TITLE_ROW) = 500

   F!Grid.ColWidth(AUID) = 1  'This column is not visible to the user.
   F!Grid.ColWidth(TASKID) = 500
   F!Grid.ColWidth(TASKNAME) = 2200
   For iGCol = ACTWORK To FINISH
      F!Grid.ColWidth(iGCol) = 900
   Next iGCol


   ' Indicate that the grid is empty.
   mbGridEmpty = True

   F!Grid.Row = 1
   F!Grid.Col = ADDWORK
End Sub

Sub MarkCellDirty (ByVal iCol As Integer, ByVal iRow As Integer, bDirty As Integer)

   Dim F As frmTInfo
   Set F = frmTInfo

   ' Check the args
   Select Case iCol
      Case -1
         iCol = F!Grid.SelStartCol
      Case ADDWORK To FINISH
         'ok
      Case Else
         'subscript out of range
         Error 9
   End Select
   Select Case iRow
      Case -1
         iRow = F!Grid.SelStartRow
      Case 1 To UBound(mabCellChangedTable, 2)
         'ok
      Case Else
         'subscript out of range
         Error 9
   End Select

   mabCellChangedTable(iCol, iRow) = bDirty

End Sub