{*********************************************************} {* OVCTCMMN.PAS 4.06 *} {*********************************************************} {* ***** BEGIN LICENSE BLOCK ***** *} {* Version: MPL 1.1 *} {* *} {* The contents of this file are subject to the Mozilla Public License *} {* Version 1.1 (the "License"); you may not use this file except in *} {* compliance with the License. You may obtain a copy of the License at *} {* http://www.mozilla.org/MPL/ *} {* *} {* Software distributed under the License is distributed on an "AS IS" basis, *} {* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License *} {* for the specific language governing rights and limitations under the *} {* License. *} {* *} {* The Original Code is TurboPower Orpheus *} {* *} {* The Initial Developer of the Original Code is TurboPower Software *} {* *} {* Portions created by TurboPower Software Inc. are Copyright (C)1995-2002 *} {* TurboPower Software Inc. All Rights Reserved. *} {* *} {* Contributor(s): *} {* *} {* ***** END LICENSE BLOCK ***** *} {$I OVC.INC} {$B-} {Complete Boolean Evaluation} {$I+} {Input/Output-Checking} {$P+} {Open Parameters} {$T-} {Typed @ Operator} {.W-} {Windows Stack Frame} {$X+} {Extended Syntax} unit ovctcmmn; {-Orpheus table: common unit} interface uses SysUtils, Classes, {$IFNDEF LCL} Windows, Messages, {$ELSE} LclIntf, LMessages, LclType, MyMisc, {$ENDIF} Graphics, Forms, StdCtrls, Controls, OvcBase, OvcData, OvcExcpt; {---Enumeration types} type TOvcTblAdjust = ( {data adjustment in cell} otaDefault, {the default for the next higher class} otaTopLeft, {top left hand corner} otaTopCenter, {top, centered horizontally} otaTopRight, {top right hand corner} otaCenterLeft, {left hand side, centered vertically} otaCenter, {centered vertically and horizontally} otaCenterRight, {right hand side, centered vertically} otaBottomLeft, {bottom left hand corner} otaBottomCenter, {bottom, centered horizontally} otaBottomRight); {bottom right hand corner} TOvcTblAccess = ( {cell access types} otxDefault, {the default for the next higher class} otxNormal, {read & write} otxReadOnly, {read only, no write} otxInvisible); {no read or write, ie invisible} TOvcTblState = ( {grid states} {..Major} otsFocused, { focused, or cell being edited} otsUnfocused, { unfocused} otsDesigning, { being designed} {..Minor} otsNormal, { normal} otsEditing, { cell being edited} otsHiddenEdit, { ditto, however currently hidden} otsMouseSelect, { mouse is selecting} otsShowSize, { row/col sizing cursor shown} otsSizing, { row/col being resized} otsShowMove, { row/col move cursor shown} otsMoving, { row/col is being moved} {..Qualifiers} otsDoingRow, { moving/sizing a row} otsDoingCol, { moving/sizing a column} otsANOther); TOvcTblStates = set of TOvcTblState; TOvcTblKeyNeeds = ( {grid's requirements for keystrokes} otkDontCare, {grid does not need key} otkWouldLike, {grid would like key, but cell can take it} otkMustHave); {grid must have key} TOvcTblRegion = ( {table regions} otrInMain, {..main table area} otrInLocked, {..locked row or col area} otrInUnused, {..unused bit} otrOutside); {..outside table client area} TOvcTblOption = ( {table options} otoBrowseRow, {Highlight row when browsing} otoNoRowResizing, {No run-time row resizing allowed} otoNoColResizing, {No run-time column resizing allowed} otoTabToArrow, {Tab moves cell to right, ShiftTab left} otoEnterToArrow, {Enter stops editing and moves cell right} otoAlwaysEditing, {Edit mode is always active} otoNoSelection, {No run-time selection allowed} otoMouseDragSelect, {dragging with mouse selects} otoRowSelection, {clicking on row header selects entire row} otoColSelection, {clicking on column header selects entire column} otoThumbTrack, {Scrollbar thumb-tracking} otoAllowColMoves, {Enable column moves} otoAllowRowMoves); {Enable row moves} TOvcTblOptionSet = set of TOvcTblOption; TOvcScrollBar = ( {scroll bar identifiers} otsbVertical, {..the vertical one} otsbHorizontal); {..the horizontal one} TOvcTblActions = ( {configuration actions on rows/columns} taGeneral, {..general} taSingle, {..changing a single row/column} taAll, {..changing all rows/columns} taInsert, {..inserting a row/column} taDelete, {..deleting a row/column} taExchange); {..exchanging two rows/columns} TOvcCellDataPurpose = ( {OnGetCellData data request purpose} cdpForPaint, {..for painting} cdpForEdit, {..for editing} cdpForSave); {..for saving an edited data} TOvcTextStyle = ( {text painting styles} tsFlat, {..flat} tsRaised, {..raised look} tsLowered); {..lowered look} TOvcTblSelectionType = ( {Internal selection type} tstDeselectAll, {..deselect all selections} tstAdditional); {..additional selection/deselection} TOvcTblEditorStyle = ( {Table's cell editor style} tesNormal, {..normal (ie nothing special)} tesBorder, {..with border} tes3D); {..3D look} {---Row/Column number (index) types} type TRowNum = longint; {actually 0..2 billion} TColNum = integer; {actually 0..16K} {---record types for cells---} type PCellBitMapInfo = ^TCellBitMapInfo; TCellBitMapInfo = packed record BM : TBitMap; {bitmap object to display} Count : integer; {number of glyphs} ActiveCount : integer; {number of active glyphs} Index : integer; {index of glyph to display} end; PCellComboBoxInfo = ^TCellComboBoxInfo; TCellComboBoxInfo = packed record Index : integer; {index into Items list} {$IFDEF CBuilder} case integer of 0 : (St : array[0..255] of char); 1 : (RTItems : TStrings; RTSt : array[0..255] of char); {$ELSE} case integer of 0 : (St : ShortString); {string value if Index = -1} 1 : (RTItems : TStrings; {run-time items list} RTSt : ShortString); {run-time string value if Index = -1} {$ENDIF} end; TOvcCellAttributes = packed record {display attributes for a cell} caAccess : TOvcTblAccess; {..access rights} caAdjust : TOvcTblAdjust; {..data adjustment} caColor : TColor; {..background color} caFont : TFont; {..text font} caFontColor : TColor; {..text color} caFontHiColor : TColor; {..text highlight color} caTextStyle : TOvcTextStyle; {..text style} end; {---Table cell ancestor---} TOvcTableCellAncestor = class(TComponent) protected {private} {.Z+} FOnCfgChanged : TNotifyEvent; {.Z-} protected {.Z+} procedure tcChangeScale(M, D : integer); dynamic; procedure tcDoCfgChanged; {.Z-} public {protected} {.Z+} procedure tcResetTableValues; virtual; abstract; property OnCfgChanged : TNotifyEvent write FOnCfgChanged; {.Z-} public end; {---Table ancestor---} TOvcTableAncestor = class(TO32CustomControl) protected {private} FController : TOvcController; taCellList : TList; taLoadList : TStringList; function ControllerAssigned : Boolean; procedure SetController(Value : TOvcController); virtual; protected procedure CreateWnd; override; procedure Notification(AComponent : TComponent; Operation : TOperation); override; {streaming routines} procedure ChangeScale(M, D : integer); override; procedure DefineProperties(Filer : TFiler); override; procedure Loaded; override; procedure tbFinishLoadingCellList; procedure tbReadCellData(Reader : TReader); procedure tbWriteCellData(Writer : TWriter); procedure tbCellChanged(Sender : TObject); virtual; abstract; public {protected} {internal use only methods} procedure tbExcludeCell(Cell : TOvcTableCellAncestor); procedure tbIncludeCell(Cell : TOvcTableCellAncestor); procedure tbNotifyCellsOfTableChange; public constructor Create(AOwner : TComponent); override; destructor Destroy; override; property Controller : TOvcController read FController write SetController; function FilterKey(var Msg : TWMKey) : TOvcTblKeyNeeds; virtual; abstract; procedure ResolveCellAttributes(RowNum : TRowNum; ColNum : TColNum; var CellAttr : TOvcCellAttributes); virtual; abstract; end; type POvcSparseAttr = ^TOvcSparseAttr; {attributes for cells in sparse matrix--INTERNAL USE} TOvcSparseAttr = packed record scaAccess : TOvcTblAccess; scaAdjust : TOvcTblAdjust; scaColor : TColor; scaFont : TFont; scaCell : TOvcTableCellAncestor; end; POvcTableNumberArray = ^TOvcTableNumberArray; {structure passed to GetDisplayedRow(Col)Numbers} TOvcTableNumberArray = packed record NumElements : longint; {..number of elements in Number array} Count : longint; {..return count of used elements in Number array} Number : array [0..29] of longint; {..Number array} end; {---Row style type} type PRowStyle = ^TRowStyle; TRowStyle = packed record Height : Integer; {-1 means default} Hidden : boolean; end; {---Short string type (length-byte string)} type POvcShortString = ^ShortString; {pointer to shortstring} {---Exception classes} type EOrpheusTable = class(Exception); {---Notification events} type TRowNotifyEvent = procedure (Sender : TObject; RowNum : TRowNum) of object; TColNotifyEvent = procedure (Sender : TObject; ColNum : TColNum) of object; TColResizeEvent = procedure ( Sender: TObject; ColNum : TColNum; NewWidth: Integer) of object; TRowResizeEvent = procedure ( Sender: TObject; RowNum : TRowNum; NewHeight: Integer) of object; TCellNotifyEvent = procedure (Sender : TObject; RowNum : TRowNum; ColNum : TColNum) of object; TCellDataNotifyEvent = procedure (Sender : TObject; RowNum : TRowNum; ColNum : TColNum; var Data : pointer; Purpose : TOvcCellDataPurpose) of object; TCellAttrNotifyEvent = procedure (Sender : TObject; RowNum : TRowNum; ColNum : TColNum; var CellAttr : TOvcCellAttributes) of object; TCellPaintNotifyEvent = procedure (Sender : TObject; TableCanvas : TCanvas; const CellRect : TRect; RowNum : TRowNum; ColNum : TColNum; const CellAttr : TOvcCellAttributes; Data : pointer; var DoneIt : boolean) of object; TCellBeginEditNotifyEvent = procedure (Sender : TObject; RowNum : TRowNum; ColNum : TColNum; var AllowIt : boolean) of object; TCellEndEditNotifyEvent = procedure (Sender : TObject; Cell : TOvcTableCellAncestor; RowNum : TRowNum; ColNum : TColNum; var AllowIt : boolean) of object; TCellMoveNotifyEvent = procedure (Sender : TObject; Command : word; var RowNum : TRowNum; var ColNum : TColNum) of object; TCellChangeNotifyEvent = procedure (Sender : TObject; var RowNum : TRowNum; var ColNum : TColNum) of object; TRowChangeNotifyEvent = procedure (Sender : TObject; RowNum1, RowNum2 : TRowNum; Action : TOvcTblActions) of object; TColChangeNotifyEvent = procedure (Sender : TObject; ColNum1, ColNum2 : TColNum; Action : TOvcTblActions) of object; TSizeCellEditorNotifyEvent = procedure (Sender : TObject; RowNum : TRowNum; ColNum : TColNum; var CellRect : TRect; var CellStyle: TOvcTblEditorStyle) of object; TSelectionIterator = function(RowNum1 : TRowNum; ColNum1 : TColNum; RowNum2 : TRowNum; ColNum2 : TColNum; ExtraData : pointer) : boolean of object; {---Cell-Table interaction messages---} const ctim_Base = WM_USER + $4545; ctim_QueryOptions = ctim_Base; ctim_QueryColor = ctim_Base + 1; ctim_QueryFont = ctim_Base + 2; ctim_QueryLockedCols = ctim_Base + 3; ctim_QueryLockedRows = ctim_Base + 4; ctim_QueryActiveCol = ctim_Base + 5; ctim_QueryActiveRow = ctim_Base + 6; ctim_RemoveCell = ctim_Base + 10; ctim_StartEdit = ctim_Base + 11; ctim_StartEditMouse = ctim_Base + 12; ctim_StartEditKey = ctim_Base + 13; ctim_SetFocus = ctim_Base + 14; ctim_KillFocus = ctim_Base + 15; ctim_LoadDefaultCells = ctim_Base + 20; {---Property defaults} const tbDefAccess = otxNormal; tbDefAdjust = otaCenterLeft; tbDefBorderStyle = bsSingle; tbDefColCount = 10; tbDefColWidth = 150; tbDefGridColor = clBlack; tbDefHeight = 100; tbDefLockedCols = 1; tbDefLockedRows = 1; tbDefMargin = 4; tbDefRowCount = 10; tbDefRowHeight = 30; tbDefScrollBars = ssBoth; tbDefTableColor = clBtnFace; tbDefWidth = 300; {---Default color for cells (to force them to table color)} const clOvcTableDefault = $2FFFFFF; {---Handy extra constants for table's CalcRowColFromXY method} const CRCFXY_RowAbove = -2; {Y is above all table cells} CRCFXY_RowBelow = -1; {Y is below all table cells} CRCFXY_ColToLeft = -2; {X is to left of all table cells} CRCFXY_ColToRight = -1; {X is to right of all table cells} {---Handy extra constants for TRowNum variables, Row Heights} const RowLimitChanged = -2; UseDefHt = -1; type {internal use only} TOvcTblDisplayItem = packed record Number : longint; Offset : Integer; end; POvcTblDisplayArray = ^TOvcTblDisplayArray; TOvcTblDisplayArray = packed record AllocNm : word; Count : word; Ay : array [0..127] of TOvcTblDisplayItem; {127 is arbitrary} end; {--Utility routines} function MinI(X, Y : Integer) : Integer; {Return the minimum of two integers} function MaxI(X, Y : Integer) : Integer; {Return the maximum of two integers} function MaxL(A, B : longint) : longint; function MinL(A, B : longint) : longint; function MakeRowStyle(AHeight : Integer; AHidden : boolean) : TRowStyle; {-Make a row style variable from a height and hidden flag.} procedure TableError(const Msg : string); {-Raise an exception with supplied string} procedure TableErrorRes(StringCode : word); {-Raise an exception with supplied string resource code} procedure AssignDisplayArray(var A : POvcTblDisplayArray; Num : word); {-Table internal: (re)assign a display array} implementation {===Standard routines================================================} {$IFDEF NoAsm} function MinI(X, Y : Integer) : Integer; begin if X < Y then Result := X else Result := Y; end; function MaxI(X, Y : Integer) : Integer; begin if X >= Y then Result := X else Result := Y; end; {$ELSE} function MinI(X, Y : Integer) : Integer; {Return the minimum of two integers} asm cmp eax, edx jle @@Exit mov eax, edx @@Exit: end; {--------} function MaxI(X, Y : Integer) : Integer; {Return the maximum of two integers} asm cmp eax, edx jge @@Exit mov eax, edx @@Exit: end; {$ENDIF} {--------} procedure TableError(const Msg : string); begin raise EOrpheusTable.Create(Msg); end; {--------} procedure TableErrorRes(StringCode : word); begin raise EOrpheusTable.Create(GetOrphStr(StringCode)); end; {--------} function MaxL(A, B : longint) : longint; begin if (A < B) then Result := B else Result := A; end; {--------} function MinL(A, B : longint) : longint; begin if (A < B) then Result := A else Result := B; end; {--------} procedure AssignDisplayArray(var A : POvcTblDisplayArray; Num : word); var NewA : POvcTblDisplayArray; NumToXfer : word; begin NewA := nil; if (Num > 0) then begin GetMem(NewA, Num*sizeof(TOvcTblDisplayItem)+2*sizeof(word)); {$IFOPT D+} FillChar(NewA^, Num*sizeof(TOvcTblDisplayItem)+2*sizeof(word), $CC); {$ENDIF} if Assigned(A) then begin NumToXfer := MinL(Num, A^.Count); if (NumToXfer > 0) then Move(A^.Ay, NewA^.Ay, NumToXFer*sizeof(TOvcTblDisplayItem)); end else NumToXfer := 0; with NewA^ do begin AllocNm := Num; Count := NumToXfer; end; end; if Assigned(A) then FreeMem(A, A^.AllocNm*sizeof(TOvcTblDisplayItem)+2*sizeof(word)); A := NewA; end; {--------} function MakeRowStyle(AHeight : Integer; AHidden : boolean) : TRowStyle; begin with Result do begin Height := AHeight; Hidden := AHidden; end; end; {====================================================================} {===TOvcTableCellAncestor============================================} procedure TOvcTableCellAncestor.tcChangeScale(M, D : integer); begin {do nothing at this level in the cell component hierarchy} end; {--------} procedure TOvcTableCellAncestor.tcDoCfgChanged; begin if Assigned(FOnCfgChanged) then FOnCfgChanged(Self); end; {====================================================================} {===TOvcTableAncestor================================================} constructor TOvcTableAncestor.Create(AOwner : TComponent); begin inherited Create(AOwner); taCellList := TList.Create; end; {--------} destructor TOvcTableAncestor.Destroy; begin taLoadList.Free; taCellList.Free; inherited Destroy; end; {--------} function TOvcTableAncestor.ControllerAssigned : Boolean; begin Result := Assigned(FController); end; procedure TOvcTableAncestor.CreateWnd; var OurForm : TWinControl; begin OurForm := GetImmediateParentForm(Self); {do this only when the component is first dropped on the form, not during loading} if (csDesigning in ComponentState) and not (csLoading in ComponentState) then ResolveController(OurForm, FController); if not Assigned(FController) and not (csLoading in ComponentState) then begin {try to find a controller on this form that we can use} FController := FindController(OurForm); {if not found and we are not designing, use default controller} if not Assigned(FController) and not (csDesigning in ComponentState) then FController := DefaultController; end; inherited CreateWnd; end; procedure TOvcTableAncestor.Notification(AComponent : TComponent; Operation : TOperation); begin inherited Notification(AComponent, Operation); if Operation = opRemove then begin if (AComponent = FController) then FController := nil; end else if (Operation = opInsert) and (FController = nil) and (AComponent is TOvcController) then FController := TOvcController(AComponent); end; procedure TOvcTableAncestor.SetController(Value : TOvcController); begin FController := Value; if Value <> nil then Value.FreeNotification(Self); end; procedure TOvcTableAncestor.ChangeScale(M, D : integer); var i : integer; begin inherited ChangeScale(M, D); if (M <> D) then for i := 0 to pred(taCellList.Count) do TOvcTableCellAncestor(taCellList[i]).tcChangeScale(M, D); end; {--------} procedure TOvcTableAncestor.DefineProperties(Filer : TFiler); begin inherited DefineProperties(Filer); Filer.DefineProperty('CellData', tbReadCellData, tbWriteCellData, true); end; {--------} procedure TOvcTableAncestor.tbExcludeCell(Cell : TOvcTableCellAncestor); begin taCellList.Remove(pointer(Cell)); end; {--------} procedure TOvcTableAncestor.tbFinishLoadingCellList; {Local methods} function GetImmediateParentForm(Control : TControl) : TWinControl; var ParentCtrl : TControl; begin ParentCtrl := Control.Parent; {$IFDEF VERSION5} while Assigned(ParentCtrl) and (not ((ParentCtrl is TCustomForm) or (ParentCtrl is TCustomFrame))) do ParentCtrl := ParentCtrl.Parent; Result := TWinControl(ParentCtrl); {$ELSE} while Assigned(ParentCtrl) and (not (ParentCtrl is TCustomForm)) do ParentCtrl := ParentCtrl.Parent; Result := TForm(ParentCtrl); {$ENDIF} end; {------} function FormNamesEqual(const CmptFormName, FormName : string) : boolean; var PosUL : integer; begin Result := true; if (FormName = '') or (CmptFormName = FormName) then Exit; PosUL := length(FormName); while (PosUL > 0) and (FormName[PosUL] <> '_') do dec(PosUL); if (PosUL > 0) then if (CmptFormName = Copy(FormName, 1, pred(PosUL))) then Exit; Result := false; end; {------} function GetFormName(const S, FormName : string) : string; var PosDot : integer; begin PosDot := Pos('.', S); if (PosDot <> 0) then Result := Copy(S, 1, pred(PosDot)) else Result := FormName; end; {------} function GetComponentName(const S : string) : string; var PosDot : integer; begin PosDot := Pos('.', S); if (PosDot <> 0) then Result := Copy(S, succ(PosDot), length(S)) else Result := S; end; {------} var i : integer; Form : TWinControl; Compnt : TComponent; DM : integer; DataMod: TDataModule; DMCount: integer; begin if Assigned(taLoadList) then begin {fixup the cell component list: the cells now exist} try Form := GetImmediateParentForm(Self); for i := pred(taLoadList.Count) downto 0 do if FormNamesEqual(GetFormName(taLoadList[i], Form.Name), Form.Name) then begin Compnt := Form.FindComponent(GetComponentName(taLoadList[i])); if Assigned(Compnt) and (Compnt is TOvcTableCellAncestor) then begin tbIncludeCell(TOvcTableCellAncestor(Compnt)); taLoadList.Delete(i); end; end; {fixup references to cell components on any data modules} if (taLoadList.Count <> 0) then begin DM := 0; //{$IFNDEF LCL} DMCount := Screen.DataModuleCount; //{$ELSE} // DMCount := 0; //{$ENDIF} while (taLoadList.Count > 0) and (DM < DMCount) do begin //{$IFNDEF LCL} DataMod := Screen.DataModules[DM]; //{$ENDIF} for i := pred(taLoadList.Count) downto 0 do if (GetFormName(taLoadList[i], Form.Name) = DataMod.Name) then begin Compnt := DataMod.FindComponent(GetComponentName(taLoadList[i])); if Assigned(Compnt) and (Compnt is TOvcTableCellAncestor) then begin tbIncludeCell(TOvcTableCellAncestor(Compnt)); taLoadList.Delete(i); end; end; inc(DM); end; end; finally taLoadList.Free; taLoadList := nil; end; end; end; {--------} procedure TOvcTableAncestor.tbIncludeCell(Cell : TOvcTableCellAncestor); begin if Assigned(Cell) then with taCellList do if (IndexOf(pointer(Cell)) = -1) then begin Add(pointer(Cell)); Cell.OnCfgChanged := tbCellChanged; end; end; {--------} procedure TOvcTableAncestor.Loaded; begin inherited Loaded; end; {--------} procedure TOvcTableAncestor.tbNotifyCellsOfTableChange; var i : integer; begin if Assigned(taCellList) then for i := 0 to pred(taCellList.Count) do TOvcTableCellAncestor(taCellList[i]).tcResetTableValues; end; {--------} procedure TOvcTableAncestor.tbReadCellData(Reader : TReader); begin if Assigned(taLoadList) then taLoadList.Clear else taLoadList := TStringList.Create; with Reader do begin ReadListBegin; while not EndOfList do taLoadList.Add(ReadString); ReadListEnd; end; end; {--------} procedure TOvcTableAncestor.tbWriteCellData(Writer : TWriter); var i : integer; Cell : TOvcTableCellAncestor; S : string; begin with Writer do begin WriteListBegin; for i := 0 to pred(taCellList.Count) do begin Cell := TOvcTableCellAncestor(taCellList[i]); S := Cell.Owner.Name; if (S <> '') then S := S + '.' + Cell.Name else S := Cell.Name; WriteString(S); end; WriteListEnd; end; end; {====================================================================} end.