paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-09-07 15:20:30 +02:00
Code Issues Packages Projects Releases Wiki Activity

Examples: Add example demonstrating cell text overflow in a StringGrid

Browse Source 
git-svn-id: trunk@54171 -
This commit is contained in:
wp 2017-02-16 20:27:02 +00:00
parent 083e67949c
commit 80ddf57c84
6 changed files with 438 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
.gitattributes vendored
View File

@ -5623,6 +5623,11 @@ examples/fpdocmanager/fupdateview.pas svneol=native#text/pascal
examples/fpdocmanager/ulpk.pp svneol=native#text/pascal
examples/fpdocmanager/umakeskel.pas svneol=native#text/pascal
examples/fpdocmanager/umanager.pas svneol=native#text/pascal
examples/gridexamples/cell_overflow/celloverflow_demo.lpi svneol=native#text/plain
examples/gridexamples/cell_overflow/celloverflow_demo.lpr svneol=native#text/plain
examples/gridexamples/cell_overflow/comain.lfm svneol=native#text/plain
examples/gridexamples/cell_overflow/comain.pas svneol=native#text/plain
examples/gridexamples/cell_overflow/readme.txt svneol=native#text/plain
examples/gridexamples/columneditors/main.lfm svneol=native#text/plain
examples/gridexamples/columneditors/main.pas svneol=native#text/plain
examples/gridexamples/columneditors/readme.txt svneol=native#text/plain

78
examples/gridexamples/cell_overflow/celloverflow_demo.lpi Normal file
View File

@ -0,0 +1,78 @@
<?xml version="1.0" encoding="UTF-8"?>
<CONFIG>
<ProjectOptions>
<Version Value="10"/>
<PathDelim Value="\"/>
<General>
<SessionStorage Value="InProjectDir"/>
<MainUnit Value="0"/>
<Title Value="celloverflow_demo"/>
<ResourceType Value="res"/>
<UseXPManifest Value="True"/>
<Icon Value="0"/>
</General>
<BuildModes Count="1">
<Item1 Name="Default" Default="True"/>
</BuildModes>
<PublishOptions>
<Version Value="2"/>
</PublishOptions>
<RunParams>
<local>
<FormatVersion Value="1"/>
</local>
</RunParams>
<RequiredPackages Count="1">
<Item1>
<PackageName Value="LCL"/>
</Item1>
</RequiredPackages>
<Units Count="2">
<Unit0>
<Filename Value="celloverflow_demo.lpr"/>
<IsPartOfProject Value="True"/>
</Unit0>
<Unit1>
<Filename Value="comain.pas"/>
<IsPartOfProject Value="True"/>
<ComponentName Value="MainForm"/>
<HasResources Value="True"/>
<ResourceBaseClass Value="Form"/>
</Unit1>
</Units>
</ProjectOptions>
<CompilerOptions>
<Version Value="11"/>
<PathDelim Value="\"/>
<Target>
<Filename Value="celloverflow_demo"/>
</Target>
<SearchPaths>
<IncludeFiles Value="$(ProjOutDir)"/>
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
</SearchPaths>
<Linking>
<Debugging>
<UseExternalDbgSyms Value="True"/>
</Debugging>
<Options>
<Win32>
<GraphicApplication Value="True"/>
</Win32>
</Options>
</Linking>
</CompilerOptions>
<Debugging>
<Exceptions Count="3">
<Item1>
<Name Value="EAbort"/>
</Item1>
<Item2>
<Name Value="ECodetoolError"/>
</Item2>
<Item3>
<Name Value="EFOpenError"/>
</Item3>
</Exceptions>
</Debugging>
</CONFIG>

21
examples/gridexamples/cell_overflow/celloverflow_demo.lpr Normal file
View File

@ -0,0 +1,21 @@
program celloverflow_demo;
{$mode objfpc}{$H+}
uses
{$IFDEF UNIX}{$IFDEF UseCThreads}
cthreads,
{$ENDIF}{$ENDIF}
Interfaces, // this includes the LCL widgetset
Forms, comain
{ you can add units after this };
{$R *.res}
begin
RequireDerivedFormResource:=True;
Application.Initialize;
Application.CreateForm(TMainForm, MainForm);
Application.Run;
end.

32
examples/gridexamples/cell_overflow/comain.lfm Normal file
View File

@ -0,0 +1,32 @@
object MainForm: TMainForm
Left = 271
Height = 294
Top = 237
Width = 530
Caption = 'Extended StringGrid'
ClientHeight = 294
ClientWidth = 530
OnCreate = FormCreate
Position = poScreenCenter
LCLVersion = '1.7'
object StringGrid: TStringGrid
Left = 0
Height = 271
Top = 0
Width = 530
Align = alClient
ColCount = 8
Options = [goFixedVertLine, goFixedHorzLine, goVertLine, goHorzLine, goRangeSelect, goColSizing, goEditing, goThumbTracking, goSmoothScroll]
RowCount = 10
TabOrder = 0
OnClick = StringGridClick
OnPrepareCanvas = StringGridPrepareCanvas
end
object StatusBar: TStatusBar
Left = 0
Height = 23
Top = 271
Width = 530
Panels = <>
end
end

290
examples/gridexamples/cell_overflow/comain.pas Normal file
View File

@ -0,0 +1,290 @@
unit comain;
{$mode objfpc}{$H+}
interface
uses
Classes, Controls, Dialogs, FileUtil, Forms, Graphics, Grids, ComCtrls,
SysUtils, Types;
type
TStringGrid = class(Grids.TStringGrid)
protected
procedure ColWidthsChanged; override;
procedure DoEditorHide; override;
procedure DoEditorShow; override;
procedure DrawRow(ARow: Integer); override;
function OverflowCellRect(ACol, ARow: integer; AState: TGridDrawState;
out ANumColsNeededAtRight: Integer): TRect; overload;
function OverflowCellRect(ACol, ARow: Integer): TRect; overload;
end;
{ TMainForm }
TMainForm = class(TForm)
StatusBar: TStatusBar;
StringGrid: TStringGrid;
procedure FormCreate(Sender: TObject);
procedure StringGridClick(Sender: TObject);
procedure StringGridPrepareCanvas(sender: TObject; aCol, aRow: Integer;
aState: TGridDrawState);
private
end;
var
MainForm: TMainForm;
implementation
{$R *.lfm}
uses
LCLIntf;
{ Helper routines copied from grids.pas }
function HorizontalIntersect(const aRect,bRect: TRect): boolean;
begin
result := (aRect.Left < bRect.Right) and (aRect.Right > bRect.Left);
end;
function VerticalIntersect(const aRect,bRect: TRect): boolean;
begin
result := (aRect.Top < bRect.Bottom) and (aRect.Bottom > bRect.Top);
end;
{------------------------------------------------------------------------------}
{ Extended StringGrid }
{------------------------------------------------------------------------------}
{ Makes sure that overflowing cells are painted correctly if they a column
width changes. }
procedure TStringGrid.ColWidthsChanged;
begin
inherited;
InvalidateGrid;
end;
{ After editing a repaint of the current row is needed because the edited cell
may overflow differently }
procedure TStringGrid.DoEditorHide;
begin
inherited;
InvalidateRow(Row);
end;
{ Make sure that the cell editor has the same size as the OverflowCellRect }
procedure TStringGrid.DoEditorShow;
begin
inherited;
with OverflowCellRect(Col, Row) do begin
Editor.Width := Right - Left - 4;
end;
InvalidateRow(Row);
end;
{ Draws an entire row to correctly process overflowing cells.
Most of the code is copied from TCustomGrid.DrawRow }
procedure TStringGrid.DrawRow(ARow: Integer);
var
gds: TGridDrawState;
aCol: Integer;
ncols: Integer;
Rs: Boolean;
R: TRect;
tmpR: TRect;
ClipArea: Trect;
function IsPushCellActive: boolean;
begin
with GCache do
result := (PushedCell.X<>-1) and (PushedCell.Y<>-1);
end;
procedure DoDrawCell;
begin
with GCache do begin
if (aCol=HotCell.x) and (aRow=HotCell.y) and not IsPushCellActive() then begin
Include(gds, gdHot);
HotCellPainted := True;
end;
if ClickCellPushed and (aCol=PushedCell.x) and (aRow=PushedCell.y) then begin
Include(gds, gdPushed);
end;
end;
Canvas.SaveHandleState;
try
InterSectClipRect(Canvas.Handle, R.Left, R.Top, R.Right, R.Bottom);
DrawCell(aCol, aRow, R, gds);
finally
Canvas.RestoreHandleState;
end;
end;
begin
// Upper and Lower bounds for this row
ColRowToOffSet(False, True, aRow, R.Top, R.Bottom);
// is this row within the ClipRect?
ClipArea := Canvas.ClipRect;
if (R.Top>=R.Bottom) or not VerticalIntersect(R, ClipArea) then begin
{$IFDEF DbgVisualChange}
DebugLn('Drawrow: Skipped row: ', IntToStr(aRow));
{$ENDIF}
exit;
end;
// Draw columns in this row
with GCache.VisibleGrid do begin
aCol := FixedCols;
while (aCol < ColCount) do begin
gds := GetGridDrawState(ACol, ARow);
with OverflowCellRect(ACol, ARow, gds, ncols) do begin
R.Left := Left;
R.Right := Right;
end;
if (R.Left < R.Right) and HorizontalIntersect(R, ClipArea) then
DoDrawCell;
inc(aCol, ncols);
end;
Rs := (goRowSelect in Options);
// Draw the focus Rect
if FocusRectVisible and (ARow = Row) and
((Rs and (ARow >= Top) and (ARow <= Bottom)) or IsCellVisible(Col, ARow))
then begin
if not EditorMode then begin
if Rs then
CalcFocusRect(R, false) // will be adjusted when calling DrawFocusRect
else
ColRowToOffset(True, True, Col, R.Left, R.Right);
// is this column within the ClipRect?
if HorizontalIntersect(R, ClipArea) then
DrawFocusRect(Col, Row, R);
end;
end;
end;
// Draw fixed columns
For aCol:=0 to FixedCols-1 do begin
gds := [gdFixed];
ColRowToOffset(True, True, aCol, R.Left, R.Right);
// Is this column within the ClipRect?
if (R.Left<R.Right) and HorizontalIntersect(R, ClipArea) then
DoDrawCell;
end;
end;
{ Calculates the rectangle coordinates of the cell block covered by the
overflowing cell at the specified column and row }
function TStringGrid.OverflowCellRect(ACol, ARow: Integer): TRect;
var
n: Integer;
begin
Result := OverflowCellRect(ACol, ARow, [], n);
end;
{ Calculates the pixel coordinates of the cell block covered by the
overflowing cell at the specified column and row, and retunrs in
ANumColsNeededAtRight the number of columns covered by the cell at
ACol/ARow when going to the right }
function TStringGrid.OverflowCellRect(ACol, ARow: integer; AState: TGridDrawState;
out ANumColsNeededAtRight: Integer): TRect;
var
lIndex: integer;
ts: TTextStyle;
lCol, rCol: Integer;
len: Integer;
begin
Result := CellRect(ACol, ARow);
ANumColsNeededAtRight := 1;
len := Canvas.TextWidth(Cells[ACol, ARow]) + 2*constCellPadding;
if len > ColWidths[ACol] then begin
PrepareCanvas(ACol, ARow, AState);
ts := Canvas.TextStyle;
case ts.Alignment of
taLeftJustify:
for lIndex := ACol + 1 to ColCount - 1 do
if (Cells[lIndex, ARow] = EmptyStr) then
begin
Result.Right := CellRect(lIndex, ARow).Right;
ANumColsNeededAtRight := lIndex - ACol + 1;
if Result.Right - Result.Left > len then Break;
end else
Break;
taRightJustify:
for lIndex := ACol - 1 downto FixedCols do
if (Cells[lIndex, ARow] = EmptyStr) then
begin
Result.Left := CellRect(lIndex, ARow).Left;
if Result.Right - Result.Left > len then Break;
end else
Break;
taCenter:
begin
lIndex := 1;
while true do begin
lCol := ACol - lIndex;
rCol := ACol + lIndex;
if (lCol < FixedCols) or (rCol >= ColCount) then
break;
if (Cells[rCol, ARow] = EmptyStr) and (Cells[lCol, ARow] = EmptyStr)
then begin
Result.Left := CellRect(lCol, ARow).Left;
Result.Right := CellRect(rCol, ARow).Right;
ANumColsNeededAtRight := rCol - ACol + 1;
if Result.Right - Result.Left > len then Break;
end else
Break;
inc(lIndex);
end;
end;
end;
end;
end;
{------------------------------------------------------------------------------}
{ TMainForm }
{------------------------------------------------------------------------------}
{ Sets up basic grid content }
procedure TMainForm.FormCreate(Sender: TObject);
begin
StringGrid.Cells[1, 2] := 'ABC';
StringGrid.Cells[1, 1] := 'This is a long string for my string grid';
StringGrid.Cells[StringGrid.ColCount-1, 1] := '124';
StringGrid.Cells[StringGrid.ColCount-1, StringGrid.RowCount-1] := 'Another long text, right-aligned now';
StringGrid.Cells[4, 6] := 'This is a long string which is centered.';
end;
{ Displays information on the clicked cell in the status bar }
procedure TMainForm.StringGridClick(Sender: TObject);
begin
Statusbar.SimpleText := Format('Column %d, row %d, text: "%s"',
[StringGrid.Col, StringGrid.Row, StringGrid.Cells[StringGrid.Col, StringGrid.Row]]);
end;
{ Prepares centered text in column 4, and right-aligned text in the last column}
procedure TMainForm.StringGridPrepareCanvas(sender: TObject; aCol, aRow: Integer;
aState: TGridDrawState);
var
ts: TTextStyle;
begin
if (aCol = StringGrid.ColCount-1) then begin
ts := StringGrid.Canvas.TextStyle;
ts.Alignment := taRightJustify;
StringGrid.Canvas.TextStyle := ts;
end else
if (aCol = 4) then begin
ts := StringGrid.Canvas.TextStyle;
ts.Alignment := taCenter;
StringGrid.Canvas.TextStyle := ts;
end;
end;
end.

12
examples/gridexamples/cell_overflow/readme.txt Normal file
View File

@ -0,0 +1,12 @@
--------------------------------------------------------------------------------
cell_overflow
--------------------------------------------------------------------------------
This sample project implements overflowing text in a StringGrid descendant. This
means that text which is longer than the width of the column is not truncated
at the cell border, but is allowed to flow into adjacent empty cells.
The code is based on a forum contribution by user Geepster
(http://forum.lazarus.freepascal.org/index.php/topic,35869.msg238079.html#msg238079)
It was extended to correctly handle left, right and centered text alignments.