Delphi控件源码

开发平台：

Delphi

bsSkinGrids.pas：源码内容

OldPen.Free;
end;
end;
procedure TbsSkinCustomGrid.FocusCell(ACol, ARow: Longint; MoveAnchor: Boolean);
begin
MoveCurrent(ACol, ARow, MoveAnchor, True);
UpdateEdit;
Click;
end;
procedure TbsSkinCustomGrid.GridRectToScreenRect(GridRect: TGridRect;
var ScreenRect: TRect; IncludeLine: Boolean);
function LinePos(const AxisInfo: TbsGridAxisDrawInfo; Line: Integer): Integer;
var
Start, I: Longint;
begin
with AxisInfo do
begin
Result := 0;
if Line < FixedCellCount then
Start := 0
else
begin
if Line >= FirstGridCell then
Result := FixedBoundary;
Start := FirstGridCell;
end;
for I := Start to Line - 1 do
begin
Inc(Result, GetExtent(I) + EffectiveLineWidth);
if Result > GridExtent then
begin
Result := 0;
Exit;
end;
end;
end;
end;
function CalcAxis(const AxisInfo: TbsGridAxisDrawInfo;
GridRectMin, GridRectMax: Integer;
var ScreenRectMin, ScreenRectMax: Integer): Boolean;
begin
Result := False;
with AxisInfo do
begin
if (GridRectMin >= FixedCellCount) and (GridRectMin < FirstGridCell) then
if GridRectMax < FirstGridCell then
begin
FillChar(ScreenRect, SizeOf(ScreenRect), 0); { erase partial results }
Exit;
end
else
GridRectMin := FirstGridCell;
if GridRectMax > LastFullVisibleCell then
begin
GridRectMax := LastFullVisibleCell;
if GridRectMax < GridCellCount - 1 then Inc(GridRectMax);
if LinePos(AxisInfo, GridRectMax) = 0 then
Dec(GridRectMax);
end;
ScreenRectMin := LinePos(AxisInfo, GridRectMin);
ScreenRectMax := LinePos(AxisInfo, GridRectMax);
if ScreenRectMax = 0 then
ScreenRectMax := ScreenRectMin + GetExtent(GridRectMin)
else
Inc(ScreenRectMax, GetExtent(GridRectMax));
if ScreenRectMax > GridExtent then
ScreenRectMax := GridExtent;
if IncludeLine then Inc(ScreenRectMax, EffectiveLineWidth);
end;
Result := True;
end;
var
DrawInfo: TbsGridDrawInfo;
Hold: Integer;
begin
FillChar(ScreenRect, SizeOf(ScreenRect), 0);
if (GridRect.Left > GridRect.Right) or (GridRect.Top > GridRect.Bottom) then
Exit;
CalcDrawInfo(DrawInfo);
with DrawInfo do
begin
if GridRect.Left > Horz.LastFullVisibleCell + 1 then Exit;
if GridRect.Top > Vert.LastFullVisibleCell + 1 then Exit;
if CalcAxis(Horz, GridRect.Left, GridRect.Right, ScreenRect.Left,
ScreenRect.Right) then
begin
CalcAxis(Vert, GridRect.Top, GridRect.Bottom, ScreenRect.Top,
ScreenRect.Bottom);
end;
end;
if UseRightToLeftAlignment and (Canvas.CanvasOrientation = coLeftToRight) then
begin
Hold := ScreenRect.Left;
ScreenRect.Left := ClientWidth - ScreenRect.Right;
ScreenRect.Right := ClientWidth - Hold;
end;
end;
procedure TbsSkinCustomGrid.Initialize;
begin
FTopLeft.X := FixedCols;
FTopLeft.Y := FixedRows;
FCurrent := FTopLeft;
FAnchor := FCurrent;
if goRowSelect in Options then FAnchor.X := ColCount - 1;
end;
procedure TbsSkinCustomGrid.InvalidateCell(ACol, ARow: Longint);
var
Rect: TGridRect;
begin
Rect.Top := ARow;
Rect.Left := ACol;
Rect.Bottom := ARow;
Rect.Right := ACol;
InvalidateRect(Rect);
end;
procedure TbsSkinCustomGrid.InvalidateCol(ACol: Longint);
var
Rect: TGridRect;
begin
if not HandleAllocated then Exit;
Rect.Top := 0;
Rect.Left := ACol;
Rect.Bottom := VisibleRowCount+1;
Rect.Right := ACol;
InvalidateRect(Rect);
end;
procedure TbsSkinCustomGrid.InvalidateRow(ARow: Longint);
var
Rect: TGridRect;
begin
if not HandleAllocated then Exit;
Rect.Top := ARow;
Rect.Left := 0;
Rect.Bottom := ARow;
Rect.Right := VisibleColCount+1;
InvalidateRect(Rect);
end;
procedure TbsSkinCustomGrid.InvalidateGrid;
begin
Invalidate;
end;
procedure TbsSkinCustomGrid.InvalidateRect(ARect: TGridRect);
var
InvalidRect: TRect;
begin
if not HandleAllocated then Exit;
GridRectToScreenRect(ARect, InvalidRect, True);
Windows.InvalidateRect(Handle, @InvalidRect, False);
end;
procedure TbsSkinCustomGrid.ModifyScrollBar(ScrollBar, ScrollCode, Pos: Cardinal;
UseRightToLeft: Boolean);
var
NewTopLeft, MaxTopLeft: TGridCoord;
OldNewTopLeftX: Integer;
DrawInfo: TbsGridDrawInfo;
RTLFactor: Integer;
function Min: Longint;
begin
if ScrollBar = SB_HORZ then Result := FixedCols
else Result := FixedRows;
end;
function Max: Longint;
begin
if ScrollBar = SB_HORZ then Result := MaxTopLeft.X
else Result := MaxTopLeft.Y;
end;
function PageUp: Longint;
var
MaxTopLeft: TGridCoord;
begin
MaxTopLeft := CalcMaxTopLeft(FTopLeft, DrawInfo);
if ScrollBar = SB_HORZ then
Result := FTopLeft.X - MaxTopLeft.X else
Result := FTopLeft.Y - MaxTopLeft.Y;
if Result < 1 then Result := 1;
end;
function PageDown: Longint;
var
DrawInfo: TbsGridDrawInfo;
begin
CalcDrawInfo(DrawInfo);
with DrawInfo do
if ScrollBar = SB_HORZ then
Result := Horz.LastFullVisibleCell - FTopLeft.X else
Result := Vert.LastFullVisibleCell - FTopLeft.Y;
if Result < 1 then Result := 1;
end;
function CalcScrollBar(Value, ARTLFactor: Longint): Longint;
begin
Result := Value;
case ScrollCode of
SB_LINEUP:
Dec(Result, ARTLFactor);
SB_LINEDOWN:
Inc(Result, ARTLFactor);
SB_PAGEUP:
Dec(Result, PageUp * ARTLFactor);
SB_PAGEDOWN:
Inc(Result, PageDown * ARTLFactor);
SB_THUMBPOSITION, SB_THUMBTRACK:
if (goThumbTracking in Options) or (ScrollCode = SB_THUMBPOSITION) then
begin
if (not UseRightToLeftAlignment) or (ARTLFactor = 1) then
Result := Min + LongMulDiv(Pos, Max - Min, MaxShortInt)
else
Result := Max - LongMulDiv(Pos, Max - Min, MaxShortInt);
end;
SB_BOTTOM:
Result := Max;
SB_TOP:
Result := Min;
end;
end;
procedure ModifyPixelScrollBar(Code, Pos: Cardinal);
var
NewOffset: Integer;
OldOffset: Integer;
R: TGridRect;
GridSpace, ColWidth: Integer;
begin
NewOffset := FColOffset;
ColWidth := ColWidths[DrawInfo.Horz.FirstGridCell];
GridSpace := ClientWidth - DrawInfo.Horz.FixedBoundary;
case Code of
SB_LINEUP: Dec(NewOffset, Canvas.TextWidth('0') * RTLFactor);
SB_LINEDOWN: Inc(NewOffset, Canvas.TextWidth('0') * RTLFactor);
SB_PAGEUP: Dec(NewOffset, GridSpace * RTLFactor);
SB_PAGEDOWN: Inc(NewOffset, GridSpace * RTLFactor);
SB_THUMBPOSITION,
SB_THUMBTRACK:
if (goThumbTracking in Options) or (Code = SB_THUMBPOSITION) then
begin
if not UseRightToLeftAlignment then
NewOffset := Pos
else
NewOffset := Max - Integer(Pos);
end;
SB_BOTTOM: NewOffset := 0;
SB_TOP: NewOffset := ColWidth - GridSpace;
end;
if NewOffset < 0 then
NewOffset := 0
else if NewOffset >= ColWidth - GridSpace then
NewOffset := ColWidth - GridSpace;
if NewOffset <> FColOffset then
begin
OldOffset := FColOffset;
FColOffset := NewOffset;
ScrollData(OldOffset - NewOffset, 0);
FillChar(R, SizeOf(R), 0);
R.Bottom := FixedRows;
InvalidateRect(R);
Update;
UpdateScrollPos(True);
end;
end;
begin
if (not UseRightToLeftAlignment) or (not UseRightToLeft) then
RTLFactor := 1
else
RTLFactor := -1;
if Visible and CanFocus and TabStop and not (csDesigning in ComponentState) then
SetFocus;
CalcDrawInfo(DrawInfo);
if (ScrollBar = SB_HORZ) and (ColCount = 1) then
begin
ModifyPixelScrollBar(ScrollCode, Pos);
Exit;
end;
MaxTopLeft.X := ColCount - 1;
MaxTopLeft.Y := RowCount - 1;
MaxTopLeft := CalcMaxTopLeft(MaxTopLeft, DrawInfo);
NewTopLeft := FTopLeft;
if ScrollBar = SB_HORZ then
repeat
//
OldNewTopLeftX := NewTopLeft.X;
NewTopLeft.X := CalcScrollBar(NewTopLeft.X, RTLFactor);
//
if OldNewTopLeftX = NewTopLeft.X then Break;
until (NewTopLeft.X <= FixedCols) or (NewTopLeft.X >= MaxTopLeft.X)
or (ColWidths[NewTopLeft.X] > 0)
else
repeat
//
OldNewTopLeftX := NewTopLeft.X;
NewTopLeft.Y := CalcScrollBar(NewTopLeft.Y, 1);
//
if OldNewTopLeftX = NewTopLeft.X then Break;
until (NewTopLeft.Y <= FixedRows) or (NewTopLeft.Y >= MaxTopLeft.Y)
or (RowHeights[NewTopLeft.Y] > 0);
NewTopLeft.X := Math.Max(FixedCols, Math.Min(MaxTopLeft.X, NewTopLeft.X));
NewTopLeft.Y := Math.Max(FixedRows, Math.Min(MaxTopLeft.Y, NewTopLeft.Y));
if (NewTopLeft.X <> FTopLeft.X) or (NewTopLeft.Y <> FTopLeft.Y) then
MoveTopLeft(NewTopLeft.X, NewTopLeft.Y);
end;
procedure TbsSkinCustomGrid.MoveAdjust(var CellPos: Longint; FromIndex, ToIndex: Longint);
var
Min, Max: Longint;
begin
if CellPos = FromIndex then CellPos := ToIndex
else
begin
Min := FromIndex;
Max := ToIndex;
if FromIndex > ToIndex then
begin
Min := ToIndex;
Max := FromIndex;
end;
if (CellPos >= Min) and (CellPos <= Max) then
if FromIndex > ToIndex then
Inc(CellPos) else
Dec(CellPos);
end;
end;
procedure TbsSkinCustomGrid.MoveAnchor(const NewAnchor: TGridCoord);
var
OldSel: TGridRect;
begin
if [goRangeSelect, goEditing] * Options = [goRangeSelect] then
begin
OldSel := Selection;
FAnchor := NewAnchor;
if goRowSelect in Options then FAnchor.X := ColCount - 1;
ClampInView(NewAnchor);
SelectionMoved(OldSel);
end
else MoveCurrent(NewAnchor.X, NewAnchor.Y, True, True);
end;
procedure TbsSkinCustomGrid.MoveCurrent(ACol, ARow: Longint; MoveAnchor,
Show: Boolean);
var
OldSel: TGridRect;
OldCurrent: TGridCoord;
begin
if (ACol < 0) or (ARow < 0) or (ACol >= ColCount) or (ARow >= RowCount) then
InvalidOp(SIndexOutOfRange);
if SelectCell(ACol, ARow) then
begin
OldSel := Selection;
OldCurrent := FCurrent;
FCurrent.X := ACol;
FCurrent.Y := ARow;
if not (goAlwaysShowEditor in Options) then HideEditor;
if MoveAnchor or not (goRangeSelect in Options) then
begin
FAnchor := FCurrent;
if goRowSelect in Options then FAnchor.X := ColCount - 1;
end;
if goRowSelect in Options then FCurrent.X := FixedCols;
if Show then ClampInView(FCurrent);
SelectionMoved(OldSel);
with OldCurrent do InvalidateCell(X, Y);
with FCurrent do InvalidateCell(ACol, ARow);
end;
end;
procedure TbsSkinCustomGrid.MoveTopLeft(ALeft, ATop: Longint);
var
OldTopLeft: TGridCoord;
begin
if (ALeft = FTopLeft.X) and (ATop = FTopLeft.Y) then Exit;
Update;
OldTopLeft := FTopLeft;
FTopLeft.X := ALeft;
FTopLeft.Y := ATop;
TopLeftMoved(OldTopLeft);
end;
procedure TbsSkinCustomGrid.ResizeCol(Index: Longint; OldSize, NewSize: Integer);
begin
InvalidateGrid;
end;
procedure TbsSkinCustomGrid.ResizeRow(Index: Longint; OldSize, NewSize: Integer);
begin
InvalidateGrid;
end;
procedure TbsSkinCustomGrid.SelectionMoved(const OldSel: TGridRect);
var
OldRect, NewRect: TRect;
AXorRects: TXorRects;
I: Integer;
begin
if not HandleAllocated then Exit;
GridRectToScreenRect(OldSel, OldRect, True);
GridRectToScreenRect(Selection, NewRect, True);
XorRects(OldRect, NewRect, AXorRects);
for I := Low(AXorRects) to High(AXorRects) do
Windows.InvalidateRect(Handle, @AXorRects[I], False);
end;
procedure TbsSkinCustomGrid.ScrollDataInfo(DX, DY: Integer;
var DrawInfo: TbsGridDrawInfo);
var
ScrollArea: TRect;
ScrollFlags: Integer;
begin
with DrawInfo do
begin
ScrollFlags := SW_INVALIDATE;
if not DefaultDrawing then
ScrollFlags := ScrollFlags or SW_ERASE;
{ Scroll the area }
if DY = 0 then
begin
{ Scroll both the column titles and data area at the same time }
if not UseRightToLeftAlignment then
ScrollArea := Rect(Horz.FixedBoundary, 0, Horz.GridExtent-1, Vert.GridExtent)
else
begin
ScrollArea := Rect(ClientWidth - Horz.GridExtent + 1, 0, ClientWidth - Horz.FixedBoundary, Vert.GridExtent);
DX := -DX;
end;
ScrollWindowEx(Handle, DX, 0, @ScrollArea, @ScrollArea, 0, nil, ScrollFlags);
end
else if DX = 0 then
begin
{ Scroll both the row titles and data area at the same time }
ScrollArea := Rect(0, Vert.FixedBoundary, Horz.GridExtent, Vert.GridExtent);
ScrollWindowEx(Handle, 0, DY, @ScrollArea, @ScrollArea, 0, nil, ScrollFlags);
end
else
begin
{ Scroll titles and data area separately }
{ Column titles }
ScrollArea := Rect(Horz.FixedBoundary, 0, Horz.GridExtent-1, Vert.FixedBoundary);
ScrollWindowEx(Handle, DX, 0, @ScrollArea, @ScrollArea, 0, nil, ScrollFlags);
{ Row titles }
ScrollArea := Rect(0, Vert.FixedBoundary, Horz.FixedBoundary, Vert.GridExtent);
ScrollWindowEx(Handle, 0, DY, @ScrollArea, @ScrollArea, 0, nil, ScrollFlags);
{ Data area }
ScrollArea := Rect(Horz.FixedBoundary, Vert.FixedBoundary, Horz.GridExtent,
Vert.GridExtent);
ScrollWindowEx(Handle, DX, DY, @ScrollArea, @ScrollArea, 0, nil, ScrollFlags);
end;
end;
if goRowSelect in Options then
InvalidateRect(Selection);
end;
procedure TbsSkinCustomGrid.ScrollData(DX, DY: Integer);
var
DrawInfo: TbsGridDrawInfo;
begin
CalcDrawInfo(DrawInfo);
ScrollDataInfo(DX, DY, DrawInfo);
end;
procedure TbsSkinCustomGrid.TopLeftMoved(const OldTopLeft: TGridCoord);
function CalcScroll(const AxisInfo: TbsGridAxisDrawInfo;
OldPos, CurrentPos: Integer; var Amount: Longint): Boolean;
var
Start, Stop: Longint;
I: Longint;
begin
Result := False;
with AxisInfo do
begin
if OldPos < CurrentPos then
begin
Start := OldPos;
Stop := CurrentPos;
end
else
begin
Start := CurrentPos;
Stop := OldPos;
end;
Amount := 0;
for I := Start to Stop - 1 do
begin
Inc(Amount, GetExtent(I) + EffectiveLineWidth);
if Amount > (GridBoundary - FixedBoundary) then
begin
{ Scroll amount too big, redraw the whole thing }
InvalidateGrid;
Exit;
end;
end;
if OldPos < CurrentPos then Amount := -Amount;
end;
Result := True;
end;
var
DrawInfo: TbsGridDrawInfo;
Delta: TGridCoord;
R: TRect;
begin
UpdateScrollPos(True);
CalcDrawInfo(DrawInfo);
if CalcScroll(DrawInfo.Horz, OldTopLeft.X, FTopLeft.X, Delta.X) and
CalcScroll(DrawInfo.Vert, OldTopLeft.Y, FTopLeft.Y, Delta.Y) then
ScrollDataInfo(Delta.X, Delta.Y, DrawInfo);
TopLeftChanged;
R.Left := GridWidth;
if R.Left >= Width then R.Left := Width - 1;
R.Top := 0;
R.Right := Width;
R.Bottom := Height;
Windows.InvalidateRect(Handle, @R, True);
end;
procedure TbsSkinCustomGrid.UpdateScrollPos;
var
DrawInfo: TbsGridDrawInfo;
MaxTopLeft: TGridCoord;
GridSpace, ColWidth: Integer;
procedure SetScroll(Code: Word; Value: Integer);
begin
if UseRightToLeftAlignment and (Code = SB_HORZ) then
if ColCount <> 1 then Value := MaxShortInt - Value
else Value := (ColWidth - GridSpace) - Value;
case Code of
SB_HORZ:
if FHScrollBar <> nil then
begin
FHScrollBar.SimplySetPosition(Value);
end;
SB_VERT:
if (FVScrollBar <> nil) and UpDateVert then
begin
FVScrollBar.SimplySetPosition(Value);
end;
end;
end;
begin
if (not HandleAllocated) then Exit;
CalcDrawInfo(DrawInfo);
MaxTopLeft.X := ColCount - 1;
MaxTopLeft.Y := RowCount - 1;
MaxTopLeft := CalcMaxTopLeft(MaxTopLeft, DrawInfo);
if ColCount = 1 then
begin
ColWidth := ColWidths[DrawInfo.Horz.FirstGridCell];
GridSpace := ClientWidth - DrawInfo.Horz.FixedBoundary;
if (FColOffset > 0) and (GridSpace > (ColWidth - FColOffset)) then
ModifyScrollbar(SB_HORZ, SB_THUMBPOSITION, ColWidth - GridSpace, True)
else
SetScroll(SB_HORZ, FColOffset)
end
else
SetScroll(SB_HORZ, LongMulDiv(FTopLeft.X - FixedCols, MaxShortInt,
MaxTopLeft.X - FixedCols));
SetScroll(SB_VERT, LongMulDiv(FTopLeft.Y - FixedRows, MaxShortInt,
MaxTopLeft.Y - FixedRows));
end;
type
ParentControl = class(TWinControl);
procedure TbsSkinCustomGrid.UpdateScrollRange;
var
MaxTopLeft, OldTopLeft: TGridCoord;
DrawInfo: TbsGridDrawInfo;
Updated: Boolean;
VVisibleChanged, HVisibleChanged: Boolean;
VVisible, HVisible: Boolean;
K: Integer;
procedure DoUpdate;
begin
if not Updated then
begin
Update;
Updated := True;
end;
end;
procedure CalcSizeInfo;
begin
CalcDrawInfoXY(DrawInfo, DrawInfo.Horz.GridExtent, DrawInfo.Vert.GridExtent);
MaxTopLeft.X := ColCount - 1;
MaxTopLeft.Y := RowCount - 1;
MaxTopLeft := CalcMaxTopLeft(MaxTopLeft, DrawInfo);
end;
procedure SetAxisRange(var Max, Old, Current: Longint; Code: Word;
Fixeds: Integer);
begin
CalcSizeInfo;
if Fixeds < Max then
begin
case Code of
SB_HORZ:
if FHScrollBar <> nil then
begin
FHScrollBar.SetRange(0, MaxShortInt, FHScrollBar.Position, 0);
K := ColCount - GetVisibleColCount - FixedCols;
if K = 0 then K := 1;
FHScrollBar.SmallChange := FHScrollBar.Max div K;
if FHScrollBar.SmallChange = 0
then FHScrollBar.SmallChange := 1;
FHScrollBar.LargeChange := FHScrollBar.SmallChange;
if not FHScrollBar.Visible
then
begin
HVisible := True;
HVisibleChanged := True;
end;
end;
SB_VERT:
if (FVScrollBar <> nil) and UpDateVert then
begin
FVScrollBar.SetRange(0, MaxShortInt, FVScrollBar.Position, 0);
FVScrollBar.SmallChange := FVScrollBar.Max div
(RowCount - GetVisibleRowCount - FixedRows);
if FVScrollBar.SmallChange = 0
then FVScrollBar.SmallChange := 1;
FVScrollBar.LargeChange := FVScrollBar.SmallChange;
if not FVScrollBar.Visible
then
begin
VVisibleChanged := True;
VVisible := True;
end;
end
end;
end
else
begin
case Code of
SB_HORZ:
if FHScrollBar <> nil then
begin
FHScrollBar.SetRange(0, 0, 0, 0);
if FHScrollBar.Visible
then
begin
HVisibleChanged := True;
HVisible := False;
end;
end;
SB_VERT:
if (FVScrollBar <> nil) and UpDateVert then
begin
FVScrollBar.SetRange(0, 0, 0, 0);
if FVScrollBar.Visible
then
begin
VVisibleChanged := True;
VVisible := False;
end;
end;
end;
end;
if Old > Max then
begin
DoUpdate;
Current := Max;
end;
end;
procedure SetHorzRange;
var
Range: Integer;
begin
if ColCount = 1 then
begin
Range := ColWidths[0] - ClientWidth;
if Range < 0 then Range := 0;
// skinscroll
if (FHScrollBar <> nil)
then
if Range > 0
then
begin
FHScrollBar.SetRange(0, Range, FHScrollBar.Position, 0);
K := ColCount - GetVisibleColCount - FixedCols;
if K = 0 then K := 1;
FHScrollBar.SmallChange := FHScrollBar.Max div K;
if FHScrollBar.SmallChange = 0
then FHScrollBar.SmallChange := 1;
FHScrollBar.LargeChange := FHScrollBar.SmallChange;
if not FHScrollBar.Visible
then
begin
HVisibleChanged := True;
HVisible:= True;
end;
end
else
if FHScrollBar.Visible
then
begin
HVisibleChanged := True;
HVisible:= False;
end;
end
else
SetAxisRange(MaxTopLeft.X, OldTopLeft.X, FTopLeft.X, SB_HORZ, FixedCols);
end;
procedure SetVertRange;
begin
SetAxisRange(MaxTopLeft.Y, OldTopLeft.Y, FTopLeft.Y, SB_VERT, FixedRows);
end;
var
R: TRect;
begin
if not HandleAllocated or not Showing or FInCheckScrollBars then Exit;
VVisibleChanged := False;
HVisibleChanged := False;
with DrawInfo do
begin
Horz.GridExtent := ClientWidth;
Vert.GridExtent := ClientHeight;
end;
OldTopLeft := FTopLeft;
{ Temporarily mark us as not having scroll bars to avoid recursion }
Updated := False;
SetHorzRange;
DrawInfo.Vert.GridExtent := ClientHeight;
SetVertRange;
if DrawInfo.Horz.GridExtent <> ClientWidth then
begin
DrawInfo.Horz.GridExtent := ClientWidth;
SetHorzRange;
end;
UpdateScrollPos(True);
if (FTopLeft.X <> OldTopLeft.X) or (FTopLeft.Y <> OldTopLeft.Y) then
TopLeftMoved(OldTopLeft);
FInCheckScrollBars := True;
if VVisibleChanged then FVScrollBar.Visible := VVisible;
if HVisibleChanged then FHScrollBar.Visible := HVisible;
FInCheckScrollBars := False;
if (FVScrollBar <> nil) and (FHScrollBar <> nil)
then
begin
if not FVScrollBar.Visible and FHScrollBar.Both
then
FHScrollBar.Both := False
else
if FVScrollBar.Visible and not FHScrollBar.Both
then
FHScrollBar.Both := True;
end;
if (Self.Align <> alNone) and (HVisibleChanged or VVisibleChanged)
then
begin
R := Parent.ClientRect;
FInCheckScrollBars := True;
ParentControl(Parent).AlignControls(nil, R);
Invalidate;
FInCheckScrollBars := False;
end;
end;
function TbsSkinCustomGrid.CreateEditor: TbsSkinInplaceEdit;
begin
Result := TbsSkinInplaceEdit.Create(Self);
end;
procedure TbsSkinCustomGrid.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
with Params do
begin
Style := Style or WS_TABSTOP;
Style := Style and not WS_VSCROLL;
Style := Style and not WS_HSCROLL;
WindowClass.style := CS_DBLCLKS;
end;
end;
procedure TbsSkinCustomGrid.KeyDown(var Key: Word; Shift: TShiftState);
var
NewTopLeft, NewCurrent, MaxTopLeft: TGridCoord;
DrawInfo: TbsGridDrawInfo;
PageWidth, PageHeight: Integer;
RTLFactor: Integer;
procedure CalcPageExtents;
begin
CalcDrawInfo(DrawInfo);
PageWidth := DrawInfo.Horz.LastFullVisibleCell - LeftCol;
if PageWidth < 1 then PageWidth := 1;
PageHeight := DrawInfo.Vert.LastFullVisibleCell - TopRow;
if PageHeight < 1 then PageHeight := 1;
end;
procedure Restrict(var Coord: TGridCoord; MinX, MinY, MaxX, MaxY: Longint);
begin
with Coord do
begin
if X > MaxX then X := MaxX
else if X < MinX then X := MinX;
if Y > MaxY then Y := MaxY
else if Y < MinY then Y := MinY;
end;
end;
begin
inherited KeyDown(Key, Shift);
if not CanGridAcceptKey(Key, Shift) then Key := 0;
if not UseRightToLeftAlignment then
RTLFactor := 1
else
RTLFactor := -1;
NewCurrent := FCurrent;
NewTopLeft := FTopLeft;
CalcPageExtents;
if ssCtrl in Shift then
case Key of
VK_UP: Dec(NewTopLeft.Y);
VK_DOWN: Inc(NewTopLeft.Y);
VK_LEFT:
if not (goRowSelect in Options) then
begin
Dec(NewCurrent.X, PageWidth * RTLFactor);
Dec(NewTopLeft.X, PageWidth * RTLFactor);
end;
VK_RIGHT:
if not (goRowSelect in Options) then
begin
Inc(NewCurrent.X, PageWidth * RTLFactor);
Inc(NewTopLeft.X, PageWidth * RTLFactor);
end;
VK_PRIOR: NewCurrent.Y := TopRow;
VK_NEXT: NewCurrent.Y := DrawInfo.Vert.LastFullVisibleCell;
VK_HOME:
begin
NewCurrent.X := FixedCols;
NewCurrent.Y := FixedRows;
end;
VK_END:
begin
NewCurrent.X := ColCount - 1;
NewCurrent.Y := RowCount - 1;
end;
end
else
case Key of
VK_UP: Dec(NewCurrent.Y);
VK_DOWN: Inc(NewCurrent.Y);
VK_LEFT:
if goRowSelect in Options then
Dec(NewCurrent.Y, RTLFactor) else
Dec(NewCurrent.X, RTLFactor);
VK_RIGHT:
if goRowSelect in Options then
Inc(NewCurrent.Y, RTLFactor) else
Inc(NewCurrent.X, RTLFactor);
VK_NEXT:
begin
Inc(NewCurrent.Y, PageHeight);
Inc(NewTopLeft.Y, PageHeight);
end;
VK_PRIOR:
begin
Dec(NewCurrent.Y, PageHeight);
Dec(NewTopLeft.Y, PageHeight);
end;
VK_HOME:
if goRowSelect in Options then
NewCurrent.Y := FixedRows else
NewCurrent.X := FixedCols;
VK_END:
if goRowSelect in Options then
NewCurrent.Y := RowCount - 1 else
NewCurrent.X := ColCount - 1;
VK_TAB:
if not (ssAlt in Shift) then
repeat
if ssShift in Shift then
begin
Dec(NewCurrent.X);
if NewCurrent.X < FixedCols then
begin
NewCurrent.X := ColCount - 1;
Dec(NewCurrent.Y);
if NewCurrent.Y < FixedRows then NewCurrent.Y := RowCount - 1;
end;
Shift := [];
end
else
begin
Inc(NewCurrent.X);
if NewCurrent.X >= ColCount then
begin
NewCurrent.X := FixedCols;
Inc(NewCurrent.Y);
if NewCurrent.Y >= RowCount then NewCurrent.Y := FixedRows;
end;
end;
until TabStops[NewCurrent.X] or (NewCurrent.X = FCurrent.X);
VK_F2: EditorMode := True;
end;
MaxTopLeft.X := ColCount - 1;
MaxTopLeft.Y := RowCount - 1;
MaxTopLeft := CalcMaxTopLeft(MaxTopLeft, DrawInfo);
Restrict(NewTopLeft, FixedCols, FixedRows, MaxTopLeft.X, MaxTopLeft.Y);
if (NewTopLeft.X <> LeftCol) or (NewTopLeft.Y <> TopRow) then
MoveTopLeft(NewTopLeft.X, NewTopLeft.Y);
Restrict(NewCurrent, FixedCols, FixedRows, ColCount - 1, RowCount - 1);
if (NewCurrent.X <> Col) or (NewCurrent.Y <> Row) then
FocusCell(NewCurrent.X, NewCurrent.Y, not (ssShift in Shift));
end;
procedure TbsSkinCustomGrid.KeyPress(var Key: Char);
begin
inherited KeyPress(Key);
if not (goAlwaysShowEditor in Options) and (Key = #13) then
begin
if FEditorMode then
HideEditor else
ShowEditor;
Key := #0;
end;
end;
procedure TbsSkinCustomGrid.MouseDown(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer);
var
CellHit: TGridCoord;
DrawInfo: TbsGridDrawInfo;
MoveDrawn: Boolean;
begin
MoveDrawn := False;
HideEdit;
if not (csDesigning in ComponentState) and
(CanFocus or (GetParentForm(Self) = nil)) then
begin
SetFocus;
if not IsActiveControl then
begin
MouseCapture := False;
Exit;
end;
end;
if (Button = mbLeft) and (ssDouble in Shift) then
DblClick
else if Button = mbLeft then
begin
CalcDrawInfo(DrawInfo);
{ Check grid sizing }
CalcSizingState(X, Y, FGridState, FSizingIndex, FSizingPos, FSizingOfs,
DrawInfo);
if FGridState <> gsNormal then
begin
if UseRightToLeftAlignment then
FSizingPos := ClientWidth - FSizingPos;
DrawSizingLine(DrawInfo);
Exit;
end;
CellHit := CalcCoordFromPoint(X, Y, DrawInfo);
if (CellHit.X >= FixedCols) and (CellHit.Y >= FixedRows) then
begin
if goEditing in Options then
begin
if (CellHit.X = FCurrent.X) and (CellHit.Y = FCurrent.Y) then
ShowEditor
else
begin
MoveCurrent(CellHit.X, CellHit.Y, True, True);
UpdateEdit;
end;
Click;
end
else
begin
FGridState := gsSelecting;
SetTimer(Handle, 1, 60, nil);
if ssShift in Shift then
MoveAnchor(CellHit)
else
MoveCurrent(CellHit.X, CellHit.Y, True, True);
end;
end
else if (goRowMoving in Options) and (CellHit.X >= 0) and
(CellHit.X < FixedCols) and (CellHit.Y >= FixedRows) then
begin
FMoveIndex := CellHit.Y;
FMovePos := FMoveIndex;
if BeginRowDrag(FMoveIndex, FMovePos, Point(X,Y)) then
begin
FGridState := gsRowMoving;
Update;
DrawMove;
MoveDrawn := True;
SetTimer(Handle, 1, 60, nil);
end;
end
else if (goColMoving in Options) and (CellHit.Y >= 0) and
(CellHit.Y < FixedRows) and (CellHit.X >= FixedCols) then
begin
FMoveIndex := CellHit.X;
FMovePos := FMoveIndex;
if BeginColumnDrag(FMoveIndex, FMovePos, Point(X,Y)) then
begin
FGridState := gsColMoving;
Update;
DrawMove;
MoveDrawn := True;
SetTimer(Handle, 1, 60, nil);
end;
end;
end;
try
inherited MouseDown(Button, Shift, X, Y);
except
if MoveDrawn then DrawMove;
end;
end;
procedure TbsSkinCustomGrid.MouseMove(Shift: TShiftState; X, Y: Integer);
var
DrawInfo: TbsGridDrawInfo;
CellHit: TGridCoord;
begin
CalcDrawInfo(DrawInfo);
case FGridState of
gsSelecting, gsColMoving, gsRowMoving:
begin
CellHit := CalcCoordFromPoint(X, Y, DrawInfo);
if (CellHit.X >= FixedCols) and (CellHit.Y >= FixedRows) and
(CellHit.X <= DrawInfo.Horz.LastFullVisibleCell+1) and
(CellHit.Y <= DrawInfo.Vert.LastFullVisibleCell+1) then
case FGridState of
gsSelecting:
if ((CellHit.X <> FAnchor.X) or (CellHit.Y <> FAnchor.Y)) then
MoveAnchor(CellHit);
gsColMoving:
MoveAndScroll(X, CellHit.X, DrawInfo, DrawInfo.Horz, SB_HORZ, Point(X,Y));
gsRowMoving:
MoveAndScroll(Y, CellHit.Y, DrawInfo, DrawInfo.Vert, SB_VERT, Point(X,Y));
end;
end;
gsRowSizing, gsColSizing:
begin
DrawSizingLine(DrawInfo); { XOR it out }
if FGridState = gsRowSizing then
FSizingPos := Y + FSizingOfs else
FSizingPos := X + FSizingOfs;
DrawSizingLine(DrawInfo); { XOR it back in }
end;
end;
inherited MouseMove(Shift, X, Y);
end;
procedure TbsSkinCustomGrid.MouseUp(Button: TMouseButton; Shift: TShiftState;
X, Y: Integer);
var
DrawInfo: TbsGridDrawInfo;
NewSize: Integer;
function ResizeLine(const AxisInfo: TbsGridAxisDrawInfo): Integer;
var
I: Integer;
begin
with AxisInfo do
begin
Result := FixedBoundary;
for I := FirstGridCell to FSizingIndex - 1 do
Inc(Result, GetExtent(I) + EffectiveLineWidth);
Result := FSizingPos - Result;
end;
end;
begin
try
case FGridState of
gsSelecting:
begin
MouseMove(Shift, X, Y);
KillTimer(Handle, 1);
UpdateEdit;
Click;
end;
gsRowSizing, gsColSizing:
begin
CalcDrawInfo(DrawInfo);
DrawSizingLine(DrawInfo);
if UseRightToLeftAlignment then
FSizingPos := ClientWidth - FSizingPos;
if FGridState = gsColSizing then
begin
NewSize := ResizeLine(DrawInfo.Horz);
if NewSize > 1 then
begin
ColWidths[FSizingIndex] := NewSize;
UpdateDesigner;
end;
end
else
begin
NewSize := ResizeLine(DrawInfo.Vert);
if NewSize > 1 then
begin
RowHeights[FSizingIndex] := NewSize;
UpdateDesigner;
end;
end;
end;
gsColMoving:
begin
DrawMove;
KillTimer(Handle, 1);
if EndColumnDrag(FMoveIndex, FMovePos, Point(X,Y))
and (FMoveIndex <> FMovePos) then
begin
MoveColumn(FMoveIndex, FMovePos);
UpdateDesigner;
end;
UpdateEdit;
end;
gsRowMoving:
begin
DrawMove;
KillTimer(Handle, 1);
if EndRowDrag(FMoveIndex, FMovePos, Point(X,Y))
and (FMoveIndex <> FMovePos) then
begin
MoveRow(FMoveIndex, FMovePos);
UpdateDesigner;
end;
UpdateEdit;
end;
else
UpdateEdit;
end;
inherited MouseUp(Button, Shift, X, Y);
finally
FGridState := gsNormal;
end;
end;
procedure TbsSkinCustomGrid.MoveAndScroll(Mouse, CellHit: Integer;
var DrawInfo: TbsGridDrawInfo; var Axis: TbsGridAxisDrawInfo;
ScrollBar: Integer; const MousePt: TPoint);
begin
if UseRightToLeftAlignment and (ScrollBar = SB_HORZ) then
Mouse := ClientWidth - Mouse;
if (CellHit <> FMovePos) and
not((FMovePos = Axis.FixedCellCount) and (Mouse < Axis.FixedBoundary)) and
not((FMovePos = Axis.GridCellCount-1) and (Mouse > Axis.GridBoundary)) then
begin
DrawMove; // hide the drag line
if (Mouse < Axis.FixedBoundary) then
begin
if (FMovePos > Axis.FixedCellCount) then
begin
ModifyScrollbar(ScrollBar, SB_LINEUP, 0, False);
Update;
CalcDrawInfo(DrawInfo); // this changes contents of Axis var
end;
CellHit := Axis.FirstGridCell;
end
else if (Mouse >= Axis.FullVisBoundary) then
begin
if (FMovePos = Axis.LastFullVisibleCell) and
(FMovePos < Axis.GridCellCount -1) then
begin
ModifyScrollBar(Scrollbar, SB_LINEDOWN, 0, False);
Update;
CalcDrawInfo(DrawInfo); // this changes contents of Axis var
end;
CellHit := Axis.LastFullVisibleCell;
end
else if CellHit < 0 then CellHit := FMovePos;
if ((FGridState = gsColMoving) and CheckColumnDrag(FMoveIndex, CellHit, MousePt))
or ((FGridState = gsRowMoving) and CheckRowDrag(FMoveIndex, CellHit, MousePt)) then
FMovePos := CellHit;
DrawMove;
end;
end;
function TbsSkinCustomGrid.GetColWidths(Index: Longint): Integer;
begin
if (FColWidths = nil) or (Index >= ColCount) then
Result := DefaultColWidth
else
Result := PIntArray(FColWidths)^[Index + 1];
end;
function TbsSkinCustomGrid.GetRowHeights(Index: Longint): Integer;
begin
if (FRowHeights = nil) or (Index >= RowCount) then
Result := DefaultRowHeight
else
Result := PIntArray(FRowHeights)^[Index + 1];
end;
function TbsSkinCustomGrid.GetGridWidth: Integer;
var
DrawInfo: TbsGridDrawInfo;
begin
CalcDrawInfo(DrawInfo);
Result := DrawInfo.Horz.GridBoundary;
end;
function TbsSkinCustomGrid.GetGridHeight: Integer;
var
DrawInfo: TbsGridDrawInfo;
begin
CalcDrawInfo(DrawInfo);
Result := DrawInfo.Vert.GridBoundary;
end;
function TbsSkinCustomGrid.GetSelection: TGridRect;
begin
Result := GridRect(FCurrent, FAnchor);
end;
function TbsSkinCustomGrid.GetTabStops(Index: Longint): Boolean;
begin
if FTabStops = nil then Result := True
else Result := Boolean(PIntArray(FTabStops)^[Index + 1]);
end;
function TbsSkinCustomGrid.GetVisibleColCount: Integer;
var
DrawInfo: TbsGridDrawInfo;
begin
CalcDrawInfo(DrawInfo);
Result := DrawInfo.Horz.LastFullVisibleCell - LeftCol + 1;
end;
function TbsSkinCustomGrid.GetVisibleRowCount: Integer;
var
DrawInfo: TbsGridDrawInfo;
begin
CalcDrawInfo(DrawInfo);
Result := DrawInfo.Vert.LastFullVisibleCell - TopRow + 1;
end;
procedure TbsSkinCustomGrid.SetBorderStyle(Value: TBorderStyle);
begin
if FBorderStyle <> Value then
begin
FBorderStyle := Value;
RecreateWnd;
end;
end;
procedure TbsSkinCustomGrid.SetCol(Value: Longint);
begin
if Col <> Value then FocusCell(Value, Row, True);
end;
procedure TbsSkinCustomGrid.SetColCount(Value: Longint);
begin
if FColCount <> Value then
begin
if Value < 1 then Value := 1;
if Value <= FixedCols then FixedCols := Value - 1;
ChangeSize(Value, RowCount);
if goRowSelect in Options then
begin
FAnchor.X := ColCount - 1;
Invalidate;
end;
end;
end;
procedure TbsSkinCustomGrid.SetColWidths(Index: Longint; Value: Integer);
begin
if FColWidths = nil then
UpdateExtents(FColWidths, ColCount, DefaultColWidth);
if Index >= ColCount then InvalidOp(SIndexOutOfRange);
if Value <> PIntArray(FColWidths)^[Index + 1] then
begin
ResizeCol(Index, PIntArray(FColWidths)^[Index + 1], Value);
PIntArray(FColWidths)^[Index + 1] := Value;
ColWidthsChanged;
end;
end;
procedure TbsSkinCustomGrid.SetDefaultColWidth(Value: Integer);
begin
if FColWidths <> nil then UpdateExtents(FColWidths, 0, 0);
FDefaultColWidth := Value;
ColWidthsChanged;
InvalidateGrid;
end;
procedure TbsSkinCustomGrid.SetDefaultRowHeight(Value: Integer);
begin
if FRowHeights <> nil then UpdateExtents(FRowHeights, 0, 0);
FDefaultRowHeight := Value;
RowHeightsChanged;
InvalidateGrid;
end;
procedure TbsSkinCustomGrid.SetFixedColor(Value: TColor);
begin
if FFixedColor <> Value then
begin
FFixedColor := Value;
InvalidateGrid;
end;
end;
procedure TbsSkinCustomGrid.SetFixedCols(Value: Integer);
begin
if FFixedCols <> Value then
begin
if Value < 0 then InvalidOp(SIndexOutOfRange);
if Value >= ColCount then InvalidOp(SFixedColTooBig);
FFixedCols := Value;
Initialize;
InvalidateGrid;
end;
end;
procedure TbsSkinCustomGrid.SetFixedRows(Value: Integer);
begin
if FFixedRows <> Value then
begin
if Value < 0 then InvalidOp(SIndexOutOfRange);
if Value >= RowCount then InvalidOp(SFixedRowTooBig);
FFixedRows := Value;
Initialize;
InvalidateGrid;
end;
end;
procedure TbsSkinCustomGrid.SetEditorMode(Value: Boolean);
begin
if not Value then
HideEditor
else
begin
ShowEditor;
if FInplaceEdit <> nil then FInplaceEdit.Deselect;
end;
end;
procedure TbsSkinCustomGrid.SetGridLineWidth(Value: Integer);
begin
if FGridLineWidth <> Value then
begin
FGridLineWidth := Value;
InvalidateGrid;
end;
end;
procedure TbsSkinCustomGrid.SetLeftCol(Value: Longint);
begin
if FTopLeft.X <> Value then MoveTopLeft(Value, TopRow);
end;
procedure TbsSkinCustomGrid.SetOptions(Value: TGridOptions);
begin
if FOptions <> Value then
begin
if goRowSelect in Value then
Exclude(Value, goAlwaysShowEditor);
FOptions := Value;
if not FEditorMode then
if goAlwaysShowEditor in Value then
ShowEditor else
HideEditor;
if goRowSelect in Value then MoveCurrent(Col, Row, True, False);
InvalidateGrid;
end;
end;
procedure TbsSkinCustomGrid.SetRow(Value: Longint);
begin
if Row <> Value then FocusCell(Col, Value, True);
end;
procedure TbsSkinCustomGrid.SetRowCount(Value: Longint);
begin
if FRowCount <> Value then
begin
if Value < 1 then Value := 1;
if Value <= FixedRows then FixedRows := Value - 1;
ChangeSize(ColCount, Value);
end;
end;
procedure TbsSkinCustomGrid.SetRowHeights(Index: Longint; Value: Integer);
begin
if FRowHeights = nil then
UpdateExtents(FRowHeights, RowCount, DefaultRowHeight);
if Index >= RowCount then InvalidOp(SIndexOutOfRange);
if Value <> PIntArray(FRowHeights)^[Index + 1] then
begin
ResizeRow(Index, PIntArray(FRowHeights)^[Index + 1], Value);
PIntArray(FRowHeights)^[Index + 1] := Value;
RowHeightsChanged;
end;
end;
procedure TbsSkinCustomGrid.SetSelection(Value: TGridRect);
var
OldSel: TGridRect;
begin
OldSel := Selection;
FAnchor := Value.TopLeft;
FCurrent := Value.BottomRight;
SelectionMoved(OldSel);
end;
procedure TbsSkinCustomGrid.SetTabStops(Index: Longint; Value: Boolean);
begin
if FTabStops = nil then
UpdateExtents(FTabStops, ColCount, Integer(True));
if Index >= ColCount then InvalidOp(SIndexOutOfRange);
PIntArray(FTabStops)^[Index + 1] := Integer(Value);
end;
procedure TbsSkinCustomGrid.SetTopRow(Value: Longint);
begin
if FTopLeft.Y <> Value then MoveTopLeft(LeftCol, Value);
end;
procedure TbsSkinCustomGrid.HideEdit;
begin
if FInplaceEdit <> nil then
try
UpdateText;
finally
FInplaceCol := -1;
FInplaceRow := -1;
FInplaceEdit.Hide;
end;
end;
procedure TbsSkinCustomGrid.UpdateEdit;
procedure UpdateEditor;
begin
FInplaceCol := Col;
FInplaceRow := Row;
if FIndex > -1
then
begin
FInplaceEdit.Color := BGColor;
if FUseSkinFont
then
begin
FInplaceEdit.Font.Name := Self.FontName;
FInplaceEdit.Font.Color := Self.FontColor;
FInplaceEdit.Font.Style := Self.FontStyle;
FInplaceEdit.Font.Height := Self.FontHeight;
end
else
begin
FInplaceEdit.Font.Assign(Self.Font);
FInplaceEdit.Font.Color := FontColor;
end;
end
else
begin
FInplaceEdit.Color := clWindow;
FInplaceEdit.Font := Font;
end;
if (SkinData <> nil) and (SkinData.ResourceStrData <> nil)
then
FInplaceEdit.Font.Charset := SkinData.ResourceStrData.CharSet
else
FInplaceEdit.Font.CharSet := Self.Font.CharSet;
FInplaceEdit.UpdateContents;
if FInplaceEdit.MaxLength = -1 then FCanEditModify := False
else FCanEditModify := True;
FInplaceEdit.SelectAll;
end;
begin
if CanEditShow then
begin
if FInplaceEdit = nil then
begin
FInplaceEdit := CreateEditor;
FInplaceEdit.SetGrid(Self);
FInplaceEdit.Parent := Self;
UpdateEditor;
end
else
begin
if (Col <> FInplaceCol) or (Row <> FInplaceRow) then
begin
HideEdit;
UpdateEditor;
end;
end;
if CanEditShow then FInplaceEdit.Move(CellRect(Col, Row));
end;
end;
procedure TbsSkinCustomGrid.UpdateText;
begin
if (FInplaceCol <> -1) and (FInplaceRow <> -1) then
SetEditText(FInplaceCol, FInplaceRow, FInplaceEdit.Text);
end;
procedure TbsSkinCustomGrid.WMChar(var Msg: TWMChar);
begin
if (goEditing in Options) and (Char(Msg.CharCode) in [^H, #32..#255]) then
ShowEditorChar(Char(Msg.CharCode))
else
inherited;
end;
procedure TbsSkinCustomGrid.WMCommand(var Message: TWMCommand);
begin
with Message do
begin
if (FInplaceEdit <> nil) and (Ctl = FInplaceEdit.Handle) then
case NotifyCode of
EN_CHANGE: UpdateText;
end;
end;
end;
procedure TbsSkinCustomGrid.WMGetDlgCode(var Msg: TWMGetDlgCode);
begin
Msg.Result := DLGC_WANTARROWS;
if goRowSelect in Options then Exit;
if goTabs in Options then Msg.Result := Msg.Result or DLGC_WANTTAB;
if goEditing in Options then Msg.Result := Msg.Result or DLGC_WANTCHARS;
end;
procedure TbsSkinCustomGrid.WMKillFocus(var Msg: TWMKillFocus);
begin
inherited;
InvalidateRect(Selection);
if (FInplaceEdit <> nil) and (Msg.FocusedWnd <> FInplaceEdit.Handle) then
HideEdit;
end;
procedure TbsSkinCustomGrid.WMLButtonDown(var Message: TMessage);
begin
inherited;
if FInplaceEdit <> nil then FInplaceEdit.FClickTime := GetMessageTime;
end;
procedure TbsSkinCustomGrid.WMNCHitTest(var Msg: TWMNCHitTest);
begin
DefaultHandler(Msg);
FHitTest := ScreenToClient(SmallPointToPoint(Msg.Pos));
end;
procedure TbsSkinCustomGrid.WMSetCursor(var Msg: TWMSetCursor);
var
DrawInfo: TbsGridDrawInfo;
State: TbsGridState;
Index: Longint;
Pos, Ofs: Integer;
Cur: HCURSOR;
begin
Cur := 0;
with Msg do
begin
if HitTest = HTCLIENT then
begin
if FGridState = gsNormal then
begin
CalcDrawInfo(DrawInfo);
CalcSizingState(FHitTest.X, FHitTest.Y, State, Index, Pos, Ofs,
DrawInfo);
end else State := FGridState;
if State = gsRowSizing then
Cur := Screen.Cursors[crVSplit]
else if State = gsColSizing then
Cur := Screen.Cursors[crHSplit]
end;
end;
if Cur <> 0 then SetCursor(Cur)
else inherited;
end;
procedure TbsSkinCustomGrid.WMSetFocus(var Msg: TWMSetFocus);
begin
inherited;
if (FInplaceEdit = nil) or (Msg.FocusedWnd <> FInplaceEdit.Handle) then
begin
InvalidateRect(Selection);
UpdateEdit;
end;
end;
procedure TbsSkinCustomGrid.WMSize(var Msg: TWMSize);
begin
inherited;
if (UseRightToLeftAlignment) or ((FIndex = -1) and (goRowSelect in Options))
then Invalidate;
if not FInCheckScrollBars then UpdateScrollRange(True);
end;
procedure TbsSkinCustomGrid.WMVScroll(var Msg: TWMVScroll);
begin
ModifyScrollBar(SB_VERT, Msg.ScrollCode, Msg.Pos, True);
end;
procedure TbsSkinCustomGrid.WMHScroll(var Msg: TWMHScroll);
begin
ModifyScrollBar(SB_HORZ, Msg.ScrollCode, Msg.Pos, True);
end;
procedure TbsSkinCustomGrid.CancelMode;
var
DrawInfo: TbsGridDrawInfo;
begin
try
case FGridState of
gsSelecting:
KillTimer(Handle, 1);
gsRowSizing, gsColSizing:
begin
CalcDrawInfo(DrawInfo);
DrawSizingLine(DrawInfo);
end;
gsColMoving, gsRowMoving:
begin
DrawMove;
KillTimer(Handle, 1);
end;
end;
finally
FGridState := gsNormal;
end;
end;
procedure TbsSkinCustomGrid.WMCancelMode(var Msg: TWMCancelMode);
begin
inherited;
CancelMode;
end;
procedure TbsSkinCustomGrid.CMCancelMode(var Msg: TMessage);
begin
if Assigned(FInplaceEdit) then FInplaceEdit.WndProc(Msg);
inherited;
CancelMode;
end;
procedure TbsSkinCustomGrid.CMFontChanged(var Message: TMessage);
begin
if FInplaceEdit <> nil then FInplaceEdit.Font := Font;
inherited;
end;
procedure TbsSkinCustomGrid.CMDesignHitTest(var Msg: TCMDesignHitTest);
begin
Msg.Result := Longint(BOOL(Sizing(Msg.Pos.X, Msg.Pos.Y)));
end;
procedure TbsSkinCustomGrid.CMWanTbsecialKey(var Msg: TCMWantSpecialKey);
begin
inherited;
if (goEditing in Options) and (Char(Msg.CharCode) = #13) then Msg.Result := 1;
end;
procedure TbsSkinCustomGrid.TimedScroll(Direction: TGridScrollDirection);
var
MaxAnchor, NewAnchor: TGridCoord;
begin
NewAnchor := FAnchor;
MaxAnchor.X := ColCount - 1;
MaxAnchor.Y := RowCount - 1;
if (sdLeft in Direction) and (FAnchor.X > FixedCols) then Dec(NewAnchor.X);
if (sdRight in Direction) and (FAnchor.X < MaxAnchor.X) then Inc(NewAnchor.X);
if (sdUp in Direction) and (FAnchor.Y > FixedRows) then Dec(NewAnchor.Y);
if (sdDown in Direction) and (FAnchor.Y < MaxAnchor.Y) then Inc(NewAnchor.Y);
if (FAnchor.X <> NewAnchor.X) or (FAnchor.Y <> NewAnchor.Y) then
MoveAnchor(NewAnchor);
end;
procedure TbsSkinCustomGrid.WMTimer(var Msg: TWMTimer);
var
Point: TPoint;
DrawInfo: TbsGridDrawInfo;
ScrollDirection: TGridScrollDirection;
CellHit: TGridCoord;
LeftSide: Integer;
RightSide: Integer;
begin
if not (FGridState in [gsSelecting, gsRowMoving, gsColMoving]) then Exit;
GetCursorPos(Point);
Point := ScreenToClient(Point);
CalcDrawInfo(DrawInfo);
ScrollDirection := [];
with DrawInfo do
begin
CellHit := CalcCoordFromPoint(Point.X, Point.Y, DrawInfo);
case FGridState of
gsColMoving:
MoveAndScroll(Point.X, CellHit.X, DrawInfo, Horz, SB_HORZ, Point);
gsRowMoving:
MoveAndScroll(Point.Y, CellHit.Y, DrawInfo, Vert, SB_VERT, Point);
gsSelecting:
begin
if not UseRightToLeftAlignment then
begin
if Point.X < Horz.FixedBoundary then Include(ScrollDirection, sdLeft)
else if Point.X > Horz.FullVisBoundary then Include(ScrollDirection, sdRight);
end
else
begin
LeftSide := ClientWidth - Horz.FullVisBoundary;
RightSide := ClientWidth - Horz.FixedBoundary;
if Point.X < LeftSide then Include(ScrollDirection, sdRight)
else if Point.X > RightSide then Include(ScrollDirection, sdLeft);
end;
if Point.Y < Vert.FixedBoundary then Include(ScrollDirection, sdUp)
else if Point.Y > Vert.FullVisBoundary then Include(ScrollDirection, sdDown);
if ScrollDirection <> [] then TimedScroll(ScrollDirection);
end;
end;
end;
end;
procedure TbsSkinCustomGrid.ColWidthsChanged;
begin
UpdateScrollRange(True);
UpdateEdit;
end;
procedure TbsSkinCustomGrid.RowHeightsChanged;
begin
UpdateScrollRange(True);
UpdateEdit;
end;
procedure TbsSkinCustomGrid.DeleteColumn(ACol: Longint);
begin
MoveColumn(ACol, ColCount-1);
ColCount := ColCount - 1;
end;
procedure TbsSkinCustomGrid.DeleteRow(ARow: Longint);
begin
MoveRow(ARow, RowCount - 1);
RowCount := RowCount - 1;
end;
procedure TbsSkinCustomGrid.UpdateDesigner;
var
ParentForm: TCustomForm;
begin
if (csDesigning in ComponentState) and HandleAllocated and
not (csUpdating in ComponentState) then
begin
ParentForm := GetParentForm(Self);
if Assigned(ParentForm) and Assigned(ParentForm.Designer) then
ParentForm.Designer.Modified;
end;
end;
function TbsSkinCustomGrid.DoMouseWheelDown(Shift: TShiftState; MousePos: TPoint): Boolean;
begin
Result := inherited DoMouseWheelDown(Shift, MousePos);
if not Result then
begin
if Row < RowCount - 1 then Row := Row + 1;
Result := True;
end;
end;
function TbsSkinCustomGrid.DoMouseWheelUp(Shift: TShiftState; MousePos: TPoint): Boolean;
begin
Result := inherited DoMouseWheelUp(Shift, MousePos);
if not Result then
begin
if Row > FixedRows then Row := Row - 1;
Result := True;
end;
end;
function TbsSkinCustomGrid.CheckColumnDrag(var Origin,
Destination: Integer; const MousePt: TPoint): Boolean;
begin
Result := True;
end;
function TbsSkinCustomGrid.CheckRowDrag(var Origin,
Destination: Integer; const MousePt: TPoint): Boolean;
begin
Result := True;
end;
function TbsSkinCustomGrid.BeginColumnDrag(var Origin, Destination: Integer; const MousePt: TPoint): Boolean;
begin
Result := True;
end;
function TbsSkinCustomGrid.BeginRowDrag(var Origin, Destination: Integer; const MousePt: TPoint): Boolean;
begin
Result := True;
end;
function TbsSkinCustomGrid.EndColumnDrag(var Origin, Destination: Integer; const MousePt: TPoint): Boolean;
begin
Result := True;
end;
function TbsSkinCustomGrid.EndRowDrag(var Origin, Destination: Integer; const MousePt: TPoint): Boolean;
begin
Result := True;
end;
procedure TbsSkinCustomGrid.WMPAINT;
begin
inherited;
if not FInCheckScrollBars then UpDateScrollRange(True);
end;
procedure TbsSkinCustomGrid.CMShowingChanged(var Message: TMessage);
begin
inherited;
end;
{ TbsSkinDrawGrid }
function TbsSkinDrawGrid.CellRect(ACol, ARow: Longint): TRect;
begin
Result := inherited CellRect(ACol, ARow);
end;
procedure TbsSkinDrawGrid.MouseToCell(X, Y: Integer; var ACol, ARow: Longint);
var
Coord: TGridCoord;
begin
Coord := MouseCoord(X, Y);
ACol := Coord.X;
ARow := Coord.Y;
end;
procedure TbsSkinDrawGrid.ColumnMoved(FromIndex, ToIndex: Longint);
begin
if Assigned(FOnColumnMoved) then FOnColumnMoved(Self, FromIndex, ToIndex);
end;
function TbsSkinDrawGrid.GetEditMask(ACol, ARow: Longint): string;
begin
Result := '';
if Assigned(FOnGetEditMask) then FOnGetEditMask(Self, ACol, ARow, Result);
end;
function TbsSkinDrawGrid.GetEditText(ACol, ARow: Longint): string;
begin
Result := '';
if Assigned(FOnGetEditText) then FOnGetEditText(Self, ACol, ARow, Result);
end;
procedure TbsSkinDrawGrid.RowMoved(FromIndex, ToIndex: Longint);
begin
if Assigned(FOnRowMoved) then FOnRowMoved(Self, FromIndex, ToIndex);
end;
function TbsSkinDrawGrid.SelectCell(ACol, ARow: Longint): Boolean;
begin
Result := True;
if Assigned(FOnSelectCell) then FOnSelectCell(Self, ACol, ARow, Result);
end;
procedure TbsSkinDrawGrid.SetEditText(ACol, ARow: Longint; const Value: string);
begin
if Assigned(FOnSetEditText) then FOnSetEditText(Self, ACol, ARow, Value);
end;
procedure TbsSkinDrawGrid.DrawCell(ACol, ARow: Longint; ARect: TRect;
AState: TGridDrawState);
var
Hold: Integer;
begin
if Assigned(FOnDrawCell) then
begin
if UseRightToLeftAlignment then
begin
ARect.Left := ClientWidth - ARect.Left;
ARect.Right := ClientWidth - ARect.Right;
Hold := ARect.Left;
ARect.Left := ARect.Right;
ARect.Right := Hold;
ChangeGridOrientation(False);
end;
FOnDrawCell(Self, ACol, ARow, ARect, AState);
if UseRightToLeftAlignment then ChangeGridOrientation(True);
end;
end;
procedure TbsSkinDrawGrid.TopLeftChanged;
begin
inherited TopLeftChanged;
if Assigned(FOnTopLeftChanged) then FOnTopLeftChanged(Self);
end;
{ StrItem management for TStringSparseList }
type
PStrItem = ^TStrItem;
TStrItem = record
FObject: TObject;
FString: string;
end;
function NewStrItem(const AString: string; AObject: TObject): PStrItem;
begin
New(Result);
Result^.FObject := AObject;
Result^.FString := AString;
end;
procedure DisposeStrItem(P: PStrItem);
begin
Dispose(P);
end;
{ Sparse array classes for TbsSkinStringGrid }
type
PPointer = ^Pointer;
{ Exception classes }
EStringSparseListError = class(Exception);
{ TbsarsePointerArray class}
{ Used by TbsarseList. Based on Sparse1Array, but has Pointer elements
and Integer index, just like TPointerList/TList, and less indirection }
{ Apply function for the applicator:
TheIndex Index of item in array
TheItem Value of item (i.e pointer element) in section
Returns: 0 if success, else error code. }
TbsAApply = function(TheIndex: Integer; TheItem: Pointer): Integer;
TSecDir = array[0..4095] of Pointer; { Enough for up to 12 bits of sec }
PSecDir = ^TSecDir;
TbsAQuantum = (SPASmall, SPALarge); { Section size }
TbsarsePointerArray = class(TObject)
private
secDir: PSecDir;
slotsInDir: Word;
indexMask, secShift: Word;
FHighBound: Integer;
FSectionSize: Word;
cachedIndex: Integer;
cachedPointer: Pointer;
{ Return item[i], nil if slot outside defined section. }
function GetAt(Index: Integer): Pointer;
{ Return address of item[i], creating slot if necessary. }
function MakeAt(Index: Integer): PPointer;
{ Store item at item[i], creating slot if necessary. }
procedure PutAt(Index: Integer; Item: Pointer);
public
constructor Create(Quantum: TbsAQuantum);
destructor Destroy; override;
{ Traverse SPA, calling apply function for each defined non-nil
item. The traversal terminates if the apply function returns
a value other than 0. }
{ NOTE: must be static method so that we can take its address in
TbsarseList.ForAll }
function ForAll(ApplyFunction: Pointer {TbsAApply}): Integer;
{ Ratchet down HighBound after a deletion }
procedure ResetHighBound;
property HighBound: Integer read FHighBound;
property SectionSize: Word read FSectionSize;
property Items[Index: Integer]: Pointer read GetAt write PutAt; default;
end;
{ TbsarseList class }
TbsarseList = class(TObject)
private
FList: TbsarsePointerArray;
FCount: Integer; { 1 + HighBound, adjusted for Insert/Delete }
FQuantum: TbsAQuantum;
procedure NewList(Quantum: TbsAQuantum);
protected
procedure Error; virtual;
function Get(Index: Integer): Pointer;
procedure Put(Index: Integer; Item: Pointer);
public
constructor Create(Quantum: TbsAQuantum);
destructor Destroy; override;
procedure Clear;
procedure Delete(Index: Integer);
procedure Exchange(Index1, Index2: Integer);
function ForAll(ApplyFunction: Pointer {TbsAApply}): Integer;
procedure Insert(Index: Integer; Item: Pointer);
procedure Move(CurIndex, NewIndex: Integer);
property Count: Integer read FCount;
property Items[Index: Integer]: Pointer read Get write Put; default;
end;
{ TStringSparseList class }
TStringSparseList = class(TStrings)
private
FList: TbsarseList; { of StrItems }
FOnChange: TNotifyEvent;
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 Changed; virtual;
procedure Error; virtual;
public
constructor Create(Quantum: TbsAQuantum);
destructor Destroy; override;
procedure ReadData(Reader: TReader);
procedure WriteData(Writer: TWriter);
procedure DefineProperties(Filer: TFiler); override;
procedure Delete(Index: Integer); override;
procedure Exchange(Index1, Index2: Integer); override;
procedure Insert(Index: Integer; const S: String); override;
procedure Clear; override;
property List: TbsarseList read FList;
property OnChange: TNotifyEvent read FOnChange write FOnChange;
end;
{ TbsarsePointerArray }
const
SPAIndexMask: array[TbsAQuantum] of Byte = (15, 255);
SPASecShift: array[TbsAQuantum] of Byte = (4, 8);
{ Expand Section Directory to cover at least `newSlots' slots. Returns: Possibly
updated pointer to the Section Directory. }
function ExpandDir(secDir: PSecDir; var slotsInDir: Word;
newSlots: Word): PSecDir;
begin
Result := secDir;
ReallocMem(Result, newSlots * SizeOf(Pointer));
FillChar(Result^[slotsInDir], (newSlots - slotsInDir) * SizeOf(Pointer), 0);
slotsInDir := newSlots;
end;
{ Allocate a section and set all its items to nil. Returns: Pointer to start of
section. }
function MakeSec(SecIndex: Integer; SectionSize: Word): Pointer;
var
SecP: Pointer;
Size: Word;
begin
Size := SectionSize * SizeOf(Pointer);
GetMem(secP, size);
FillChar(secP^, size, 0);
MakeSec := SecP
end;
constructor TbsarsePointerArray.Create(Quantum: TbsAQuantum);
begin
SecDir := nil;
SlotsInDir := 0;
FHighBound := -1;
FSectionSize := Word(SPAIndexMask[Quantum]) + 1;
IndexMask := Word(SPAIndexMask[Quantum]);
SecShift := Word(SPASecShift[Quantum]);
CachedIndex := -1
end;
destructor TbsarsePointerArray.Destroy;
var
i: Integer;
size: Word;
begin
{ Scan section directory and free each section that exists. }
i := 0;
size := FSectionSize * SizeOf(Pointer);
while i < slotsInDir do begin
if secDir^[i] <> nil then
FreeMem(secDir^[i], size);
Inc(i)
end;
{ Free section directory. }
if secDir <> nil then
FreeMem(secDir, slotsInDir * SizeOf(Pointer));
end;
function TbsarsePointerArray.GetAt(Index: Integer): Pointer;
var
byteP: PChar;
secIndex: Cardinal;
begin
{ Index into Section Directory using high order part of
index. Get pointer to Section. If not null, index into
Section using low order part of index. }
if Index = cachedIndex then
Result := cachedPointer
else begin
secIndex := Index shr secShift;
if secIndex >= slotsInDir then
byteP := nil
else begin
byteP := secDir^[secIndex];
if byteP <> nil then begin
Inc(byteP, (Index and indexMask) * SizeOf(Pointer));
end
end;
if byteP = nil then Result := nil else Result := PPointer(byteP)^;
cachedIndex := Index;
cachedPointer := Result
end
end;
function TbsarsePointerArray.MakeAt(Index: Integer): PPointer;
var
dirP: PSecDir;
p: Pointer;
byteP: PChar;
secIndex: Word;
begin
{ Expand Section Directory if necessary. }
secIndex := Index shr secShift; { Unsigned shift }
if secIndex >= slotsInDir then
dirP := expandDir(secDir, slotsInDir, secIndex + 1)
else
dirP := secDir;
{ Index into Section Directory using high order part of
index. Get pointer to Section. If null, create new
Section. Index into Section using low order part of index. }
secDir := dirP;
p := dirP^[secIndex];
if p = nil then begin
p := makeSec(secIndex, FSectionSize);
dirP^[secIndex] := p
end;
byteP := p;
Inc(byteP, (Index and indexMask) * SizeOf(Pointer));
if Index > FHighBound then
FHighBound := Index;
Result := PPointer(byteP);
cachedIndex := -1
end;
procedure TbsarsePointerArray.PutAt(Index: Integer; Item: Pointer);
begin
if (Item <> nil) or (GetAt(Index) <> nil) then
begin
MakeAt(Index)^ := Item;
if Item = nil then
ResetHighBound
end
end;
function TbsarsePointerArray.ForAll(ApplyFunction: Pointer {TbsAApply}):
Integer;
var
itemP: PChar; { Pointer to item in section }
item: Pointer;
i, callerBP: Cardinal;
j, index: Integer;
begin
{ Scan section directory and scan each section that exists,
calling the apply function for each non-nil item.
The apply function must be a far local function in the scope of
the procedure P calling ForAll. The trick of setting up the stack
frame (taken from TurboVision's TCollection.ForEach) allows the
apply function access to P's arguments and local variables and,
if P is a method, the instance variables and methods of P's class }
Result := 0;
i := 0;
asm
mov eax,[ebp] { Set up stack frame for local }
mov callerBP,eax
end;
while (i < slotsInDir) and (Result = 0) do begin
itemP := secDir^[i];
if itemP <> nil then begin
j := 0;
index := i shl SecShift;
while (j < FSectionSize) and (Result = 0) do begin
item := PPointer(itemP)^;
if item <> nil then
{ ret := ApplyFunction(index, item.Ptr); }
asm
mov eax,index
mov edx,item
push callerBP
call ApplyFunction
pop ecx
mov @Result,eax
end;
Inc(itemP, SizeOf(Pointer));
Inc(j);
Inc(index)
end
end;
Inc(i)
end;
end;
procedure TbsarsePointerArray.ResetHighBound;
var
NewHighBound: Integer;
function Detector(TheIndex: Integer; TheItem: Pointer): Integer; far;
begin
if TheIndex > FHighBound then
Result := 1
else
begin
Result := 0;
if TheItem <> nil then NewHighBound := TheIndex
end
end;
begin
NewHighBound := -1;
ForAll(@Detector);
FHighBound := NewHighBound
end;
{ TbsarseList }
constructor TbsarseList.Create(Quantum: TbsAQuantum);
begin
NewList(Quantum)
end;
destructor TbsarseList.Destroy;
begin
if FList <> nil then FList.Destroy
end;
procedure TbsarseList.Clear;
begin
FList.Destroy;
NewList(FQuantum);
FCount := 0
end;
procedure TbsarseList.Delete(Index: Integer);
var
I: Integer;
begin
if (Index < 0) or (Index >= FCount) then Exit;
for I := Index to FCount - 1 do
FList[I] := FList[I + 1];
FList[FCount] := nil;
Dec(FCount);
end;
procedure TbsarseList.Error;
begin
raise EListError.Create('List index out of bounds (%d)');
end;
procedure TbsarseList.Exchange(Index1, Index2: Integer);
var
temp: Pointer;
begin
temp := Get(Index1);
Put(Index1, Get(Index2));
Put(Index2, temp);
end;
{ Jump to TbsarsePointerArray.ForAll so that it looks like it was called
from our caller, so that the BP trick works. }
function TbsarseList.ForAll(ApplyFunction: Pointer {TbsAApply}): Integer; assembler;
asm
MOV EAX,[EAX].TbsarseList.FList
JMP TbsarsePointerArray.ForAll
end;
function TbsarseList.Get(Index: Integer): Pointer;
begin
if Index < 0 then Error;
Result := FList[Index]
end;
procedure TbsarseList.Insert(Index: Integer; Item: Pointer);
var
i: Integer;
begin
if Index < 0 then Error;
I := FCount;
while I > Index do
begin
FList[i] := FList[i - 1];
Dec(i)
end;
FList[Index] := Item;
if Index > FCount then FCount := Index;
Inc(FCount)
end;
procedure TbsarseList.Move(CurIndex, NewIndex: Integer);
var
Item: Pointer;
begin
if CurIndex <> NewIndex then
begin
Item := Get(CurIndex);
Delete(CurIndex);
Insert(NewIndex, Item);
end;
end;
procedure TbsarseList.NewList(Quantum: TbsAQuantum);
begin
FQuantum := Quantum;
FList := TbsarsePointerArray.Create(Quantum)
end;
procedure TbsarseList.Put(Index: Integer; Item: Pointer);
begin
if Index < 0 then Error;
FList[Index] := Item;
FCount := FList.HighBound + 1
end;
{ TStringSparseList }
constructor TStringSparseList.Create(Quantum: TbsAQuantum);
begin
FList := TbsarseList.Create(Quantum)
end;
destructor TStringSparseList.Destroy;
begin
if FList <> nil then begin
Clear;
FList.Destroy
end
end;
procedure TStringSparseList.ReadData(Reader: TReader);
var
i: Integer;
begin
with Reader do begin
i := Integer(ReadInteger);
while i > 0 do begin
InsertObject(Integer(ReadInteger), ReadString, nil);
Dec(i)
end
end
end;
procedure TStringSparseList.WriteData(Writer: TWriter);
var
itemCount: Integer;
function CountItem(TheIndex: Integer; TheItem: Pointer): Integer; far;
begin
Inc(itemCount);
Result := 0
end;
function StoreItem(TheIndex: Integer; TheItem: Pointer): Integer; far;
begin
with Writer do
begin
WriteInteger(TheIndex); { Item index }
WriteString(PStrItem(TheItem)^.FString);
end;
Result := 0
end;
begin
with Writer do
begin
itemCount := 0;
FList.ForAll(@CountItem);
WriteInteger(itemCount);
FList.ForAll(@StoreItem);
end
end;
procedure TStringSparseList.DefineProperties(Filer: TFiler);
begin
Filer.DefineProperty('List', ReadData, WriteData, True);
end;
function TStringSparseList.Get(Index: Integer): String;
var
p: PStrItem;
begin
p := PStrItem(FList[Index]);
if p = nil then Result := '' else Result := p^.FString
end;
function TStringSparseList.GetCount: Integer;
begin
Result := FList.Count
end;
function TStringSparseList.GetObject(Index: Integer): TObject;
var
p: PStrItem;
begin
p := PStrItem(FList[Index]);
if p = nil then Result := nil else Result := p^.FObject
end;
procedure TStringSparseList.Put(Index: Integer; const S: String);
var
p: PStrItem;
obj: TObject;
begin
p := PStrItem(FList[Index]);
if p = nil then obj := nil else obj := p^.FObject;
if (S = '') and (obj = nil) then { Nothing left to store }
FList[Index] := nil
else
FList[Index] := NewStrItem(S, obj);
if p <> nil then DisposeStrItem(p);
Changed
end;
procedure TStringSparseList.PutObject(Index: Integer; AObject: TObject);
var
p: PStrItem;
begin
p := PStrItem(FList[Index]);
if p <> nil then
p^.FObject := AObject
else if AObject <> nil then
FList[Index] := NewStrItem('',AObject);
Changed
end;
procedure TStringSparseList.Changed;
begin
if Assigned(FOnChange) then FOnChange(Self)
end;
procedure TStringSparseList.Error;
begin
raise EStringSparseListError.Create(SPutObjectError);
end;
procedure TStringSparseList.Delete(Index: Integer);
var
p: PStrItem;
begin
p := PStrItem(FList[Index]);
if p <> nil then DisposeStrItem(p);
FList.Delete(Index);
Changed
end;
procedure TStringSparseList.Exchange(Index1, Index2: Integer);
begin
FList.Exchange(Index1, Index2);
end;
procedure TStringSparseList.Insert(Index: Integer; const S: String);
begin
FList.Insert(Index, NewStrItem(S, nil));
Changed
end;
procedure TStringSparseList.Clear;
function ClearItem(TheIndex: Integer; TheItem: Pointer): Integer; far;
begin
DisposeStrItem(PStrItem(TheItem)); { Item guaranteed non-nil }
Result := 0
end;
begin
FList.ForAll(@ClearItem);
FList.Clear;
Changed
end;
{ TbsSkinStringGridStrings }
{ AIndex < 0 is a column (for column -AIndex - 1)
AIndex > 0 is a row (for row AIndex - 1)
AIndex = 0 denotes an empty row or column }
constructor TbsSkinStringGridStrings.Create(AGrid: TbsSkinStringGrid; AIndex: Longint);
begin
inherited Create;
FGrid := AGrid;
FIndex := AIndex;
end;
procedure TbsSkinStringGridStrings.Assign(Source: TPersistent);
var
I, Max: Integer;
begin
if Source is TStrings then
begin
BeginUpdate;
Max := TStrings(Source).Count - 1;
if Max >= Count then Max := Count - 1;
try
for I := 0 to Max do
begin
Put(I, TStrings(Source).Strings[I]);
PutObject(I, TStrings(Source).Objects[I]);
end;
finally
EndUpdate;
end;
Exit;
end;
inherited Assign(Source);
end;
procedure TbsSkinStringGridStrings.CalcXY(Index: Integer; var X, Y: Integer);
begin
if FIndex = 0 then
begin
X := -1; Y := -1;
end else if FIndex > 0 then
begin
X := Index;
Y := FIndex - 1;
end else
begin
X := -FIndex - 1;
Y := Index;
end;
end;
{ Changes the meaning of Add to mean copy to the first empty string }
function TbsSkinStringGridStrings.Add(const S: string): Integer;
var
I: Integer;
begin
for I := 0 to Count - 1 do
if Strings[I] = '' then
begin
Strings[I] := S;
Result := I;
Exit;
end;
Result := -1;
end;
procedure TbsSkinStringGridStrings.Clear;
var
SSList: TStringSparseList;
I: Integer;
function BlankStr(TheIndex: Integer; TheItem: Pointer): Integer; far;
begin
Objects[TheIndex] := nil;
Strings[TheIndex] := '';
Result := 0;
end;
begin
if FIndex > 0 then
begin
SSList := TStringSparseList(TbsarseList(FGrid.FData)[FIndex - 1]);
if SSList <> nil then SSList.List.ForAll(@BlankStr);
end
else if FIndex < 0 then
for I := Count - 1 downto 0 do
begin
Objects[I] := nil;
Strings[I] := '';
end;
end;
procedure TbsSkinStringGridStrings.Delete(Index: Integer);
begin
InvalidOp(sInvalidStringGridOp);
end;
function TbsSkinStringGridStrings.Get(Index: Integer): string;
var
X, Y: Integer;
begin
CalcXY(Index, X, Y);
if X < 0 then Result := '' else Result := FGrid.Cells[X, Y];
end;
function TbsSkinStringGridStrings.GetCount: Integer;
begin
{ Count of a row is the column count, and vice versa }
if FIndex = 0 then Result := 0
else if FIndex > 0 then Result := Integer(FGrid.ColCount)
else Result := Integer(FGrid.RowCount);
end;
function TbsSkinStringGridStrings.GetObject(Index: Integer): TObject;
var
X, Y: Integer;
begin
CalcXY(Index, X, Y);
if X < 0 then Result := nil else Result := FGrid.Objects[X, Y];
end;
procedure TbsSkinStringGridStrings.Insert(Index: Integer; const S: string);
begin
InvalidOp(sInvalidStringGridOp);
end;
procedure TbsSkinStringGridStrings.Put(Index: Integer; const S: string);
var
X, Y: Integer;
begin
CalcXY(Index, X, Y);
FGrid.Cells[X, Y] := S;
end;
procedure TbsSkinStringGridStrings.PutObject(Index: Integer; AObject: TObject);
var
X, Y: Integer;
begin
CalcXY(Index, X, Y);
FGrid.Objects[X, Y] := AObject;
end;
procedure TbsSkinStringGridStrings.SetUpdateState(Updating: Boolean);
begin
FGrid.SetUpdateState(Updating);
end;
{ TbsSkinStringGrid }
constructor TbsSkinStringGrid.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
Initialize;
end;
destructor TbsSkinStringGrid.Destroy;
function FreeItem(TheIndex: Integer; TheItem: Pointer): Integer; far;
begin
TObject(TheItem).Free;
Result := 0;
end;
begin
if FRows <> nil then
begin
TbsarseList(FRows).ForAll(@FreeItem);
TbsarseList(FRows).Free;
end;
if FCols <> nil then
begin
TbsarseList(FCols).ForAll(@FreeItem);
TbsarseList(FCols).Free;
end;
if FData <> nil then
begin
TbsarseList(FData).ForAll(@FreeItem);
TbsarseList(FData).Free;
end;
inherited Destroy;
end;
procedure TbsSkinStringGrid.ColumnMoved(FromIndex, ToIndex: Longint);
function MoveColData(Index: Integer; ARow: TStringSparseList): Integer; far;
begin
ARow.Move(FromIndex, ToIndex);
Result := 0;
end;
begin
TbsarseList(FData).ForAll(@MoveColData);
Invalidate;
inherited ColumnMoved(FromIndex, ToIndex);
end;
procedure TbsSkinStringGrid.RowMoved(FromIndex, ToIndex: Longint);
begin
TbsarseList(FData).Move(FromIndex, ToIndex);
Invalidate;
inherited RowMoved(FromIndex, ToIndex);
end;
function TbsSkinStringGrid.GetEditText(ACol, ARow: Longint): string;
begin
Result := Cells[ACol, ARow];
if Assigned(FOnGetEditText) then FOnGetEditText(Self, ACol, ARow, Result);
end;
procedure TbsSkinStringGrid.SetEditText(ACol, ARow: Longint; const Value: string);
begin
DisableEditUpdate;
try
if Value <> Cells[ACol, ARow] then Cells[ACol, ARow] := Value;
finally
EnableEditUpdate;
end;
inherited SetEditText(ACol, ARow, Value);
end;
procedure TbsSkinStringGrid.DrawCell(ACol, ARow: Longint; ARect: TRect;
AState: TGridDrawState);
var
R: TRect;
S: String;
TX, TY: Integer;
begin
if DefaultDrawing
then
with Canvas do
begin
R := GetNewTextRect(ARect, AState);
Brush.Style := bsClear;
S := Cells[ACol, ARow];
TX := R.Left + 2;
TY := R.Top + RectHeight(R) div 2 - TextHeight(S) div 2;
TextRect(R, TX, TY, S);
Brush.Style := bsSolid;
end;
inherited DrawCell(ACol, ARow, ARect, AState);
end;
procedure TbsSkinStringGrid.DisableEditUpdate;
begin
Inc(FEditUpdate);
end;
procedure TbsSkinStringGrid.EnableEditUpdate;
begin
Dec(FEditUpdate);
end;
procedure TbsSkinStringGrid.Initialize;
var
quantum: TbsAQuantum;
begin
if FCols = nil then
begin
if ColCount > 512 then quantum := SPALarge else quantum := SPASmall;
FCols := TbsarseList.Create(quantum);
end;
if RowCount > 256 then quantum := SPALarge else quantum := SPASmall;
if FRows = nil then FRows := TbsarseList.Create(quantum);
if FData = nil then FData := TbsarseList.Create(quantum);
end;
procedure TbsSkinStringGrid.SetUpdateState(Updating: Boolean);
begin
FUpdating := Updating;
if not Updating and FNeedsUpdating then
begin
InvalidateGrid;
FNeedsUpdating := False;
end;
end;
procedure TbsSkinStringGrid.Update(ACol, ARow: Integer);
begin
if not FUpdating then InvalidateCell(ACol, ARow)
else FNeedsUpdating := True;
if (ACol = Col) and (ARow = Row) and (FEditUpdate = 0) then InvalidateEditor;
end;
function TbsSkinStringGrid.EnsureColRow(Index: Integer; IsCol: Boolean):
TbsSkinStringGridStrings;
var
RCIndex: Integer;
PList: ^TbsarseList;
begin
if IsCol then PList := @FCols else PList := @FRows;
Result := TbsSkinStringGridStrings(PList^[Index]);
if Result = nil then
begin
if IsCol then RCIndex := -Index - 1 else RCIndex := Index + 1;
Result := TbsSkinStringGridStrings.Create(Self, RCIndex);
PList^[Index] := Result;
end;
end;
function TbsSkinStringGrid.EnsureDataRow(ARow: Integer): Pointer;
var
quantum: TbsAQuantum;
begin
Result := TStringSparseList(TbsarseList(FData)[ARow]);
if Result = nil then
begin
if ColCount > 512 then quantum := SPALarge else quantum := SPASmall;
Result := TStringSparseList.Create(quantum);
TbsarseList(FData)[ARow] := Result;
end;
end;
function TbsSkinStringGrid.GetCells(ACol, ARow: Integer): string;
var
ssl: TStringSparseList;
begin
ssl := TStringSparseList(TbsarseList(FData)[ARow]);
if ssl = nil then Result := '' else Result := ssl[ACol];
end;
function TbsSkinStringGrid.GetCols(Index: Integer): TStrings;
begin
Result := EnsureColRow(Index, True);
end;
function TbsSkinStringGrid.GetObjects(ACol, ARow: Integer): TObject;
var
ssl: TStringSparseList;
begin
ssl := TStringSparseList(TbsarseList(FData)[ARow]);
if ssl = nil then Result := nil else Result := ssl.Objects[ACol];
end;
function TbsSkinStringGrid.GetRows(Index: Integer): TStrings;
begin
Result := EnsureColRow(Index, False);
end;
procedure TbsSkinStringGrid.SetCells(ACol, ARow: Integer; const Value: string);
begin
TbsSkinStringGridStrings(EnsureDataRow(ARow))[ACol] := Value;
EnsureColRow(ACol, True);
EnsureColRow(ARow, False);
Update(ACol, ARow);
end;
procedure TbsSkinStringGrid.SetCols(Index: Integer; Value: TStrings);
begin
EnsureColRow(Index, True).Assign(Value);
end;
procedure TbsSkinStringGrid.SetObjects(ACol, ARow: Integer; Value: TObject);
begin
TbsSkinStringGridStrings(EnsureDataRow(ARow)).Objects[ACol] := Value;
EnsureColRow(ACol, True);
EnsureColRow(ARow, False);
Update(ACol, ARow);
end;
procedure TbsSkinStringGrid.SetRows(Index: Integer; Value: TStrings);
begin
EnsureColRow(Index, False).Assign(Value);
end;
end.