Delphi控件源码

开发平台：

Delphi

bsSkinGrids.pas：源码内容

{*******************************************************************}
{ }
{ Almediadev Visual Component Library }
{ BusinessSkinForm }
{ Version 2.90 }
{ }
{ }
{ Home: http://www.almdev.com }
{ Support: support@almdev.com }
{ }
{*******************************************************************}
unit bsSkinGrids;
{$P+,S-,W-,R-}
{$WARNINGS OFF}
{$HINTS OFF}
interface
uses Messages, Windows, SysUtils, Classes, Graphics, Menus, Controls, Forms,
StdCtrls, Mask, bsSkinData, bsSkinCtrls, bsSkinMenus;
const
MaxCustomExtents = MaxListSize;
MaxShortInt = High(ShortInt);
type
bsEInvalidGridOperation = class(Exception);
{ Internal grid types }
TbsGetExtentsFunc = function(Index: Longint): Integer of object;
TbsGridAxisDrawInfo = record
EffectiveLineWidth: Integer;
FixedBoundary: Integer;
GridBoundary: Integer;
GridExtent: Integer;
LastFullVisibleCell: Longint;
FullVisBoundary: Integer;
FixedCellCount: Integer;
FirstGridCell: Integer;
GridCellCount: Integer;
GetExtent: TbsGetExtentsFunc;
end;
TbsGridDrawInfo = record
Horz, Vert: TbsGridAxisDrawInfo;
end;
TbsGridState = (gsNormal, gsSelecting, gsRowSizing, gsColSizing,
gsRowMoving, gsColMoving);
TbsGridMovement = gsRowMoving..gsColMoving;
{ TInplaceEdit }
{ The inplace editor is not intended to be used outside the grid }
TbsSkinCustomGrid = class;
TbsSkinInplaceEdit = class(TCustomMaskEdit)
private
FGrid: TbsSkinCustomGrid;
FClickTime: Longint;
FSysPopupMenu: TbsSkinPopupMenu;
procedure DoUndo(Sender: TObject);
procedure DoCut(Sender: TObject);
procedure DoCopy(Sender: TObject);
procedure DoPaste(Sender: TObject);
procedure DoDelete(Sender: TObject);
procedure DoSelectAll(Sender: TObject);
procedure CreateSysPopupMenu;
procedure WMAFTERDISPATCH(var Message: TMessage); message WM_AFTERDISPATCH;
procedure WMCONTEXTMENU(var Message: TWMCONTEXTMENU); message WM_CONTEXTMENU;
procedure InternalMove(const Loc: TRect; Redraw: Boolean);
procedure SetGrid(Value: TbsSkinCustomGrid);
procedure CMShowingChanged(var Message: TMessage); message CM_SHOWINGCHANGED;
procedure WMGetDlgCode(var Message: TWMGetDlgCode); message WM_GETDLGCODE;
procedure WMPaste(var Message); message WM_PASTE;
procedure WMCut(var Message); message WM_CUT;
procedure WMClear(var Message); message WM_CLEAR;
protected
procedure CreateParams(var Params: TCreateParams); override;
procedure DblClick; override;
function EditCanModify: Boolean; override;
procedure KeyDown(var Key: Word; Shift: TShiftState); override;
procedure KeyPress(var Key: Char); override;
procedure KeyUp(var Key: Word; Shift: TShiftState); override;
procedure BoundsChanged; virtual;
procedure UpdateContents; virtual;
procedure WndProc(var Message: TMessage); override;
property Grid: TbsSkinCustomGrid read FGrid;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure Deselect;
procedure Hide;
procedure Invalidate;
procedure Move(const Loc: TRect);
function PosEqual(const Rect: TRect): Boolean;
procedure SetFocus;
procedure UpdateLoc(const Loc: TRect);
function Visible: Boolean;
end;
{ TbsSkinCustomGrid }
TGridOption = (goFixedVertLine, goFixedHorzLine, goVertLine, goHorzLine,
goRangeSelect, goDrawFocusSelected, goRowSizing, goColSizing, goRowMoving,
goColMoving, goEditing, goTabs, goRowSelect,
goAlwaysShowEditor, goThumbTracking);
TGridOptions = set of TGridOption;
TGridDrawState = set of (gdSelected, gdFocused, gdFixed);
TGridScrollDirection = set of (sdLeft, sdRight, sdUp, sdDown);
TGridCoord = record
X: Longint;
Y: Longint;
end;
TGridRect = record
case Integer of
0: (Left, Top, Right, Bottom: Longint);
1: (TopLeft, BottomRight: TGridCoord);
end;
TSelectCellEvent = procedure (Sender: TObject; ACol, ARow: Longint;
var CanSelect: Boolean) of object;
TDrawCellEvent = procedure (Sender: TObject; ACol, ARow: Longint;
Rect: TRect; State: TGridDrawState) of object;
TbsSkinCustomGrid = class(TbsSkinControl)
private
FUseSkinFont: Boolean;
FUseSkinCellHeight: Boolean;
FGridLineColor: TColor;
FHScrollBar: TbsSkinScrollBar;
FVScrollBar: TbsSkinScrollBar;
FAnchor: TGridCoord;
FBorderStyle: TBorderStyle;
FCanEditModify: Boolean;
FColCount: Longint;
FColWidths: Pointer;
FTabStops: Pointer;
FCurrent: TGridCoord;
FDefaultColWidth: Integer;
FDefaultRowHeight: Integer;
FDefaultCellHeight: Integer;
FFixedCols: Integer;
FFixedRows: Integer;
FFixedColor: TColor;
FGridLineWidth: Integer;
FOptions: TGridOptions;
FRowCount: Longint;
FRowHeights: Pointer;
FTopLeft: TGridCoord;
FSizingIndex: Longint;
FSizingPos, FSizingOfs: Integer;
FMoveIndex, FMovePos: Longint;
FHitTest: TPoint;
FInplaceEdit: TbsSkinInplaceEdit;
FInplaceCol, FInplaceRow: Longint;
FColOffset: Integer;
FDefaultDrawing: Boolean;
FEditorMode: Boolean;
procedure SetGridLineColor(Value: TColor);
procedure SetDefaultCellHeight(Value: Integer);
procedure OnVScrollBarChange(Sender: TObject);
procedure OnVScrollBarPageUp(Sender: TObject);
procedure OnVScrollBarPageDown(Sender: TObject);
procedure OnHScrollBarChange(Sender: TObject);
procedure OnVScrollBarUpButtonClick(Sender: TObject);
procedure OnVScrollBarDownButtonClick(Sender: TObject);
procedure OnHScrollBarUpButtonClick(Sender: TObject);
procedure OnHScrollBarDownButtonClick(Sender: TObject);
procedure OnHScrollBarPageUp(Sender: TObject);
procedure OnHScrollBarPageDown(Sender: TObject);
function CalcCoordFromPoint(X, Y: Integer;
const DrawInfo: TbsGridDrawInfo): TGridCoord;
procedure CalcDrawInfoXY(var DrawInfo: TbsGridDrawInfo;
UseWidth, UseHeight: Integer);
function CalcMaxTopLeft(const Coord: TGridCoord;
const DrawInfo: TbsGridDrawInfo): TGridCoord;
procedure CancelMode;
procedure ChangeGridOrientation(RightToLeftOrientation: Boolean);
procedure ChangeSize(NewColCount, NewRowCount: Longint);
procedure ClampInView(const Coord: TGridCoord);
procedure DrawSizingLine(const DrawInfo: TbsGridDrawInfo);
procedure DrawMove;
procedure FocusCell(ACol, ARow: Longint; MoveAnchor: Boolean);
procedure GridRectToScreenRect(GridRect: TGridRect;
var ScreenRect: TRect; IncludeLine: Boolean);
procedure HideEdit;
procedure Initialize;
procedure InvalidateGrid;
procedure InvalidateRect(ARect: TGridRect);
procedure ModifyScrollBar(ScrollBar, ScrollCode, Pos: Cardinal;
UseRightToLeft: Boolean);
procedure MoveAdjust(var CellPos: Longint; FromIndex, ToIndex: Longint);
procedure MoveAnchor(const NewAnchor: TGridCoord);
procedure MoveAndScroll(Mouse, CellHit: Integer; var DrawInfo: TbsGridDrawInfo;
var Axis: TbsGridAxisDrawInfo; Scrollbar: Integer; const MousePt: TPoint);
// procedure MoveCurrent(ACol, ARow: Longint; MoveAnchor, Show: Boolean);
procedure MoveTopLeft(ALeft, ATop: Longint);
procedure ResizeCol(Index: Longint; OldSize, NewSize: Integer);
procedure ResizeRow(Index: Longint; OldSize, NewSize: Integer);
procedure SelectionMoved(const OldSel: TGridRect);
procedure ScrollDataInfo(DX, DY: Integer; var DrawInfo: TbsGridDrawInfo);
procedure TopLeftMoved(const OldTopLeft: TGridCoord);
function GetColWidths(Index: Longint): Integer;
function GetRowHeights(Index: Longint): Integer;
function GetSelection: TGridRect;
function GetTabStops(Index: Longint): Boolean;
function GetVisibleRowCount: Integer;
function GetVisibleColCount: Integer;
function IsActiveControl: Boolean;
procedure ReadColWidths(Reader: TReader);
procedure ReadRowHeights(Reader: TReader);
procedure SetBorderStyle(Value: TBorderStyle);
procedure SetCol(Value: Longint);
procedure SetColWidths(Index: Longint; Value: Integer);
procedure SetDefaultColWidth(Value: Integer);
procedure SetDefaultRowHeight(Value: Integer);
procedure SetEditorMode(Value: Boolean);
procedure SetFixedColor(Value: TColor);
procedure SetFixedCols(Value: Integer);
procedure SetFixedRows(Value: Integer);
procedure SetGridLineWidth(Value: Integer);
procedure SetLeftCol(Value: Longint);
procedure SetOptions(Value: TGridOptions);
procedure SetRow(Value: Longint);
procedure SetRowHeights(Index: Longint; Value: Integer);
procedure SetSelection(Value: TGridRect);
procedure SetTabStops(Index: Longint; Value: Boolean);
procedure SetTopRow(Value: Longint);
procedure UpdateText;
procedure UpdateEdit;
procedure WriteColWidths(Writer: TWriter);
procedure WriteRowHeights(Writer: TWriter);
procedure CMCancelMode(var Msg: TMessage); message CM_CANCELMODE;
procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
procedure CMDesignHitTest(var Msg: TCMDesignHitTest); message CM_DESIGNHITTEST;
procedure CMWanTbsecialKey(var Msg: TCMWantSpecialKey); message CM_WANTSPECIALKEY;
procedure CMShowingChanged(var Message: TMessage); message CM_SHOWINGCHANGED;
procedure WMChar(var Msg: TWMChar); message WM_CHAR;
procedure WMCancelMode(var Msg: TWMCancelMode); message WM_CANCELMODE;
procedure WMCommand(var Message: TWMCommand); message WM_COMMAND;
procedure WMGetDlgCode(var Msg: TWMGetDlgCode); message WM_GETDLGCODE;
procedure WMHScroll(var Msg: TWMHScroll); message WM_HSCROLL;
procedure WMKillFocus(var Msg: TWMKillFocus); message WM_KILLFOCUS;
procedure WMLButtonDown(var Message: TMessage); message WM_LBUTTONDOWN;
procedure WMNCHitTest(var Msg: TWMNCHitTest); message WM_NCHITTEST;
procedure WMSetCursor(var Msg: TWMSetCursor); message WM_SETCURSOR;
procedure WMSetFocus(var Msg: TWMSetFocus); message WM_SETFOCUS;
procedure WMSize(var Msg: TWMSize); message WM_SIZE;
procedure WMTimer(var Msg: TWMTimer); message WM_TIMER;
procedure WMPAINT(var Msg: TWMPAINT); message WM_PAINT;
procedure WMVScroll(var Msg: TWMVScroll); message WM_VSCROLL;
protected
FInCheckScrollBars: Boolean;
FGridState: TbsGridState;
FSaveCellExtents: Boolean;
DesignOptionsBoost: TGridOptions;
VirtualView: Boolean;
//
procedure SetColCount(Value: Longint); virtual;
procedure MoveCurrent(ACol, ARow: Longint; MoveAnchor, Show: Boolean); virtual;
procedure SetRowCount(Value: Longint); virtual;
//
procedure SetHScrollBar(Value: TbsSkinScrollBar); virtual;
procedure SetVScrollBar(Value: TbsSkinScrollBar); virtual;
procedure UpdateScrollPos(UpDateVert: Boolean); virtual;
procedure UpdateScrollRange(UpDateVert: Boolean); virtual;
procedure GetSkinData; override;
procedure CalcDrawInfo(var DrawInfo: TbsGridDrawInfo);
procedure CalcFixedInfo(var DrawInfo: TbsGridDrawInfo);
procedure CalcSizingState(X, Y: Integer; var State: TbsGridState;
var Index: Longint; var SizingPos, SizingOfs: Integer;
var FixedInfo: TbsGridDrawInfo); virtual;
function CreateEditor: TbsSkinInplaceEdit; virtual;
procedure CreateParams(var Params: TCreateParams); override;
procedure KeyDown(var Key: Word; Shift: TShiftState); override;
procedure KeyPress(var Key: Char); override;
procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer); override;
procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer); override;
procedure AdjustSize(Index, Amount: Longint; Rows: Boolean); reintroduce; dynamic;
function BoxRect(ALeft, ATop, ARight, ABottom: Longint): TRect;
procedure DoExit; override;
function CellRect(ACol, ARow: Longint): TRect;
function CanEditAcceptKey(Key: Char): Boolean; dynamic;
function CanGridAcceptKey(Key: Word; Shift: TShiftState): Boolean; dynamic;
function CanEditModify: Boolean; dynamic;
function CanEditShow: Boolean; virtual;
function DoMouseWheelDown(Shift: TShiftState; MousePos: TPoint): Boolean; override;
function DoMouseWheelUp(Shift: TShiftState; MousePos: TPoint): Boolean; override;
function GetEditText(ACol, ARow: Longint): string; dynamic;
procedure SetEditText(ACol, ARow: Longint; const Value: string); dynamic;
function GetEditMask(ACol, ARow: Longint): string; dynamic;
function GetEditLimit: Integer; dynamic;
function GetGridWidth: Integer;
function GetGridHeight: Integer;
procedure HideEditor;
procedure ShowEditor;
procedure ShowEditorChar(Ch: Char);
procedure InvalidateEditor;
procedure MoveColumn(FromIndex, ToIndex: Longint);
procedure ColumnMoved(FromIndex, ToIndex: Longint); dynamic;
procedure MoveRow(FromIndex, ToIndex: Longint);
procedure RowMoved(FromIndex, ToIndex: Longint); dynamic;
procedure DrawCell(ACol, ARow: Longint; ARect: TRect;
AState: TGridDrawState); virtual; abstract;
procedure DefineProperties(Filer: TFiler); override;
procedure MoveColRow(ACol, ARow: Longint; MoveAnchor, Show: Boolean);
function SelectCell(ACol, ARow: Longint): Boolean; virtual;
procedure SizeChanged(OldColCount, OldRowCount: Longint); dynamic;
function Sizing(X, Y: Integer): Boolean;
procedure ScrollData(DX, DY: Integer);
procedure InvalidateCell(ACol, ARow: Longint);
procedure InvalidateCol(ACol: Longint);
procedure InvalidateRow(ARow: Longint);
procedure TopLeftChanged; dynamic;
procedure TimedScroll(Direction: TGridScrollDirection); dynamic;
procedure Paint; override;
procedure ColWidthsChanged; dynamic;
procedure RowHeightsChanged; dynamic;
procedure DeleteColumn(ACol: Longint); virtual;
procedure DeleteRow(ARow: Longint); virtual;
procedure UpdateDesigner;
function BeginColumnDrag(var Origin, Destination: Integer;
const MousePt: TPoint): Boolean; dynamic;
function BeginRowDrag(var Origin, Destination: Integer;
const MousePt: TPoint): Boolean; dynamic;
function CheckColumnDrag(var Origin, Destination: Integer;
const MousePt: TPoint): Boolean; dynamic;
function CheckRowDrag(var Origin, Destination: Integer;
const MousePt: TPoint): Boolean; dynamic;
function EndColumnDrag(var Origin, Destination: Integer;
const MousePt: TPoint): Boolean; dynamic;
function EndRowDrag(var Origin, Destination: Integer;
const MousePt: TPoint): Boolean; dynamic;
property BorderStyle: TBorderStyle read FBorderStyle write SetBorderStyle default bsSingle;
property Col: Longint read FCurrent.X write SetCol;
property Color default clWindow;
property ColCount: Longint read FColCount write SetColCount default 5;
property ColWidths[Index: Longint]: Integer read GetColWidths write SetColWidths;
property DefaultColWidth: Integer read FDefaultColWidth write SetDefaultColWidth default 64;
property DefaultDrawing: Boolean read FDefaultDrawing write FDefaultDrawing default True;
property DefaultRowHeight: Integer read FDefaultRowHeight write SetDefaultRowHeight default 24;
property EditorMode: Boolean read FEditorMode write SetEditorMode;
property FixedColor: TColor read FFixedColor write SetFixedColor default clBtnFace;
property FixedCols: Integer read FFixedCols write SetFixedCols default 1;
property FixedRows: Integer read FFixedRows write SetFixedRows default 1;
property GridHeight: Integer read GetGridHeight;
property GridLineWidth: Integer read FGridLineWidth write SetGridLineWidth default 1;
property GridWidth: Integer read GetGridWidth;
property HitTest: TPoint read FHitTest;
property InplaceEditor: TbsSkinInplaceEdit read FInplaceEdit;
property LeftCol: Longint read FTopLeft.X write SetLeftCol;
property Options: TGridOptions read FOptions write SetOptions
default [goFixedVertLine, goFixedHorzLine, goVertLine, goHorzLine,
goRangeSelect];
property ParentColor default False;
property Row: Longint read FCurrent.Y write SetRow;
property RowCount: Longint read FRowCount write SetRowCount default 5;
property RowHeights[Index: Longint]: Integer read GetRowHeights write SetRowHeights;
property Selection: TGridRect read GetSelection write SetSelection;
property TabStops[Index: Longint]: Boolean read GetTabStops write SetTabStops;
property TopRow: Longint read FTopLeft.Y write SetTopRow;
property VisibleColCount: Integer read GetVisibleColCount;
property VisibleRowCount: Integer read GetVisibleRowCount;
procedure Notification(AComponent: TComponent;
Operation: TOperation); override;
procedure CMVisibleChanged(var Message: TMessage); message CM_VISIBLECHANGED;
public
// skin properties
FixedCellRect, SelectCellRect, FocusCellRect: TRect;
FixedCellLeftOffset, FixedCellRightOffset: Integer;
FixedCellTextRect: TRect;
CellLeftOffset, CellRightOffset: Integer;
CellTextRect: TRect;
LinesColor, BGColor: TColor;
FontName: String;
FontStyle: TFontStyles;
FontHeight: Integer;
FontColor, SelectFontColor, FocusFontColor: TColor;
FixedFontName: String;
FixedFontStyle: TFontStyles;
FixedFontHeight: Integer;
FixedFontColor: TColor;
Picture: TBitMap;
procedure ChangeSkinData; override;
function GetNewTextRect(CellR: TRect; AState: TGridDrawState): TRect;
//
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
function MouseCoord(X, Y: Integer): TGridCoord;
published
property TabStop default True;
property UseSkinFont: Boolean read FUseSkinFont write FUseSkinFont;
property UseSkinCellHeight: Boolean read
FUseSkinCellHeight write FUseSkinCellHeight;
property HScrollBar: TbsSkinScrollBar read FHScrollBar
write SetHScrollBar;
property VScrollBar: TbsSkinScrollBar read FVScrollBar
write SetVScrollBar;
property GridLineColor: TColor read FGridLineColor write SetGridLineColor;
property DefaultCellHeight: Integer read FDefaultCellHeight
write SetDefaultCellHeight;
end;
{ TbsSkinDrawGrid }
TGetEditEvent = procedure (Sender: TObject; ACol, ARow: Longint; var Value: string) of object;
TSetEditEvent = procedure (Sender: TObject; ACol, ARow: Longint; const Value: string) of object;
TMovedEvent = procedure (Sender: TObject; FromIndex, ToIndex: Longint) of object;
TbsSkinDrawGrid = class(TbsSkinCustomGrid)
private
FOnColumnMoved: TMovedEvent;
FOnDrawCell: TDrawCellEvent;
FOnGetEditMask: TGetEditEvent;
FOnGetEditText: TGetEditEvent;
FOnRowMoved: TMovedEvent;
FOnSelectCell: TSelectCellEvent;
FOnSetEditText: TSetEditEvent;
FOnTopLeftChanged: TNotifyEvent;
protected
procedure ColumnMoved(FromIndex, ToIndex: Longint); override;
procedure DrawCell(ACol, ARow: Longint; ARect: TRect;
AState: TGridDrawState); override;
function GetEditMask(ACol, ARow: Longint): string; override;
function GetEditText(ACol, ARow: Longint): string; override;
procedure RowMoved(FromIndex, ToIndex: Longint); override;
function SelectCell(ACol, ARow: Longint): Boolean; override;
procedure SetEditText(ACol, ARow: Longint; const Value: string); override;
procedure TopLeftChanged; override;
public
function CellRect(ACol, ARow: Longint): TRect;
procedure MouseToCell(X, Y: Integer; var ACol, ARow: Longint);
property Canvas;
property Col;
property ColWidths;
property EditorMode;
property GridHeight;
property GridWidth;
property LeftCol;
property Selection;
property Row;
property RowHeights;
property TabStops;
property TopRow;
published
property Align;
property Anchors;
property BiDiMode;
property BorderStyle;
property Color;
property ColCount;
property Constraints;
property DefaultColWidth;
property DefaultRowHeight;
property DefaultDrawing;
property DragCursor;
property DragKind;
property DragMode;
property Enabled;
property FixedColor;
property FixedCols;
property RowCount;
property FixedRows;
property Font;
property GridLineWidth;
property Options;
property ParentBiDiMode;
property ParentColor;
property ParentFont;
property ParentShowHint;
property PopupMenu;
property ShowHint;
property TabOrder;
property TabStop;
property Visible;
property VisibleColCount;
property VisibleRowCount;
property OnClick;
property OnColumnMoved: TMovedEvent read FOnColumnMoved write FOnColumnMoved;
property OnDblClick;
property OnDragDrop;
property OnDragOver;
property OnDrawCell: TDrawCellEvent read FOnDrawCell write FOnDrawCell;
property OnEndDock;
property OnEndDrag;
property OnEnter;
property OnExit;
property OnGetEditMask: TGetEditEvent read FOnGetEditMask write FOnGetEditMask;
property OnGetEditText: TGetEditEvent read FOnGetEditText write FOnGetEditText;
property OnKeyDown;
property OnKeyPress;
property OnKeyUp;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
property OnMouseWheelDown;
property OnMouseWheelUp;
property OnRowMoved: TMovedEvent read FOnRowMoved write FOnRowMoved;
property OnSelectCell: TSelectCellEvent read FOnSelectCell write FOnSelectCell;
property OnSetEditText: TSetEditEvent read FOnSetEditText write FOnSetEditText;
property OnStartDock;
property OnStartDrag;
property OnTopLeftChanged: TNotifyEvent read FOnTopLeftChanged write FOnTopLeftChanged;
end;
{ TbsSkinStringGrid }
TbsSkinStringGrid = class;
TbsSkinStringGridStrings = class(TStrings)
private
FGrid: TbsSkinStringGrid;
FIndex: Integer;
procedure CalcXY(Index: Integer; var X, Y: Integer);
protected
function Get(Index: Integer): string; override;
function GetCount: Integer; override;
function GetObject(Index: Integer): TObject; override;
procedure Put(Index: Integer; const S: string); override;
procedure PutObject(Index: Integer; AObject: TObject); override;
procedure SetUpdateState(Updating: Boolean); override;
public
constructor Create(AGrid: TbsSkinStringGrid; AIndex: Longint);
function Add(const S: string): Integer; override;
procedure Assign(Source: TPersistent); override;
procedure Clear; override;
procedure Delete(Index: Integer); override;
procedure Insert(Index: Integer; const S: string); override;
end;
TbsSkinStringGrid = class(TbsSkinDrawGrid)
private
FData: Pointer;
FRows: Pointer;
FCols: Pointer;
FUpdating: Boolean;
FNeedsUpdating: Boolean;
FEditUpdate: Integer;
procedure DisableEditUpdate;
procedure EnableEditUpdate;
procedure Initialize;
procedure Update(ACol, ARow: Integer); reintroduce;
procedure SetUpdateState(Updating: Boolean);
function GetCells(ACol, ARow: Integer): string;
function GetCols(Index: Integer): TStrings;
function GetObjects(ACol, ARow: Integer): TObject;
function GetRows(Index: Integer): TStrings;
procedure SetCells(ACol, ARow: Integer; const Value: string);
procedure SetCols(Index: Integer; Value: TStrings);
procedure SetObjects(ACol, ARow: Integer; Value: TObject);
procedure SetRows(Index: Integer; Value: TStrings);
function EnsureColRow(Index: Integer; IsCol: Boolean): TbsSkinStringGridStrings;
function EnsureDataRow(ARow: Integer): Pointer;
protected
procedure ColumnMoved(FromIndex, ToIndex: Longint); override;
procedure DrawCell(ACol, ARow: Longint; ARect: TRect;
AState: TGridDrawState); override;
function GetEditText(ACol, ARow: Longint): string; override;
procedure SetEditText(ACol, ARow: Longint; const Value: string); override;
procedure RowMoved(FromIndex, ToIndex: Longint); override;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
property Cells[ACol, ARow: Integer]: string read GetCells write SetCells;
property Cols[Index: Integer]: TStrings read GetCols write SetCols;
property Objects[ACol, ARow: Integer]: TObject read GetObjects write SetObjects;
property Rows[Index: Integer]: TStrings read GetRows write SetRows;
end;
implementation
uses Math, Consts, bsUtils, Clipbrd, bsConst;
type
PIntArray = ^TIntArray;
TIntArray = array[0..MaxCustomExtents] of Integer;
procedure InvalidOp(const id: string);
begin
raise bsEInvalidGridOperation.Create(id);
end;
function GridRect(Coord1, Coord2: TGridCoord): TGridRect;
begin
with Result do
begin
Left := Coord2.X;
if Coord1.X < Coord2.X then Left := Coord1.X;
Right := Coord1.X;
if Coord1.X < Coord2.X then Right := Coord2.X;
Top := Coord2.Y;
if Coord1.Y < Coord2.Y then Top := Coord1.Y;
Bottom := Coord1.Y;
if Coord1.Y < Coord2.Y then Bottom := Coord2.Y;
end;
end;
function PointInGridRect(Col, Row: Longint; const Rect: TGridRect): Boolean;
begin
Result := (Col >= Rect.Left) and (Col <= Rect.Right) and (Row >= Rect.Top)
and (Row <= Rect.Bottom);
end;
type
TXorRects = array[0..3] of TRect;
procedure XorRects(const R1, R2: TRect; var XorRects: TXorRects);
var
Intersect, Union: TRect;
function PtInRect(X, Y: Integer; const Rect: TRect): Boolean;
begin
with Rect do Result := (X >= Left) and (X <= Right) and (Y >= Top) and
(Y <= Bottom);
end;
function Includes(const P1: TPoint; var P2: TPoint): Boolean;
begin
with P1 do
begin
Result := PtInRect(X, Y, R1) or PtInRect(X, Y, R2);
if Result then P2 := P1;
end;
end;
function Build(var R: TRect; const P1, P2, P3: TPoint): Boolean;
begin
Build := True;
with R do
if Includes(P1, TopLeft) then
begin
if not Includes(P3, BottomRight) then BottomRight := P2;
end
else if Includes(P2, TopLeft) then BottomRight := P3
else Build := False;
end;
begin
FillChar(XorRects, SizeOf(XorRects), 0);
if not Bool(IntersectRect(Intersect, R1, R2)) then
begin
{ Don't intersect so its simple }
XorRects[0] := R1;
XorRects[1] := R2;
end
else
begin
UnionRect(Union, R1, R2);
if Build(XorRects[0],
Point(Union.Left, Union.Top),
Point(Union.Left, Intersect.Top),
Point(Union.Left, Intersect.Bottom)) then
XorRects[0].Right := Intersect.Left;
if Build(XorRects[1],
Point(Intersect.Left, Union.Top),
Point(Intersect.Right, Union.Top),
Point(Union.Right, Union.Top)) then
XorRects[1].Bottom := Intersect.Top;
if Build(XorRects[2],
Point(Union.Right, Intersect.Top),
Point(Union.Right, Intersect.Bottom),
Point(Union.Right, Union.Bottom)) then
XorRects[2].Left := Intersect.Right;
if Build(XorRects[3],
Point(Union.Left, Union.Bottom),
Point(Intersect.Left, Union.Bottom),
Point(Intersect.Right, Union.Bottom)) then
XorRects[3].Top := Intersect.Bottom;
end;
end;
procedure ModifyExtents(var Extents: Pointer; Index, Amount: Longint;
Default: Integer);
var
LongSize, OldSize: LongInt;
NewSize: Integer;
I: Integer;
begin
if Amount <> 0 then
begin
if not Assigned(Extents) then OldSize := 0
else OldSize := PIntArray(Extents)^[0];
if (Index < 0) or (OldSize < Index) then InvalidOp(SIndexOutOfRange);
LongSize := OldSize + Amount;
if LongSize < 0 then InvalidOp(STooManyDeleted)
else if LongSize >= MaxListSize - 1 then InvalidOp(SGridTooLarge);
NewSize := Cardinal(LongSize);
if NewSize > 0 then Inc(NewSize);
ReallocMem(Extents, NewSize * SizeOf(Integer));
if Assigned(Extents) then
begin
I := Index + 1;
while I < NewSize do
begin
PIntArray(Extents)^[I] := Default;
Inc(I);
end;
PIntArray(Extents)^[0] := NewSize-1;
end;
end;
end;
procedure UpdateExtents(var Extents: Pointer; NewSize: Longint;
Default: Integer);
var
OldSize: Integer;
begin
OldSize := 0;
if Assigned(Extents) then OldSize := PIntArray(Extents)^[0];
ModifyExtents(Extents, OldSize, NewSize - OldSize, Default);
end;
procedure MoveExtent(var Extents: Pointer; FromIndex, ToIndex: Longint);
var
Extent: Integer;
begin
if Assigned(Extents) then
begin
Extent := PIntArray(Extents)^[FromIndex];
if FromIndex < ToIndex then
Move(PIntArray(Extents)^[FromIndex + 1], PIntArray(Extents)^[FromIndex],
(ToIndex - FromIndex) * SizeOf(Integer))
else if FromIndex > ToIndex then
Move(PIntArray(Extents)^[ToIndex], PIntArray(Extents)^[ToIndex + 1],
(FromIndex - ToIndex) * SizeOf(Integer));
PIntArray(Extents)^[ToIndex] := Extent;
end;
end;
function CompareExtents(E1, E2: Pointer): Boolean;
var
I: Integer;
begin
Result := False;
if E1 <> nil then
begin
if E2 <> nil then
begin
for I := 0 to PIntArray(E1)^[0] do
if PIntArray(E1)^[I] <> PIntArray(E2)^[I] then Exit;
Result := True;
end
end
else Result := E2 = nil;
end;
function LongMulDiv(Mult1, Mult2, Div1: Longint): Longint; stdcall;
external 'kernel32.dll' name 'MulDiv';
type
TSelection = record
StartPos, EndPos: Integer;
end;
constructor TbsSkinInplaceEdit.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
ParentCtl3D := False;
Ctl3D := False;
TabStop := False;
BorderStyle := bsNone;
FSysPopupMenu := nil;
end;
destructor TbsSkinInplaceEdit.Destroy;
begin
if FSysPopupMenu <> nil then FSysPopupMenu.Free;
inherited;
end;
procedure TbsSkinInplaceEdit.WMCONTEXTMENU;
var
X, Y: Integer;
P: TPoint;
begin
if PopupMenu <> nil
then
inherited
else
begin
CreateSysPopupMenu;
X := Message.XPos;
Y := Message.YPos;
if (X < 0) or (Y < 0)
then
begin
X := Width div 2;
Y := Height div 2;
P := Point(0, 0);
P := ClientToScreen(P);
X := X + P.X;
Y := Y + P.Y;
end;
if FSysPopupMenu <> nil
then
FSysPopupMenu.Popup2(Self, X, Y)
end;
end;
procedure TbsSkinInplaceEdit.WMAFTERDISPATCH;
begin
if FSysPopupMenu <> nil
then
begin
FSysPopupMenu.Free;
FSysPopupMenu := nil;
end;
end;
procedure TbsSkinInplaceEdit.DoUndo;
begin
Undo;
end;
procedure TbsSkinInplaceEdit.DoCut;
begin
CutToClipboard;
end;
procedure TbsSkinInplaceEdit.DoCopy;
begin
CopyToClipboard;
end;
procedure TbsSkinInplaceEdit.DoPaste;
begin
PasteFromClipboard;
end;
procedure TbsSkinInplaceEdit.DoDelete;
begin
ClearSelection;
end;
procedure TbsSkinInplaceEdit.DoSelectAll;
begin
SelectAll;
end;
procedure TbsSkinInplaceEdit.CreateSysPopupMenu;
function IsSelected: Boolean;
var
i, j: Integer;
begin
GetSel(i, j);
Result := (i < j);
end;
function IsFullSelected: Boolean;
var
i, j: Integer;
begin
GetSel(i, j);
Result := (i = 0) and (j = Length(Text));
end;
var
Item: TMenuItem;
begin
if FSysPopupMenu <> nil then FSysPopupMenu.Free;
FSysPopupMenu := TbsSkinPopupMenu.Create(Self);
FSysPopupMenu.ComponentForm := TForm(GetParentForm(Self));
Item := TMenuItem.Create(FSysPopupMenu);
with Item do
begin
if (FGrid.SkinData <> nil) and (FGrid.SkinData.ResourceStrData <> nil)
then
Caption := FGrid.SkinData.ResourceStrData.GetResStr('EDIT_UNDO')
else
Caption := BS_Edit_Undo;
OnClick := DoUndo;
Enabled := Self.CanUndo;
end;
FSysPopupMenu.Items.Add(Item);
Item := TMenuItem.Create(FSysPopupMenu);
Item.Caption := '-';
FSysPopupMenu.Items.Add(Item);
Item := TMenuItem.Create(FSysPopupMenu);
with Item do
begin
if (FGrid.SkinData <> nil) and (FGrid.SkinData.ResourceStrData <> nil)
then
Caption := FGrid.SkinData.ResourceStrData.GetResStr('EDIT_CUT')
else
Caption := BS_Edit_Cut;
Enabled := IsSelected and not Self.ReadOnly;
OnClick := DoCut;
end;
FSysPopupMenu.Items.Add(Item);
Item := TMenuItem.Create(FSysPopupMenu);
with Item do
begin
if (FGrid.SkinData <> nil) and (FGrid.SkinData.ResourceStrData <> nil)
then
Caption := FGrid.SkinData.ResourceStrData.GetResStr('EDIT_COPY')
else
Caption := BS_Edit_Copy;
Enabled := IsSelected;
OnClick := DoCopy;
end;
FSysPopupMenu.Items.Add(Item);
Item := TMenuItem.Create(FSysPopupMenu);
with Item do
begin
if (FGrid.SkinData <> nil) and (FGrid.SkinData.ResourceStrData <> nil)
then
Caption := FGrid.SkinData.ResourceStrData.GetResStr('EDIT_PASTE')
else
Caption := BS_Edit_Paste;
Enabled := (ClipBoard.AsText <> '') and not ReadOnly;
OnClick := DoPaste;
end;
FSysPopupMenu.Items.Add(Item);
Item := TMenuItem.Create(FSysPopupMenu);
with Item do
begin
if (FGrid.SkinData <> nil) and (FGrid.SkinData.ResourceStrData <> nil)
then
Caption := FGrid.SkinData.ResourceStrData.GetResStr('EDIT_DELETE')
else
Caption := BS_Edit_Delete;
Enabled := IsSelected and not Self.ReadOnly;
OnClick := DoDelete;
end;
FSysPopupMenu.Items.Add(Item);
Item := TMenuItem.Create(FSysPopupMenu);
Item.Caption := '-';
FSysPopupMenu.Items.Add(Item);
Item := TMenuItem.Create(FSysPopupMenu);
with Item do
begin
if (FGrid.SkinData <> nil) and (FGrid.SkinData.ResourceStrData <> nil)
then
Caption := FGrid.SkinData.ResourceStrData.GetResStr('EDIT_SELECTALL')
else
Caption := BS_Edit_SelectAll;
Enabled := not IsFullSelected;
OnClick := DoSelectAll;
end;
FSysPopupMenu.Items.Add(Item);
end;
procedure TbsSkinInplaceEdit.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
Params.Style := Params.Style or ES_MULTILINE;
end;
procedure TbsSkinInplaceEdit.SetGrid(Value: TbsSkinCustomGrid);
begin
FGrid := Value;
end;
procedure TbsSkinInplaceEdit.CMShowingChanged(var Message: TMessage);
begin
end;
procedure TbsSkinInplaceEdit.WMGetDlgCode(var Message: TWMGetDlgCode);
begin
inherited;
if goTabs in Grid.Options then
Message.Result := Message.Result or DLGC_WANTTAB;
end;
procedure TbsSkinInplaceEdit.WMPaste(var Message);
begin
if not EditCanModify then Exit;
inherited
end;
procedure TbsSkinInplaceEdit.WMClear(var Message);
begin
if not EditCanModify then Exit;
inherited;
end;
procedure TbsSkinInplaceEdit.WMCut(var Message);
begin
if not EditCanModify then Exit;
inherited;
end;
procedure TbsSkinInplaceEdit.DblClick;
begin
Grid.DblClick;
end;
function TbsSkinInplaceEdit.EditCanModify: Boolean;
begin
Result := Grid.CanEditModify;
end;
procedure TbsSkinInplaceEdit.KeyDown(var Key: Word; Shift: TShiftState);
procedure SendToParent;
begin
Grid.KeyDown(Key, Shift);
Key := 0;
end;
procedure ParentEvent;
var
GridKeyDown: TKeyEvent;
begin
GridKeyDown := Grid.OnKeyDown;
if Assigned(GridKeyDown) then GridKeyDown(Grid, Key, Shift);
end;
function ForwardMovement: Boolean;
begin
Result := goAlwaysShowEditor in Grid.Options;
end;
function Ctrl: Boolean;
begin
Result := ssCtrl in Shift;
end;
function Selection: TSelection;
begin
SendMessage(Handle, EM_GETSEL, Longint(@Result.StartPos), Longint(@Result.EndPos));
end;
function RightSide: Boolean;
begin
with Selection do
Result := ((StartPos = 0) or (EndPos = StartPos)) and
(EndPos = GetTextLen);
end;
function LeftSide: Boolean;
begin
with Selection do
Result := (StartPos = 0) and ((EndPos = 0) or (EndPos = GetTextLen));
end;
begin
case Key of
VK_UP, VK_DOWN, VK_PRIOR, VK_NEXT, VK_ESCAPE: SendToParent;
VK_INSERT:
if Shift = [] then SendToParent
else if (Shift = [ssShift]) and not Grid.CanEditModify then Key := 0;
VK_LEFT: if ForwardMovement and (Ctrl or LeftSide) then SendToParent;
VK_RIGHT: if ForwardMovement and (Ctrl or RightSide) then SendToParent;
VK_HOME: if ForwardMovement and (Ctrl or LeftSide) then SendToParent;
VK_END: if ForwardMovement and (Ctrl or RightSide) then SendToParent;
VK_F2:
begin
ParentEvent;
if Key = VK_F2 then
begin
Deselect;
Exit;
end;
end;
VK_TAB: if not (ssAlt in Shift) then SendToParent;
end;
if (Key = VK_DELETE) and not Grid.CanEditModify then Key := 0;
if Key <> 0 then
begin
ParentEvent;
inherited KeyDown(Key, Shift);
end;
end;
procedure TbsSkinInplaceEdit.KeyPress(var Key: Char);
var
Selection: TSelection;
begin
Grid.KeyPress(Key);
if (Key in [#32..#255]) and not Grid.CanEditAcceptKey(Key) then
begin
Key := #0;
MessageBeep(0);
end;
case Key of
#9, #27: Key := #0;
#13:
begin
SendMessage(Handle, EM_GETSEL, Longint(@Selection.StartPos), Longint(@Selection.EndPos));
if (Selection.StartPos = 0) and (Selection.EndPos = GetTextLen) then
Deselect else
SelectAll;
Key := #0;
end;
^H, ^V, ^X, #32..#255:
if not Grid.CanEditModify then Key := #0;
end;
if Key <> #0 then inherited KeyPress(Key);
end;
procedure TbsSkinInplaceEdit.KeyUp(var Key: Word; Shift: TShiftState);
begin
Grid.KeyUp(Key, Shift);
end;
procedure TbsSkinInplaceEdit.WndProc(var Message: TMessage);
var
FOld: Boolean;
begin
FOld := True;
case Message.Msg of
WM_SETFOCUS:
begin
if (GetParentForm(Self) = nil) or GetParentForm(Self).SetFocusedControl(Grid) then Dispatch(Message);
Exit;
end;
WM_LBUTTONDOWN:
begin
if ((GetMessageTime - FClickTime) < GetDoubleClickTime) then
Message.Msg := WM_LBUTTONDBLCLK;
FClickTime := 0;
end;
end;
if FOld then inherited WndProc(Message);
end;
procedure TbsSkinInplaceEdit.Deselect;
begin
SendMessage(Handle, EM_SETSEL, $7FFFFFFF, Longint($FFFFFFFF));
end;
procedure TbsSkinInplaceEdit.Invalidate;
var
Cur: TRect;
begin
ValidateRect(Handle, nil);
InvalidateRect(Handle, nil, True);
Windows.GetClientRect(Handle, Cur);
MapWindowPoints(Handle, Grid.Handle, Cur, 2);
ValidateRect(Grid.Handle, @Cur);
InvalidateRect(Grid.Handle, @Cur, False);
end;
procedure TbsSkinInplaceEdit.Hide;
begin
if HandleAllocated and IsWindowVisible(Handle) then
begin
Invalidate;
SetWindowPos(Handle, 0, 0, 0, 0, 0, SWP_HIDEWINDOW or SWP_NOZORDER or
SWP_NOREDRAW);
if Focused then Windows.SetFocus(Grid.Handle);
end;
end;
function TbsSkinInplaceEdit.PosEqual(const Rect: TRect): Boolean;
var
Cur: TRect;
begin
GetWindowRect(Handle, Cur);
MapWindowPoints(HWND_DESKTOP, Grid.Handle, Cur, 2);
Result := EqualRect(Rect, Cur);
end;
procedure TbsSkinInplaceEdit.InternalMove(const Loc: TRect; Redraw: Boolean);
begin
if IsRectEmpty(Loc) then Hide
else
begin
CreateHandle;
Redraw := Redraw or not IsWindowVisible(Handle);
Invalidate;
with Loc do
SetWindowPos(Handle, HWND_TOP, Left, Top, Right - Left, Bottom - Top,
SWP_SHOWWINDOW or SWP_NOREDRAW);
BoundsChanged;
if Redraw then Invalidate;
if Grid.Focused then
Windows.SetFocus(Handle);
end;
end;
procedure TbsSkinInplaceEdit.BoundsChanged;
var
R: TRect;
begin
R := Rect(2, 2, Width - 2, Height);
SendMessage(Handle, EM_SETRECTNP, 0, LongInt(@R));
SendMessage(Handle, EM_SCROLLCARET, 0, 0);
end;
procedure TbsSkinInplaceEdit.UpdateLoc(const Loc: TRect);
begin
InternalMove(Loc, False);
end;
function TbsSkinInplaceEdit.Visible: Boolean;
begin
Result := IsWindowVisible(Handle);
end;
procedure TbsSkinInplaceEdit.Move(const Loc: TRect);
begin
InternalMove(Loc, True);
end;
procedure TbsSkinInplaceEdit.SetFocus;
begin
if IsWindowVisible(Handle) then
Windows.SetFocus(Handle);
end;
procedure TbsSkinInplaceEdit.UpdateContents;
begin
Text := '';
EditMask := Grid.GetEditMask(Grid.Col, Grid.Row);
Text := Grid.GetEditText(Grid.Col, Grid.Row);
MaxLength := Grid.GetEditLimit;
end;
{ TbsSkinCustomGrid }
constructor TbsSkinCustomGrid.Create(AOwner: TComponent);
const
GridStyle = [csCaptureMouse, csOpaque, csDoubleClicks];
begin
inherited Create(AOwner);
FHScrollBar := nil;
FVScrollBar := nil;
FUseSkinCellHeight := True;
FUseSkinFont := True;
Ctl3D := False;
if NewStyleControls then
ControlStyle := GridStyle else
ControlStyle := GridStyle + [csFramed];
FCanEditModify := True;
FColCount := 5;
FRowCount := 5;
FFixedCols := 1;
FFixedRows := 1;
FGridLineWidth := 1;
FOptions := [goFixedVertLine, goFixedHorzLine, goVertLine, goHorzLine,
goRangeSelect];
DesignOptionsBoost := [goColSizing, goRowSizing];
FFixedColor := clBtnFace;
FBorderStyle := bsSingle;
FDefaultColWidth := 64;
FDefaultRowHeight := 20;
FDefaultCellHeight := 20;
FDefaultDrawing := True;
FSaveCellExtents := True;
FEditorMode := False;
Picture := nil;
Color := clWindow;
ParentColor := False;
TabStop := True;
SetBounds(Left, Top, FColCount * FDefaultColWidth,
FRowCount * FDefaultRowHeight);
Initialize;
FSkinDataName := 'grid';
FGridLineColor := clWindowText;
FInCheckScrollBars := False;
end;
destructor TbsSkinCustomGrid.Destroy;
begin
FInplaceEdit.Free;
inherited Destroy;
FreeMem(FColWidths);
FreeMem(FRowHeights);
FreeMem(FTabStops);
end;
procedure TbsSkinCustomGrid.CMVisibleChanged;
begin
inherited;
if FVScrollBar <> nil then FVScrollBar.Visible := Self.Visible;
if FHScrollBar <> nil then FHScrollBar.Visible := Self.Visible;
end;
procedure TbsSkinCustomGrid.SetDefaultCellHeight(Value: Integer);
begin
FDefaultCellHeight := Value;
if FIndex = -1 then DefaultRowHeight := FDefaultCellHeight;
end;
procedure TbsSkinCustomGrid.SetGridLineColor;
begin
FGridLineColor := Value;
if FIndex = -1 then RePaint;
end;
procedure TbsSkinCustomGrid.Notification;
begin
inherited Notification(AComponent, Operation);
if (Operation = opRemove) and (AComponent = FHScrollBar)
then FHScrollBar := nil;
if (Operation = opRemove) and (AComponent = FVScrollBar)
then FVScrollBar := nil;
end;
procedure TbsSkinCustomGrid.SetHScrollBar;
begin
FHScrollBar := Value;
if FHScrollBar <> nil
then
begin
FHScrollBar.Enabled := True;
FHScrollBar.Visible := False;
FHScrollBar.OnLastChange := OnHScrollBarChange;
FHScrollBar.OnUpButtonClick := OnHScrollBarUpButtonClick;
FHScrollBar.OnDownButtonClick := OnHScrollBarDownButtonClick;
FHScrollBar.OnPageUp := OnHScrollBarPageUp;
FHScrollBar.OnPageDown := OnHScrollBarPageDown;
UpdateScrollRange(True);
end;
end;
procedure TbsSkinCustomGrid.SetVScrollBar;
begin
FVScrollBar := Value;
if FVScrollBar <> nil
then
begin
FVScrollBar.Enabled := True;
FVScrollBar.Visible := False;
FVScrollBar.OnLastChange := OnVScrollBarChange;
FVScrollBar.OnUpButtonClick := OnVScrollBarUpButtonClick;
FVScrollBar.OnDownButtonClick := OnVScrollBarDownButtonClick;
FVScrollBar.OnPageUp := OnVScrollBarPageUp;
FVScrollBar.OnPageDown := OnVScrollBarPageDown;
UpdateScrollRange(True);
end;
end;
procedure TbsSkinCustomGrid.OnVScrollBarUpButtonClick(Sender: TObject);
begin
SendMessage(Handle, WM_VSCROLL,
MakeWParam(SB_LINEDOWN, VScrollBar.Position), 0);
end;
procedure TbsSkinCustomGrid.OnVScrollBarDownButtonClick(Sender: TObject);
begin
SendMessage(Handle, WM_VSCROLL,
MakeWParam(SB_LINEUP, VScrollBar.Position), 0);
end;
procedure TbsSkinCustomGrid.OnHScrollBarUpButtonClick(Sender: TObject);
begin
FHScrollBar.Position := FHScrollBar.Position + FHScrollBar.SmallChange;
SendMessage(Handle, WM_HSCROLL,
MakeWParam(SB_THUMBPOSITION, FHScrollBar.Position), 0);
end;
procedure TbsSkinCustomGrid.OnHScrollBarDownButtonClick(Sender: TObject);
begin
FHScrollBar.Position := FHScrollBar.Position - FHScrollBar.SmallChange;
SendMessage(Handle, WM_HSCROLL,
MakeWParam(SB_THUMBPOSITION, FHScrollBar.Position), 0);
end;
procedure TbsSkinCustomGrid.OnVScrollBarPageUp(Sender: TObject);
begin
SendMessage(Handle, WM_VSCROLL,
MakeWParam(SB_PAGEUP, 0), 0);
end;
procedure TbsSkinCustomGrid.OnVScrollBarPageDown(Sender: TObject);
begin
SendMessage(Handle, WM_VSCROLL,
MakeWParam(SB_PAGEDOWN, 0), 0);
end;
procedure TbsSkinCustomGrid.OnHScrollBarPageUp(Sender: TObject);
begin
SendMessage(Handle, WM_HSCROLL,
MakeWParam(SB_PAGEUP, 0), 0);
end;
procedure TbsSkinCustomGrid.OnHScrollBarPageDown(Sender: TObject);
begin
SendMessage(Handle, WM_HSCROLL,
MakeWParam(SB_PAGEDOWN, 0), 0);
end;
procedure TbsSkinCustomGrid.OnVScrollBarChange(Sender: TObject);
begin
SendMessage(Handle, WM_VSCROLL,
MakeWParam(SB_THUMBPOSITION, FVScrollBar.Position), 0);
end;
procedure TbsSkinCustomGrid.OnHScrollBarChange(Sender: TObject);
begin
SendMessage(Handle, WM_HSCROLL,
MakeWParam(SB_THUMBPOSITION, FHScrollBar.Position), 0);
end;
function TbsSkinCustomGrid.GetNewTextRect;
var
SR1, SR2, R: TRect;
OX, OY: Integer;
begin
if FIndex < 0
then
begin
Result := CellR;
Exit;
end
else
begin
R := CellR;
if gdFixed in AState
then
begin
SR1 := FixedCellRect;
SR2 := FixedCellTextRect;
end
else
begin
SR1 := SelectCellRect;
SR2 := CellTextRect;
end;
if not IsNullRect(SR2)
then
begin
if not UseSkinCellHeight
then
OY := RectHeight(R) - RectHeight(FixedCellRect)
else
OY := 0;
OX := RectWidth(CellR) - RectWidth(SR1);
Inc(R.Left, SR2.Left);
Inc(R.Top, SR2.Top);
R.Right := R.Left + RectWidth(SR2) + OX;
R.Bottom := R.Top + RectHeight(SR2) + OY;
end;
Result := R;
end
end;
procedure TbsSkinCustomGrid.ChangeSkinData;
var
i, Old: Integer;
begin
GetSkinData;
if FIndex > -1
then
begin
Old := DefaultRowHeight;
i := RectHeight(SelectCellRect);
if (i <> Old) and FUseSkinCellHeight
then
DefaultRowHeight := i
else
Invalidate;
end
else
begin
DefaultRowHeight := FDefaultCellHeight;
Invalidate;
end;
UpDateScrollRange(True);
if FVScrollBar <> nil then FVScrollBar.Align := FVScrollBar.Align;
if FHScrollBar <> nil then FHScrollBar.Align := FHScrollBar.Align;
end;
procedure TbsSkinCustomGrid.GetSkinData;
begin
Picture := nil;
FIndex := -1;
inherited;
if FIndex > -1
then
if TbsDataSkinControl(FSD.CtrlList.Items[FIndex]) is TbsDataSkinGridControl
then
with TbsDataSkinGridControl(FSD.CtrlList.Items[FIndex]) do
begin
//
if (PictureIndex <> -1) and (PictureIndex < FSD.FActivePictures.Count)
then
Picture := TBitMap(FSD.FActivePictures.Items[PictureIndex])
else
Picture := nil;
//
Self.FixedCellRect := FixedCellRect;
Self.SelectCellRect := SelectCellRect;
Self.FocusCellRect := FocusCellRect;
Self.FixedCellLeftOffset := FixedCellLeftOffset;
Self.FixedCellRightOffset := FixedCellRightOffset;
Self.FixedCellTextRect := FixedCellTextRect;
Self.CellLeftOffset := CellLeftOffset;
Self.CellRightOffset := CellRightOffset;
Self.CellTextRect := CellTextRect;
Self.LinesColor := LinesColor;
Self.BGColor := BGColor;
//
Self.FontName := FontName;
Self.FontStyle := FontStyle;
Self.FontHeight := FontHeight;
Self.FontColor := FontColor;
Self.SelectFontColor := SelectFontColor;
Self.FocusFontColor := FocusFontColor;
Self.FixedFontName := FixedFontName;
Self.FixedFontStyle := FixedFontStyle;
Self.FixedFontHeight := FixedFontHeight;
Self.FixedFontColor := FixedFontColor;
if IsNullRect(Self.SelectCellRect)
then
Self.SelectCellRect := Self.FocusCellRect;
if IsNullRect(Self.FocusCellRect)
then
Self.FocusCellRect := Self.SelectCellRect;
if IsNullRect(Self.FixedCellRect)
then
begin
FIndex := -1;
Picture := nil;
end;
end;
end;
procedure TbsSkinCustomGrid.AdjustSize(Index, Amount: Longint; Rows: Boolean);
var
NewCur: TGridCoord;
OldRows, OldCols: Longint;
MovementX, MovementY: Longint;
MoveRect: TGridRect;
ScrollArea: TRect;
AbsAmount: Longint;
function DoSizeAdjust(var Count: Longint; var Extents: Pointer;
DefaultExtent: Integer; var Current: Longint): Longint;
var
I: Integer;
NewCount: Longint;
begin
NewCount := Count + Amount;
if NewCount < Index then InvalidOp(STooManyDeleted);
if (Amount < 0) and Assigned(Extents) then
begin
Result := 0;
for I := Index to Index - Amount - 1 do
Inc(Result, PIntArray(Extents)^[I]);
end
else
Result := Amount * DefaultExtent;
if Extents <> nil then
ModifyExtents(Extents, Index, Amount, DefaultExtent);
Count := NewCount;
if Current >= Index then
if (Amount < 0) and (Current < Index - Amount) then Current := Index
else Inc(Current, Amount);
end;
begin
if Amount = 0 then Exit;
NewCur := FCurrent;
OldCols := ColCount;
OldRows := RowCount;
MoveRect.Left := FixedCols;
MoveRect.Right := ColCount - 1;
MoveRect.Top := FixedRows;
MoveRect.Bottom := RowCount - 1;
MovementX := 0;
MovementY := 0;
AbsAmount := Amount;
if AbsAmount < 0 then AbsAmount := -AbsAmount;
if Rows then
begin
MovementY := DoSizeAdjust(FRowCount, FRowHeights, DefaultRowHeight, NewCur.Y);
MoveRect.Top := Index;
if Index + AbsAmount <= TopRow then MoveRect.Bottom := TopRow - 1;
end
else
begin
MovementX := DoSizeAdjust(FColCount, FColWidths, DefaultColWidth, NewCur.X);
MoveRect.Left := Index;
if Index + AbsAmount <= LeftCol then MoveRect.Right := LeftCol - 1;
end;
GridRectToScreenRect(MoveRect, ScrollArea, True);
if not IsRectEmpty(ScrollArea) then
begin
ScrollWindow(Handle, MovementX, MovementY, @ScrollArea, @ScrollArea);
UpdateWindow(Handle);
end;
SizeChanged(OldCols, OldRows);
if (NewCur.X <> FCurrent.X) or (NewCur.Y <> FCurrent.Y) then
MoveCurrent(NewCur.X, NewCur.Y, True, True);
end;
function TbsSkinCustomGrid.BoxRect(ALeft, ATop, ARight, ABottom: Longint): TRect;
var
GridRect: TGridRect;
begin
GridRect.Left := ALeft;
GridRect.Right := ARight;
GridRect.Top := ATop;
GridRect.Bottom := ABottom;
GridRectToScreenRect(GridRect, Result, False);
end;
procedure TbsSkinCustomGrid.DoExit;
begin
inherited DoExit;
if not (goAlwaysShowEditor in Options) then HideEditor;
end;
function TbsSkinCustomGrid.CellRect(ACol, ARow: Longint): TRect;
begin
Result := BoxRect(ACol, ARow, ACol, ARow);
end;
function TbsSkinCustomGrid.CanEditAcceptKey(Key: Char): Boolean;
begin
Result := True;
end;
function TbsSkinCustomGrid.CanGridAcceptKey(Key: Word; Shift: TShiftState): Boolean;
begin
Result := True;
end;
function TbsSkinCustomGrid.CanEditModify: Boolean;
begin
Result := FCanEditModify;
end;
function TbsSkinCustomGrid.CanEditShow: Boolean;
begin
Result := ([goRowSelect, goEditing] * Options = [goEditing]) and
FEditorMode and not (csDesigning in ComponentState) and HandleAllocated and
((goAlwaysShowEditor in Options) or IsActiveControl);
end;
function TbsSkinCustomGrid.IsActiveControl: Boolean;
var
H: Hwnd;
ParentForm: TCustomForm;
begin
Result := False;
ParentForm := GetParentForm(Self);
if Assigned(ParentForm) then
begin
if (ParentForm.ActiveControl = Self) then
Result := True
end
else
begin
H := GetFocus;
while IsWindow(H) and (Result = False) do
begin
if H = WindowHandle then
Result := True
else
H := GetParent(H);
end;
end;
end;
function TbsSkinCustomGrid.GetEditMask(ACol, ARow: Longint): string;
begin
Result := '';
end;
function TbsSkinCustomGrid.GetEditText(ACol, ARow: Longint): string;
begin
Result := '';
end;
procedure TbsSkinCustomGrid.SetEditText(ACol, ARow: Longint; const Value: string);
begin
end;
function TbsSkinCustomGrid.GetEditLimit: Integer;
begin
Result := 0;
end;
procedure TbsSkinCustomGrid.HideEditor;
begin
FEditorMode := False;
HideEdit;
end;
procedure TbsSkinCustomGrid.ShowEditor;
begin
FEditorMode := True;
UpdateEdit;
end;
procedure TbsSkinCustomGrid.ShowEditorChar(Ch: Char);
begin
ShowEditor;
if FInplaceEdit <> nil then
PostMessage(FInplaceEdit.Handle, WM_CHAR, Word(Ch), 0);
end;
procedure TbsSkinCustomGrid.InvalidateEditor;
begin
FInplaceCol := -1;
FInplaceRow := -1;
UpdateEdit;
end;
procedure TbsSkinCustomGrid.ReadColWidths(Reader: TReader);
var
I: Integer;
begin
with Reader do
begin
ReadListBegin;
for I := 0 to ColCount - 1 do ColWidths[I] := ReadInteger;
ReadListEnd;
end;
end;
procedure TbsSkinCustomGrid.ReadRowHeights(Reader: TReader);
var
I: Integer;
begin
with Reader do
begin
ReadListBegin;
for I := 0 to RowCount - 1 do RowHeights[I] := ReadInteger;
ReadListEnd;
end;
end;
procedure TbsSkinCustomGrid.WriteColWidths(Writer: TWriter);
var
I: Integer;
begin
with Writer do
begin
WriteListBegin;
for I := 0 to ColCount - 1 do WriteInteger(ColWidths[I]);
WriteListEnd;
end;
end;
procedure TbsSkinCustomGrid.WriteRowHeights(Writer: TWriter);
var
I: Integer;
begin
with Writer do
begin
WriteListBegin;
for I := 0 to RowCount - 1 do WriteInteger(RowHeights[I]);
WriteListEnd;
end;
end;
procedure TbsSkinCustomGrid.DefineProperties(Filer: TFiler);
function DoColWidths: Boolean;
begin
if Filer.Ancestor <> nil then
Result := not CompareExtents(TbsSkinCustomGrid(Filer.Ancestor).FColWidths, FColWidths)
else
Result := FColWidths <> nil;
end;
function DoRowHeights: Boolean;
begin
if Filer.Ancestor <> nil then
Result := not CompareExtents(TbsSkinCustomGrid(Filer.Ancestor).FRowHeights, FRowHeights)
else
Result := FRowHeights <> nil;
end;
begin
inherited DefineProperties(Filer);
if FSaveCellExtents then
with Filer do
begin
DefineProperty('ColWidths', ReadColWidths, WriteColWidths, DoColWidths);
DefineProperty('RowHeights', ReadRowHeights, WriteRowHeights, DoRowHeights);
end;
end;
procedure TbsSkinCustomGrid.MoveColumn(FromIndex, ToIndex: Longint);
var
Rect: TGridRect;
begin
if FromIndex = ToIndex then Exit;
if Assigned(FColWidths) then
begin
MoveExtent(FColWidths, FromIndex + 1, ToIndex + 1);
MoveExtent(FTabStops, FromIndex + 1, ToIndex + 1);
end;
MoveAdjust(FCurrent.X, FromIndex, ToIndex);
MoveAdjust(FAnchor.X, FromIndex, ToIndex);
MoveAdjust(FInplaceCol, FromIndex, ToIndex);
Rect.Top := 0;
Rect.Bottom := VisibleRowCount;
if FromIndex < ToIndex then
begin
Rect.Left := FromIndex;
Rect.Right := ToIndex;
end
else
begin
Rect.Left := ToIndex;
Rect.Right := FromIndex;
end;
InvalidateRect(Rect);
ColumnMoved(FromIndex, ToIndex);
if Assigned(FColWidths) then
ColWidthsChanged;
UpdateEdit;
end;
procedure TbsSkinCustomGrid.ColumnMoved(FromIndex, ToIndex: Longint);
begin
end;
procedure TbsSkinCustomGrid.MoveRow(FromIndex, ToIndex: Longint);
begin
if Assigned(FRowHeights) then
MoveExtent(FRowHeights, FromIndex + 1, ToIndex + 1);
MoveAdjust(FCurrent.Y, FromIndex, ToIndex);
MoveAdjust(FAnchor.Y, FromIndex, ToIndex);
MoveAdjust(FInplaceRow, FromIndex, ToIndex);
RowMoved(FromIndex, ToIndex);
if Assigned(FRowHeights) then
RowHeightsChanged;
UpdateEdit;
end;
procedure TbsSkinCustomGrid.RowMoved(FromIndex, ToIndex: Longint);
begin
end;
function TbsSkinCustomGrid.MouseCoord(X, Y: Integer): TGridCoord;
var
DrawInfo: TbsGridDrawInfo;
begin
CalcDrawInfo(DrawInfo);
Result := CalcCoordFromPoint(X, Y, DrawInfo);
if Result.X < 0 then Result.Y := -1
else if Result.Y < 0 then Result.X := -1;
end;
procedure TbsSkinCustomGrid.MoveColRow(ACol, ARow: Longint; MoveAnchor,
Show: Boolean);
begin
MoveCurrent(ACol, ARow, MoveAnchor, Show);
end;
function TbsSkinCustomGrid.SelectCell(ACol, ARow: Longint): Boolean;
begin
Result := True;
end;
procedure TbsSkinCustomGrid.SizeChanged(OldColCount, OldRowCount: Longint);
begin
end;
function TbsSkinCustomGrid.Sizing(X, Y: Integer): Boolean;
var
DrawInfo: TbsGridDrawInfo;
State: TbsGridState;
Index: Longint;
Pos, Ofs: Integer;
begin
State := FGridState;
if State = gsNormal then
begin
CalcDrawInfo(DrawInfo);
CalcSizingState(X, Y, State, Index, Pos, Ofs, DrawInfo);
end;
Result := State <> gsNormal;
end;
procedure TbsSkinCustomGrid.TopLeftChanged;
begin
if FEditorMode and (FInplaceEdit <> nil) then FInplaceEdit.UpdateLoc(CellRect(Col, Row));
end;
procedure FillDWord(var Dest; Count, Value: Integer); register;
asm
XCHG EDX, ECX
PUSH EDI
MOV EDI, EAX
MOV EAX, EDX
REP STOSD
POP EDI
end;
function StackAlloc(Size: Integer): Pointer; register;
asm
POP ECX { return address }
MOV EDX, ESP
ADD EAX, 3
AND EAX, not 3 // round up to keep ESP dword aligned
CMP EAX, 4092
JLE @@2
@@1:
SUB ESP, 4092
PUSH EAX { make sure we touch guard page, to grow stack }
SUB EAX, 4096
JNS @@1
ADD EAX, 4096
@@2:
SUB ESP, EAX
MOV EAX, ESP { function result = low memory address of block }
PUSH EDX { save original SP, for cleanup }
MOV EDX, ESP
SUB EDX, 4
PUSH EDX { save current SP, for sanity check (sp = [sp]) }
PUSH ECX { return to caller }
end;
procedure StackFree(P: Pointer); register;
asm
POP ECX { return address }
MOV EDX, DWORD PTR [ESP]
SUB EAX, 8
CMP EDX, ESP { sanity check #1 (SP = [SP]) }
JNE @@1
CMP EDX, EAX { sanity check #2 (P = this stack block) }
JNE @@1
MOV ESP, DWORD PTR [ESP+4] { restore previous SP }
@@1:
PUSH ECX { return to caller }
end;
procedure TbsSkinCustomGrid.Paint;
var
LineColor: TColor;
DrawInfo: TbsGridDrawInfo;
Sel: TGridRect;
UpdateRect: TRect;
R, AFocRect, FocRect: TRect;
PointsList: PIntArray;
StrokeList: PIntArray;
MaxStroke: Integer;
FrameFlags1, FrameFlags2: DWORD;
B: TBitMap;
procedure DrawLines(DoHorz, DoVert: Boolean; Col, Row: Longint;
const CellBounds: array of Integer; OnColor, OffColor: TColor);
const
FlatPenStyle = PS_Geometric or PS_Solid or PS_EndCap_Flat or PS_Join_Miter;
procedure DrawAxisLines(const AxisInfo: TbsGridAxisDrawInfo;
Cell, MajorIndex: Integer; UseOnColor: Boolean);
var
Line: Integer;
LogBrush: TLOGBRUSH;
Index: Integer;
Points: PIntArray;
StopMajor, StartMinor, StopMinor: Integer;
begin
with Canvas, AxisInfo do
begin
if EffectiveLineWidth <> 0 then
begin
Pen.Width := GridLineWidth;
if UseOnColor then
Pen.Color := OnColor
else
Pen.Color := OffColor;
if Pen.Width > 1 then
begin
LogBrush.lbStyle := BS_Solid;
LogBrush.lbColor := Pen.Color;
LogBrush.lbHatch := 0;
Pen.Handle := ExtCreatePen(FlatPenStyle, Pen.Width, LogBrush, 0, nil);
end;
Points := PointsList;
Line := CellBounds[MajorIndex] + EffectiveLineWidth shr 1 +
GetExtent(Cell);
//!!! ??? Line needs to be incremented for RightToLeftAlignment ???
if UseRightToLeftAlignment and (MajorIndex = 0) then Inc(Line);
StartMinor := CellBounds[MajorIndex xor 1];
StopMinor := CellBounds[2 + (MajorIndex xor 1)];
StopMajor := CellBounds[2 + MajorIndex] + EffectiveLineWidth;
Index := 0;
repeat
Points^[Index + MajorIndex] := Line; { MoveTo }
Points^[Index + (MajorIndex xor 1)] := StartMinor;
Inc(Index, 2);
Points^[Index + MajorIndex] := Line; { LineTo }
Points^[Index + (MajorIndex xor 1)] := StopMinor;
Inc(Index, 2);
Inc(Cell);
Inc(Line, GetExtent(Cell) + EffectiveLineWidth);
until Line > StopMajor;
{ 2 integers per point, 2 points per line -> Index div 4 }
PolyPolyLine(Canvas.Handle, Points^, StrokeList^, Index shr 2);
end;
end;
end;
begin
if (CellBounds[0] = CellBounds[2]) or (CellBounds[1] = CellBounds[3]) then Exit;
if not DoHorz then
begin
DrawAxisLines(DrawInfo.Vert, Row, 1, DoHorz);
DrawAxisLines(DrawInfo.Horz, Col, 0, DoVert);
end
else
begin
DrawAxisLines(DrawInfo.Horz, Col, 0, DoVert);
DrawAxisLines(DrawInfo.Vert, Row, 1, DoHorz);
end;
end;
procedure DrawSkinCell(B: TBitMap; AState: TGridDrawState; W, H: Integer);
var
Buffer: TBitMap;
begin
if not FUseSkinCellHeight
then
begin
Buffer := TBitMap.Create;
B.Width := W;
B.Height := H;
end;
if (gdFixed in AState)
then
begin
if FUseSkinCellHeight
then
CreateHSkinImage(FixedCellLeftOffset, FixedCellRightOffset,
B, Picture, FixedCellRect, W, H)
else
CreateHSkinImage(FixedCellLeftOffset, FixedCellRightOffset,
Buffer, Picture, FixedCellRect, W, H);
if FUseSkinFont
then
with Canvas do
begin
Font.Name := FixedFontName;
Font.Height := FixedFontHeight;
Font.Color := FixedFontColor;
Font.Style := FixedFontStyle;
end
else
begin
Canvas.Font.Assign(Self.Font);
Canvas.Font.Color := FixedFontColor;
end;
if (SkinData <> nil) and (SkinData.ResourceStrData <> nil)
then
Canvas.Font.Charset := SkinData.ResourceStrData.CharSet
else
Canvas.Font.CharSet := Self.Font.CharSet;
end
else
if (gdFocused in AState) or (goRowSelect in Options)
then
begin
if FUseSkinCellHeight
then
CreateHSkinImage(CellLeftOffset, CellRightOffset,
B, Picture, FocusCellRect, W, H)
else
CreateHSkinImage(CellLeftOffset, CellRightOffset,
Buffer, Picture, FocusCellRect, W, H);
if FUseSkinFont
then
with Canvas do
begin
Font.Name := FontName;
Font.Height := FontHeight;
Font.Color := FocusFontColor;
Font.Style := FontStyle;
end
else
begin
Canvas.Font.Assign(Self.Font);
Canvas.Font.Color := FocusFontColor;
end;
if (SkinData <> nil) and (SkinData.ResourceStrData <> nil)
then
Canvas.Font.Charset := SkinData.ResourceStrData.CharSet
else
Canvas.Font.CharSet := Self.Font.CharSet;
end
else
if (gdSelected in AState)
then
begin
if FUseSkinCellHeight
then
CreateHSkinImage(CellLeftOffset, CellRightOffset,
B, Picture, SelectCellRect, W, H)
else
CreateHSkinImage(CellLeftOffset, CellRightOffset,
Buffer, Picture, SelectCellRect, W, H);
if FUseSkinFont
then
with Canvas do
begin
Font.Name := FontName;
Font.Height := FontHeight;
Font.Color := SelectFontColor;
Font.Style := FontStyle;
end
else
begin
Canvas.Font.Assign(Self.Font);
Canvas.Font.Color := SelectFontColor;
end;
if (SkinData <> nil) and (SkinData.ResourceStrData <> nil)
then
Canvas.Font.Charset := SkinData.ResourceStrData.CharSet
else
Canvas.Font.CharSet := Self.Font.CharSet;
end;
if not FUseSkinCellHeight
then
begin
B.Canvas.StretchDraw(Rect(0, 0, W, H), Buffer);
Buffer.Free;
end;
end;
procedure DrawCells(ACol, ARow: Longint; StartX, StartY, StopX, StopY: Integer;
Color: TColor; IncludeDrawState: TGridDrawState);
var
CurCol, CurRow: Longint;
AWhere, Where, TempRect: TRect;
DrawState: TGridDrawState;
Focused: Boolean;
begin
CurRow := ARow;
Where.Top := StartY;
while (Where.Top < StopY) and (CurRow < RowCount) do
begin
CurCol := ACol;
Where.Left := StartX;
Where.Bottom := Where.Top + RowHeights[CurRow];
while (Where.Left < StopX) and (CurCol < ColCount) do
begin
Where.Right := Where.Left + ColWidths[CurCol];
if (Where.Right > Where.Left) and RectVisible(Canvas.Handle, Where) then
begin
DrawState := IncludeDrawState;
Focused := IsActiveControl;
if Focused and (CurRow = Row) and (CurCol = Col) then
Include(DrawState, gdFocused);
if PointInGridRect(CurCol, CurRow, Sel) then
Include(DrawState, gdSelected);
if not (gdFocused in DrawState) or not (goEditing in Options) or
not FEditorMode or (csDesigning in ComponentState) then
begin
if DefaultDrawing or (csDesigning in ComponentState) then
with Canvas do
begin
if FIndex < 0
then
begin
Font := Self.Font;
if (gdSelected in DrawState) and
(not (gdFocused in DrawState) or
([goDrawFocusSelected, goRowSelect] * Options <> []))
then
begin
Brush.Color := clHighlight;
Font.Color := clHighlightText;
FillRect(Where)
end
else
begin
Brush.Color := Color;
FillRect(Where);
if gdFixed in DrawState
then
begin
R := Where;
Frm3D(Canvas, R, clBtnHighLight, clBtnShadow);
end;
end;
end
else
if not (gdSelected in DrawState) and
not (gdFocused in DrawState) and
not (gdFixed in DrawState)
then
begin
if FUseSkinFont
then
begin
Font.Name := FontName;
Font.Height := FontHeight;
Font.Color := FontColor;
Font.Style := FontStyle;
end
else
begin
Font.Assign(Self.Font);
Font.Color := FontColor;
end;
if (SkinData <> nil) and (SkinData.ResourceStrData <> nil)
then
Font.Charset := SkinData.ResourceStrData.CharSet
else
Font.CharSet := Self.Font.CharSet;
Brush.Color := BGColor;
FillRect(Where);
end
else
begin
B := TBitMap.Create;
DrawSkinCell(B, DrawState,
RectWidth(Where), RectHeight(Where));
Draw(Where.Left, Where.Top, B);
B.Free;
end;
end;
DrawCell(CurCol, CurRow, Where, DrawState);
if FIndex < 0
then
if DefaultDrawing and not (csDesigning in ComponentState) and
(gdFocused in DrawState) and
([goEditing, goAlwaysShowEditor] * Options <> [goEditing, goAlwaysShowEditor])
and not (goRowSelect in Options)
then
begin
if not UseRightToLeftAlignment
then
DrawFocusRect(Canvas.Handle, Where)
else
begin
AWhere := Where;
AWhere.Left := Where.Right;
AWhere.Right := Where.Left;
DrawFocusRect(Canvas.Handle, AWhere)
end;
end;
end;
end;
Where.Left := Where.Right + DrawInfo.Horz.EffectiveLineWidth;
Inc(CurCol);
end;
Where.Top := Where.Bottom + DrawInfo.Vert.EffectiveLineWidth;
Inc(CurRow);
end;
end;
begin
if (Width <= 0) or (Height <=0) then Exit;
GetSkinData;
if UseRightToLeftAlignment then ChangeGridOrientation(True);
UpdateRect := Canvas.ClipRect;
CalcDrawInfo(DrawInfo);
with DrawInfo do
begin
if (Horz.EffectiveLineWidth > 0) or (Vert.EffectiveLineWidth > 0) then
begin
{ Draw the grid line in the four areas (fixed, fixed), (variable, fixed),
(fixed, variable) and (variable, variable) }
if FIndex > -1
then
LineColor := LinesColor
else
LineColor := FGridLineColor;
MaxStroke := Max(Horz.LastFullVisibleCell - LeftCol + FixedCols,
Vert.LastFullVisibleCell - TopRow + FixedRows) + 3;
PointsList := StackAlloc(MaxStroke * sizeof(TPoint) * 2);
StrokeList := StackAlloc(MaxStroke * sizeof(Integer));
FillDWord(StrokeList^, MaxStroke, 2);
if ColorToRGB(Color) = clSilver then LineColor := clGray;
DrawLines(goFixedHorzLine in Options, goFixedVertLine in Options,
0, 0, [0, 0, Horz.FixedBoundary, Vert.FixedBoundary], LineColor{clBlack}, FixedColor);
DrawLines(goFixedHorzLine in Options, goFixedVertLine in Options,
LeftCol, 0, [Horz.FixedBoundary, 0, Horz.GridBoundary,
Vert.FixedBoundary], LineColor{clBlack}, FixedColor);
DrawLines(goFixedHorzLine in Options, goFixedVertLine in Options,
0, TopRow, [0, Vert.FixedBoundary, Horz.FixedBoundary,
Vert.GridBoundary], LineColor{clBlack}, FixedColor);
// skin
DrawLines(goHorzLine in Options, goVertLine in Options, LeftCol,
TopRow, [Horz.FixedBoundary, Vert.FixedBoundary, Horz.GridBoundary,
Vert.GridBoundary], LineColor, Color);
//
StackFree(StrokeList);
StackFree(PointsList);
end;
{ Draw the cells in the four areas }
Sel := Selection;
FrameFlags1 := 0;
FrameFlags2 := 0;
if goFixedVertLine in Options then
begin
FrameFlags1 := BF_RIGHT;
FrameFlags2 := BF_LEFT;
end;
if goFixedHorzLine in Options then
begin
FrameFlags1 := FrameFlags1 or BF_BOTTOM;
FrameFlags2 := FrameFlags2 or BF_TOP;
end;
if not IsRightToLeft
then
DrawCells(0, 0, 0, 0, Horz.FixedBoundary, Vert.FixedBoundary, FixedColor,
[gdFixed])
else
DrawCells(0, 0, 1, 0, Horz.FixedBoundary, Vert.FixedBoundary, FixedColor,
[gdFixed]);
DrawCells(LeftCol, 0, Horz.FixedBoundary - FColOffset, 0, Horz.GridBoundary, //!! clip
Vert.FixedBoundary, FixedColor, [gdFixed]);
if not IsRightToLeft
then
DrawCells(0, TopRow, 0, Vert.FixedBoundary, Horz.FixedBoundary,
Vert.GridBoundary, FixedColor, [gdFixed])
else
DrawCells(0, TopRow, 1, Vert.FixedBoundary, Horz.FixedBoundary,
Vert.GridBoundary, FixedColor, [gdFixed]);
DrawCells(LeftCol, TopRow, Horz.FixedBoundary - FColOffset, //!! clip
Vert.FixedBoundary, Horz.GridBoundary, Vert.GridBoundary, Color, []);
if not (csDesigning in ComponentState) and
(goRowSelect in Options) and DefaultDrawing and Focused then
begin
GridRectToScreenRect(GetSelection, FocRect, False);
if FIndex < 0
then
if not UseRightToLeftAlignment
then
Canvas.DrawFocusRect(FocRect)
else
begin
AFocRect := FocRect;
AFocRect.Left := FocRect.Right;
AFocRect.Right := FocRect.Left;
Canvas.DrawFocusRect(AFocRect)
end;
end;
{ Fill in area not occupied by cells }
if Horz.GridBoundary < Horz.GridExtent then
begin
if FIndex > -1
then
Canvas.Brush.Color := BGColor
else
Canvas.Brush.Color := Color;
if not IsRightToLeft
then
Canvas.FillRect(Rect(Horz.GridBoundary, 0, Horz.GridExtent + 1, Vert.GridBoundary))
else
Canvas.FillRect(Rect(Horz.GridBoundary, -20, Horz.GridExtent + 1, Vert.GridBoundary));
end;
if Vert.GridBoundary < Vert.GridExtent then
begin
if FIndex > -1
then
Canvas.Brush.Color := BGColor
else
Canvas.Brush.Color := Color;
if not IsRightToLeft
then
Canvas.FillRect(Rect(0, Vert.GridBoundary, Horz.GridExtent, Vert.GridExtent))
else
Canvas.FillRect(Rect(-20, Vert.GridBoundary, Horz.GridExtent, Vert.GridExtent));
end;
end;
if UseRightToLeftAlignment then ChangeGridOrientation(False);
end;
function TbsSkinCustomGrid.CalcCoordFromPoint(X, Y: Integer;
const DrawInfo: TbsGridDrawInfo): TGridCoord;
function DoCalc(const AxisInfo: TbsGridAxisDrawInfo; N: Integer): Integer;
var
I, Start, Stop: Longint;
Line: Integer;
begin
with AxisInfo do
begin
if N < FixedBoundary then
begin
Start := 0;
Stop := FixedCellCount - 1;
Line := 0;
end
else
begin
Start := FirstGridCell;
Stop := GridCellCount - 1;
Line := FixedBoundary;
end;
Result := -1;
for I := Start to Stop do
begin
Inc(Line, GetExtent(I) + EffectiveLineWidth);
if N < Line then
begin
Result := I;
Exit;
end;
end;
end;
end;
function DoCalcRightToLeft(const AxisInfo: TbsGridAxisDrawInfo; N: Integer): Integer;
var
I, Start, Stop: Longint;
Line: Integer;
begin
N := ClientWidth - N;
with AxisInfo do
begin
if N < FixedBoundary then
begin
Start := 0;
Stop := FixedCellCount - 1;
Line := ClientWidth;
end
else
begin
Start := FirstGridCell;
Stop := GridCellCount - 1;
Line := FixedBoundary;
end;
Result := -1;
for I := Start to Stop do
begin
Inc(Line, GetExtent(I) + EffectiveLineWidth);
if N < Line then
begin
Result := I;
Exit;
end;
end;
end;
end;
begin
if not UseRightToLeftAlignment then
Result.X := DoCalc(DrawInfo.Horz, X)
else
Result.X := DoCalcRightToLeft(DrawInfo.Horz, X);
Result.Y := DoCalc(DrawInfo.Vert, Y);
end;
procedure TbsSkinCustomGrid.CalcDrawInfo(var DrawInfo: TbsGridDrawInfo);
begin
CalcDrawInfoXY(DrawInfo, ClientWidth, ClientHeight);
end;
procedure TbsSkinCustomGrid.CalcDrawInfoXY(var DrawInfo: TbsGridDrawInfo;
UseWidth, UseHeight: Integer);
procedure CalcAxis(var AxisInfo: TbsGridAxisDrawInfo; UseExtent: Integer);
var
I: Integer;
begin
with AxisInfo do
begin
GridExtent := UseExtent;
GridBoundary := FixedBoundary;
FullVisBoundary := FixedBoundary;
LastFullVisibleCell := FirstGridCell;
for I := FirstGridCell to GridCellCount - 1 do
begin
Inc(GridBoundary, GetExtent(I) + EffectiveLineWidth);
if GridBoundary > GridExtent + EffectiveLineWidth then
begin
GridBoundary := GridExtent;
Break;
end;
LastFullVisibleCell := I;
FullVisBoundary := GridBoundary;
end;
end;
end;
begin
CalcFixedInfo(DrawInfo);
CalcAxis(DrawInfo.Horz, UseWidth);
CalcAxis(DrawInfo.Vert, UseHeight);
end;
procedure TbsSkinCustomGrid.CalcFixedInfo(var DrawInfo: TbsGridDrawInfo);
procedure CalcFixedAxis(var Axis: TbsGridAxisDrawInfo; LineOptions: TGridOptions;
FixedCount, FirstCell, CellCount: Integer; GetExtentFunc: TbsGetExtentsFunc);
var
I: Integer;
begin
with Axis do
begin
if LineOptions * Options = [] then
EffectiveLineWidth := 0
else
EffectiveLineWidth := GridLineWidth;
FixedBoundary := 0;
for I := 0 to FixedCount - 1 do
Inc(FixedBoundary, GetExtentFunc(I) + EffectiveLineWidth);
FixedCellCount := FixedCount;
FirstGridCell := FirstCell;
GridCellCount := CellCount;
GetExtent := GetExtentFunc;
end;
end;
begin
CalcFixedAxis(DrawInfo.Horz, [goFixedVertLine, goVertLine], FixedCols,
LeftCol, ColCount, GetColWidths);
CalcFixedAxis(DrawInfo.Vert, [goFixedHorzLine, goHorzLine], FixedRows,
TopRow, RowCount, GetRowHeights);
end;
{ Calculates the TopLeft that will put the given Coord in view }
function TbsSkinCustomGrid.CalcMaxTopLeft(const Coord: TGridCoord;
const DrawInfo: TbsGridDrawInfo): TGridCoord;
function CalcMaxCell(const Axis: TbsGridAxisDrawInfo; Start: Integer): Integer;
var
Line: Integer;
I, Extent: Longint;
begin
Result := Start;
with Axis do
begin
Line := GridExtent + EffectiveLineWidth;
for I := Start downto FixedCellCount do
begin
Extent := GetExtent(I);
Dec(Line, Extent);
Dec(Line, EffectiveLineWidth);
if Line < FixedBoundary then Break;
if Extent > 0 then Result := I;
end;
end;
end;
begin
Result.X := CalcMaxCell(DrawInfo.Horz, Coord.X);
Result.Y := CalcMaxCell(DrawInfo.Vert, Coord.Y);
end;
procedure TbsSkinCustomGrid.CalcSizingState(X, Y: Integer; var State: TbsGridState;
var Index: Longint; var SizingPos, SizingOfs: Integer;
var FixedInfo: TbsGridDrawInfo);
procedure CalcAxisState(const AxisInfo: TbsGridAxisDrawInfo; Pos: Integer;
NewState: TbsGridState);
var
I, Line, Back, Range: Integer;
begin
if UseRightToLeftAlignment then
Pos := ClientWidth - Pos;
with AxisInfo do
begin
Line := FixedBoundary;
Range := EffectiveLineWidth;
Back := 0;
if Range < 7 then
begin
Range := 7;
Back := (Range - EffectiveLineWidth) shr 1;
end;
for I := FirstGridCell to GridCellCount - 1 do
begin
Inc(Line, GetExtent(I));
if Line > GridBoundary then Break;
if (Pos >= Line - Back) and (Pos <= Line - Back + Range) then
begin
State := NewState;
SizingPos := Line;
SizingOfs := Line - Pos;
Index := I;
Exit;
end;
Inc(Line, EffectiveLineWidth);
end;
if (GridBoundary = GridExtent) and (Pos >= GridExtent - Back)
and (Pos <= GridExtent) then
begin
State := NewState;
SizingPos := GridExtent;
SizingOfs := GridExtent - Pos;
Index := LastFullVisibleCell + 1;
end;
end;
end;
function XOutsideHorzFixedBoundary: Boolean;
begin
with FixedInfo do
if not UseRightToLeftAlignment then
Result := X > Horz.FixedBoundary
else
Result := X < ClientWidth - Horz.FixedBoundary;
end;
function XOutsideOrEqualHorzFixedBoundary: Boolean;
begin
with FixedInfo do
if not UseRightToLeftAlignment then
Result := X >= Horz.FixedBoundary
else
Result := X <= ClientWidth - Horz.FixedBoundary;
end;
var
EffectiveOptions: TGridOptions;
begin
State := gsNormal;
Index := -1;
EffectiveOptions := Options;
if csDesigning in ComponentState then
EffectiveOptions := EffectiveOptions + DesignOptionsBoost;
if [goColSizing, goRowSizing] * EffectiveOptions <> [] then
with FixedInfo do
begin
Vert.GridExtent := ClientHeight;
Horz.GridExtent := ClientWidth;
if (XOutsideHorzFixedBoundary) and (goColSizing in EffectiveOptions) then
begin
if Y >= Vert.FixedBoundary then Exit;
CalcAxisState(Horz, X, gsColSizing);
end
else if (Y > Vert.FixedBoundary) and (goRowSizing in EffectiveOptions) then
begin
if XOutsideOrEqualHorzFixedBoundary then Exit;
CalcAxisState(Vert, Y, gsRowSizing);
end;
end;
end;
procedure TbsSkinCustomGrid.ChangeGridOrientation(RightToLeftOrientation: Boolean);
var
Org: TPoint;
Ext: TPoint;
begin
if RightToLeftOrientation then
begin
Org := Point(ClientWidth,0);
Ext := Point(-1,1);
SetMapMode(Canvas.Handle, mm_Anisotropic);
SetWindowOrgEx(Canvas.Handle, Org.X, Org.Y, nil);
SetViewportExtEx(Canvas.Handle, ClientWidth, ClientHeight, nil);
SetWindowExtEx(Canvas.Handle, Ext.X*ClientWidth, Ext.Y*ClientHeight, nil);
end
else
begin
Org := Point(0,0);
Ext := Point(1,1);
SetMapMode(Canvas.Handle, mm_Anisotropic);
SetWindowOrgEx(Canvas.Handle, Org.X, Org.Y, nil);
SetViewportExtEx(Canvas.Handle, ClientWidth, ClientHeight, nil);
SetWindowExtEx(Canvas.Handle, Ext.X*ClientWidth, Ext.Y*ClientHeight, nil);
end;
end;
procedure TbsSkinCustomGrid.ChangeSize(NewColCount, NewRowCount: Longint);
var
OldColCount, OldRowCount: Longint;
OldDrawInfo: TbsGridDrawInfo;
procedure MinRedraw(const OldInfo, NewInfo: TbsGridAxisDrawInfo; Axis: Integer);
var
R: TRect;
First: Integer;
begin
First := Min(OldInfo.LastFullVisibleCell, NewInfo.LastFullVisibleCell);
// Get the rectangle around the leftmost or topmost cell in the target range.
R := CellRect(First and not Axis, First and Axis);
R.Bottom := Height;
R.Right := Width;
Windows.InvalidateRect(Handle, @R, False);
end;
procedure DoChange;
var
Coord: TGridCoord;
NewDrawInfo: TbsGridDrawInfo;
begin
if FColWidths <> nil then
begin
UpdateExtents(FColWidths, ColCount, DefaultColWidth);
UpdateExtents(FTabStops, ColCount, Integer(True));
end;
if FRowHeights <> nil then
UpdateExtents(FRowHeights, RowCount, DefaultRowHeight);
Coord := FCurrent;
if Row >= RowCount then Coord.Y := RowCount - 1;
if Col >= ColCount then Coord.X := ColCount - 1;
if (FCurrent.X <> Coord.X) or (FCurrent.Y <> Coord.Y) then
MoveCurrent(Coord.X, Coord.Y, True, True);
if (FAnchor.X <> Coord.X) or (FAnchor.Y <> Coord.Y) then
MoveAnchor(Coord);
if VirtualView or
(LeftCol <> OldDrawInfo.Horz.FirstGridCell) or
(TopRow <> OldDrawInfo.Vert.FirstGridCell) then
InvalidateGrid
else if HandleAllocated then
begin
CalcDrawInfo(NewDrawInfo);
MinRedraw(OldDrawInfo.Horz, NewDrawInfo.Horz, 0);
MinRedraw(OldDrawInfo.Vert, NewDrawInfo.Vert, -1);
end;
UpdateScrollRange(True);
SizeChanged(OldColCount, OldRowCount);
end;
begin
if HandleAllocated then
CalcDrawInfo(OldDrawInfo);
OldColCount := FColCount;
OldRowCount := FRowCount;
FColCount := NewColCount;
FRowCount := NewRowCount;
if FixedCols > NewColCount then FFixedCols := NewColCount - 1;
if FixedRows > NewRowCount then FFixedRows := NewRowCount - 1;
try
DoChange;
except
{ Could not change size so try to clean up by setting the size back }
FColCount := OldColCount;
FRowCount := OldRowCount;
DoChange;
InvalidateGrid;
raise;
end;
end;
{ Will move TopLeft so that Coord is in view }
procedure TbsSkinCustomGrid.ClampInView(const Coord: TGridCoord);
var
DrawInfo: TbsGridDrawInfo;
MaxTopLeft: TGridCoord;
OldTopLeft: TGridCoord;
begin
if not HandleAllocated then Exit;
CalcDrawInfo(DrawInfo);
with DrawInfo, Coord do
begin
if (X > Horz.LastFullVisibleCell) or
(Y > Vert.LastFullVisibleCell) or (X < LeftCol) or (Y < TopRow) then
begin
OldTopLeft := FTopLeft;
MaxTopLeft := CalcMaxTopLeft(Coord, DrawInfo);
Update;
if X < LeftCol then FTopLeft.X := X
else if X > Horz.LastFullVisibleCell then FTopLeft.X := MaxTopLeft.X;
if Y < TopRow then FTopLeft.Y := Y
else if Y > Vert.LastFullVisibleCell then FTopLeft.Y := MaxTopLeft.Y;
TopLeftMoved(OldTopLeft);
end;
end;
end;
procedure TbsSkinCustomGrid.DrawSizingLine(const DrawInfo: TbsGridDrawInfo);
var
OldPen: TPen;
begin
OldPen := TPen.Create;
try
with Canvas, DrawInfo do
begin
OldPen.Assign(Pen);
Pen.Style := psDot;
Pen.Mode := pmXor;
Pen.Width := 1;
try
if FGridState = gsRowSizing then
begin
MoveTo(0, FSizingPos);
LineTo(Horz.GridBoundary, FSizingPos);
end
else
begin
MoveTo(FSizingPos, 0);
LineTo(FSizingPos, Vert.GridBoundary);
end;
finally
Pen := OldPen;
end;
end;
finally
OldPen.Free;
end;
end;
procedure TbsSkinCustomGrid.DrawMove;
var
OldPen: TPen;
Pos: Integer;
R: TRect;
begin
OldPen := TPen.Create;
try
with Canvas do
begin
OldPen.Assign(Pen);
try
Pen.Style := psDot;
Pen.Mode := pmXor;
Pen.Width := 5;
if FGridState = gsRowMoving then
begin
R := CellRect(0, FMovePos);
if FMovePos > FMoveIndex then
Pos := R.Bottom else
Pos := R.Top;
MoveTo(0, Pos);
LineTo(ClientWidth, Pos);
end
else
begin
R := CellRect(FMovePos, 0);
if FMovePos > FMoveIndex then
if not UseRightToLeftAlignment then
Pos := R.Right
else
Pos := R.Left
else
if not UseRightToLeftAlignment then
Pos := R.Left
else
Pos := R.Right;
MoveTo(Pos, 0);
LineTo(Pos, ClientHeight);
end;
finally
Canvas.Pen := OldPen;
end;
end;
finally