pascal/lazarus-ccr
1
0
Fork 0
Code Issues Releases Activity

GridPrinter: Add more general database example for printing a dbgrid. Modified TGridPrinter to make this work.

Browse Source 
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@8632 8e941d3f-bd1b-0410-a28a-d453659cc2b4
This commit is contained in:
wp_xxyyzz
2022-11-26 16:57:47 +00:00
parent c5dcc98172
commit 8bb47927c9
5 changed files with 523 additions and 11 deletions
Download Patch File Download Diff File Expand all files Collapse all files

87
components/gridprinter/examples/dbgrid2/dbgrid_demo.lpi Normal file
View File

@ -0,0 +1,87 @@
<?xml version="1.0" encoding="UTF-8"?>
<CONFIG>
<ProjectOptions>
<Version Value="12"/>
<PathDelim Value="\"/>
<General>
<Flags>
<CompatibilityMode Value="True"/>
</Flags>
<SessionStorage Value="InProjectDir"/>
<Title Value="dbgrid_demo"/>
<Scaled Value="True"/>
<ResourceType Value="res"/>
<UseXPManifest Value="True"/>
<XPManifest>
<DpiAware Value="True"/>
</XPManifest>
<Icon Value="0"/>
</General>
<BuildModes Count="1">
<Item1 Name="Default" Default="True"/>
</BuildModes>
<PublishOptions>
<Version Value="2"/>
<UseFileFilters Value="True"/>
</PublishOptions>
<RunParams>
<FormatVersion Value="2"/>
</RunParams>
<RequiredPackages Count="4">
<Item1>
<PackageName Value="GridPrinterPkg"/>
</Item1>
<Item2>
<PackageName Value="FCL"/>
</Item2>
<Item3>
<PackageName Value="MemDSLaz"/>
</Item3>
<Item4>
<PackageName Value="LCL"/>
</Item4>
</RequiredPackages>
<Units Count="2">
<Unit0>
<Filename Value="dbgrid_demo.lpr"/>
<IsPartOfProject Value="True"/>
</Unit0>
<Unit1>
<Filename Value="main.pas"/>
<IsPartOfProject Value="True"/>
<ComponentName Value="Form1"/>
<HasResources Value="True"/>
<ResourceBaseClass Value="Form"/>
</Unit1>
</Units>
</ProjectOptions>
<CompilerOptions>
<Version Value="11"/>
<PathDelim Value="\"/>
<Target>
<Filename Value="dbgrid_demo"/>
</Target>
<SearchPaths>
<IncludeFiles Value="$(ProjOutDir)"/>
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
</SearchPaths>
<Linking>
<Debugging>
<DebugInfoType Value="dsDwarf3"/>
</Debugging>
</Linking>
</CompilerOptions>
<Debugging>
<Exceptions Count="3">
<Item1>
<Name Value="EAbort"/>
</Item1>
<Item2>
<Name Value="ECodetoolError"/>
</Item2>
<Item3>
<Name Value="EFOpenError"/>
</Item3>
</Exceptions>
</Debugging>
</CONFIG>

25
components/gridprinter/examples/dbgrid2/dbgrid_demo.lpr Normal file
View File

@ -0,0 +1,25 @@
program dbgrid_demo;
{$mode objfpc}{$H+}
uses
{$IFDEF UNIX}
cthreads,
{$ENDIF}
{$IFDEF HASAMIGA}
athreads,
{$ENDIF}
Interfaces, // this includes the LCL widgetset
Forms, main, memdslaz
{ you can add units after this };
{$R *.res}
begin
RequireDerivedFormResource:=True;
Application.Scaled:=True;
Application.Initialize;
Application.CreateForm(TForm1, Form1);
Application.Run;
end.

105
components/gridprinter/examples/dbgrid2/main.lfm Normal file
View File

@ -0,0 +1,105 @@
object Form1: TForm1
Left = 331
Height = 382
Top = 130
Width = 689
Caption = 'Form1'
ClientHeight = 382
ClientWidth = 689
OnCreate = FormCreate
LCLVersion = '2.3.0.0'
object DBGrid1: TDBGrid
Left = 0
Height = 345
Top = 0
Width = 689
Align = alClient
Color = clWindow
Columns = <>
DataSource = DataSource1
FixedCols = 0
Options = [dgEditing, dgTitles, dgColumnResize, dgColumnMove, dgColLines, dgRowLines, dgTabs, dgAlwaysShowSelection, dgConfirmDelete, dgCancelOnExit, dgThumbTracking]
TabOrder = 0
end
object Panel1: TPanel
Left = 0
Height = 37
Top = 345
Width = 689
Align = alBottom
AutoSize = True
BevelOuter = bvNone
ClientHeight = 37
ClientWidth = 689
TabOrder = 1
object Button1: TButton
AnchorSideLeft.Control = Panel1
AnchorSideTop.Control = Panel1
Left = 6
Height = 25
Top = 6
Width = 104
AutoSize = True
BorderSpacing.Around = 6
Caption = 'Print preview...'
OnClick = Button1Click
TabOrder = 0
end
object cbShowTitles: TCheckBox
AnchorSideLeft.Control = Button1
AnchorSideLeft.Side = asrBottom
AnchorSideTop.Control = Panel1
AnchorSideTop.Side = asrCenter
Left = 116
Height = 19
Top = 9
Width = 75
BorderSpacing.Around = 6
Caption = 'Show titles'
OnChange = cbShowTitlesChange
TabOrder = 1
end
object cbShowIndicator: TCheckBox
AnchorSideLeft.Control = cbShowTitles
AnchorSideLeft.Side = asrBottom
AnchorSideTop.Control = Panel1
AnchorSideTop.Side = asrCenter
Left = 203
Height = 19
Top = 9
Width = 141
BorderSpacing.Left = 6
BorderSpacing.Around = 6
Caption = 'Show indicator column'
OnChange = cbShowIndicatorChange
TabOrder = 2
end
end
object DataSource1: TDataSource
DataSet = BufDataset1
Left = 256
Top = 64
end
object GridPrinter1: TGridPrinter
Footer.FontSize = 0
Header.FontSize = 0
OnAfterPrint = GridPrinter1AfterPrint
OnGetCellText = GridPrinter1GetCellText
OnGetRowCount = GridPrinter1GetRowCount
OnLinePrinted = GridPrinter1LinePrinted
OnNewPage = GridPrinter1NewPage
Left = 167
Top = 136
end
object GridPrintPreviewDialog1: TGridPrintPreviewDialog
FormParams.PixelsPerInch = 96
GridPrinter = GridPrinter1
Left = 167
Top = 208
end
object BufDataset1: TBufDataset
FieldDefs = <>
Left = 167
Top = 64
end
end

239
components/gridprinter/examples/dbgrid2/main.pas Normal file
View File

@ -0,0 +1,239 @@
unit main;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, DB, BufDataset, Forms, Controls, Graphics, Dialogs,
DBGrids, ExtCtrls, StdCtrls, GridPrn, GridPrnPreviewDlg, Grids;
type
{ TForm1 }
TForm1 = class(TForm)
BufDataset1: TBufDataset;
Button1: TButton;
cbShowTitles: TCheckBox;
cbShowIndicator: TCheckBox;
DataSource1: TDataSource;
DBGrid1: TDBGrid;
GridPrinter1: TGridPrinter;
GridPrintPreviewDialog1: TGridPrintPreviewDialog;
Panel1: TPanel;
procedure Button1Click(Sender: TObject);
procedure cbShowIndicatorChange(Sender: TObject);
procedure cbShowTitlesChange(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure GridPrinter1AfterPrint(Sender: TObject);
procedure GridPrinter1GetCellText(Sender: TObject; AGrid: TCustomGrid;
ACol, ARow: Integer; var AText: String);
procedure GridPrinter1GetRowCount(Sender: TObject; {%H-}AGrid: TCustomGrid;
var ARowCount: Integer);
procedure GridPrinter1LinePrinted(Sender: TObject; AGrid: TCustomGrid;
ARow, ALastCol: Integer);
procedure GridPrinter1NewPage(Sender: TObject; {%H-}AGrid: TCustomGrid;
{%H-}APageNo: Integer; AStartCol, AStartRow, AEndCol, AEndRow: Integer);
private
FPageStartBookmark: TBookmark;
FPageStartCol: Integer;
FPageStartRow: Integer;
FPageEndCol: Integer;
FPageEndRow: Integer;
public
end;
var
Form1: TForm1;
implementation
{$R *.lfm}
function RandomString(Len: Integer): String;
var
i: Integer;
begin
SetLength(Result, Len);
Result[1] := Char(ord('A') + Random(26));
for i := 2 to Len do
Result[i] := Char(ord('a') + Random(26));
end;
{ TForm1 }
procedure TForm1.FormCreate(Sender: TObject);
const
NUM_RECORDS = 100;
var
i: Integer;
begin
// Create some dummy dataset
BufDataset1.FieldDefs.Add('TextField1', ftString, 20);
BufDataset1.FieldDefs.Add('TextField2', ftString, 15);
BufDataset1.FieldDefs.Add('IntField', ftInteger);
BufDataset1.FieldDefs.Add('FloatField', ftFloat);
BufDataset1.FieldDefs.Add('BoolField', ftBoolean);
BufDataset1.FieldDefs.Add('DateField', ftDate);
BufDataset1.FieldDefs.Add('TimeField', ftTime);
BufDataset1.CreateDataset;
BufDataset1.Open;
for i := 1 to NUM_RECORDS do
BufDataset1.AppendRecord([
'Record ' + IntToStr(i),
RandomString(Random(10) + 5),
100*i,
0.1*i,
Boolean(Random(2)),
Date()-i,
TTime(Random)
]);
BufDataset1.First;
(BufDataset1.FieldByName('FloatField') as TFloatField).precision := 4;
// Since the GridPrinter accesses the DBGrid assign it to the Grid property
// only after the Dataset is ready and the DBGrid can display valid data.
GridPrinter1.Grid := DBGrid1;
cbShowTitles.Checked := dgTitles in DBGrid1.Options;
cbShowIndicator.Checked := dgIndicator in DBGrid1.Options;
end;
{ The OnAfterPrint event fires after printing/preview. We use it to free the
bookmark needed for storing the top record of each page. }
procedure TForm1.GridPrinter1AfterPrint(Sender: TObject);
begin
BufDataset1.FreeBookmark(FPageStartBookmark);
end;
procedure TForm1.Button1Click(Sender: TObject);
var
bm: TBookmark;
begin
// Store currently active record so that we can return to it after preview/print.
bm := BufDataset1.GetBookmark;
try
// Disable scrolling of grid
BufDataset1.DisableControls;
try
// Show the grid printpreview
GridPrintPreviewDialog1.Execute;
finally
// Allow scrolling again
BufDataset1.EnableControls;
end;
// Return to the stored record position.
BufDataset1.GotoBookmark(bm);
finally
BufDataset1.FreeBookmark(bm);
end;
end;
procedure TForm1.cbShowIndicatorChange(Sender: TObject);
begin
if cbShowIndicator.Checked then
DBGrid1.Options := DBGrid1.Options + [dgIndicator]
else
DBGrid1.Options := DBGrid1.Options - [dgIndicator];
end;
procedure TForm1.cbShowTitlesChange(Sender: TObject);
begin
if cbShowTitles.Checked then
DBGrid1.Options := DBGrid1.Options + [dgTitles]
else
DBGrid1.Options := DBGrid1.Options - [dgTitles];
end;
{ The OnGetCellText fires whenever a cell is printed and the printer needs to
know the cell text. }
procedure TForm1.GridPrinter1GetCellText(Sender: TObject; AGrid: TCustomGrid;
ACol, ARow: Integer; var AText: String);
var
dbGrid: TDBGrid;
col: TColumn;
begin
AText := '';
dbGrid := AGrid as TDBGrid;
if (dgIndicator in dbGrid.Options) then
begin
if ACol = 0 then
exit;
col := dbGrid.Columns[ACol - 1];
end else
col := dbGrid.Columns[ACol];
if (ARow = 0) and (dgTitles in dbGrid.Options) then
begin
AText := col.FieldName;
exit;
end;
AText := col.Field.AsString;
end;
{ Since the DBGrid does not load all records, but we want to print all
of them, we must tell the printer the real number of rows to print. }
procedure TForm1.GridPrinter1GetRowCount(Sender: TObject; AGrid: TCustomGrid;
var ARowCount: Integer);
begin
BufDataset1.Last;
BufDataset1.First;
ARowCount := BufDataset1.RecordCount;
if dgTitles in TDBGrid(AGrid).Options then
inc(ARowCount); // added 1 for the header row
end;
{ The event OnLinePrinted fires when the row with the specified index is
completely printed. The last printed cell has the index ALastCol.
The purpose of this event is to advance the dataset cursor to the next
record for printing. This normally is done by Dataset.Next, except for
the very last row of each page requiring special treatment - see below. }
procedure TForm1.GridPrinter1LinePrinted(Sender: TObject; AGrid: TCustomGrid;
ARow, ALastCol: Integer);
begin
case GridPrinter1.PrintOrder of
poRowsFirst:
// When the last row of a "rows first" page has been printed we return
// to the record of the first line of that page if more pages are following
// along the row. If we printed the last page of that row we must advance
// to the next record.
if (ARow = FPageEndRow) and (ALastCol <> GridPrinter1.ColCount - 1) then
BufDataset1.GotoBookmark(FPageStartBookmark)
else
BufDataset1.Next;
poColsFirst:
// When the last row of a "cols first" page has been printed we normally
// advance to the next record, unless the rows are continued on other
// pages where we return to the first record of the dataset.
if (ARow = GridPrinter1.RowCount-1) then
BufDataset1.First
else
BufDataset1.Next;
end;
end;
{ The event OnNewPage fires when the printer is about to begin a new page.
The page will contain cells between AStartCol, AStartRow in the top/left corner,
and AEndCol/AEndRow in the bottom/right corner.
We are setting a bookmark so that the dataset can return to this record
in case of page-breaks in "rows-first" print order. }
procedure TForm1.GridPrinter1NewPage(Sender: TObject; AGrid: TCustomGrid;
APageNo: Integer; AStartCol, AStartRow, AEndCol, AEndRow: Integer);
begin
FPageStartCol := AStartCol;
FPageStartRow := AStartRow;
FPageEndCol := AEndCol;
FPageEndRow := AEndRow;
BufDataset1.FreeBookmark(FPageStartBookmark);
FPageStartBookmark := BufDataset1.GetBookmark;
end;
end.

78
components/gridprinter/source/gridprn.pas
View File

@ -24,6 +24,12 @@ type
TGridPrnGetRowCountEvent = procedure (Sender: TObject; AGrid: TCustomGrid;
var ARowCount: Integer) of object;
TGridPrnLinePrintedEvent = procedure (Sender: TObject; AGrid: TCustomGrid;
ARow, ALastCol: Integer) of object;
TGridPrnNewPageEvent = procedure (Sender: TObject; AGrid: TCustomGrid;
APageNo: Integer; AStartCol, AStartRow, AEndCol, AEndRow: Integer) of object;
TGridPrnHeaderFooterSection = (hfsLeft, hfsCenter, hfsRight);
TGridPrnOption = (gpoCenterHor, gpoCenterVert,
@ -149,12 +155,15 @@ type
FOnGetCellText: TGridPrnGetCellTextEvent;
FOnGetColCount: TGridPrnGetColCountEvent;
FOnGetRowCount: TGridPrnGetRowCountEvent;
FOnLinePrinted: TGridPrnLinePrintedEvent;
FOnNewPage: TGridPrnNewPageEvent;
FOnPrepareCanvas: TOnPrepareCanvasEvent;
FOnPrintCell: TGridPrnPrintCellEvent;
FOnUpdatePreview: TNotifyEvent;
function GetBorderLineWidthHor: Integer;
function GetBorderLineWidthVert: Integer;
function GetCanvas: TCanvas;
function GetColWidth(AIndex: Integer): Double;
function GetFixedLineWidthHor: Integer;
function GetFixedLineWidthVert: Integer;
function GetGridLineWidthHor: Integer;
@ -162,6 +171,7 @@ type
function GetOrientation: TPrinterOrientation;
function GetPageCount: Integer;
function GetPageNumber: Integer;
function GetRowHeight(AIndex: Integer): Double;
function IsBorderLineWidthStored: Boolean;
function IsFixedLineWidthStored: Boolean;
function IsGridLineWidthStored: Boolean;
@ -207,13 +217,16 @@ type
FPrinting: Boolean;
procedure CalcFixedColPos(AStartCol, AEndCol: Integer; var ALeft, ARight: Integer);
procedure CalcFixedRowPos(AStartRow, AEndRow: Integer; var ATop, ABottom: Integer);
procedure DoLinePrinted(ARow, ALastCol: Integer); virtual;
procedure DoNewPage(AStartCol, AStartRow, AEndCol, AEndRow: Integer); virtual;
procedure DoPrepareCanvas(ACol, ARow: Integer); virtual;
procedure DoPrintCell(ACanvas: TCanvas; ACol, ARow: Integer; ARect: TRect); virtual;
procedure DoUpdatePreview; virtual;
procedure Execute(ACanvas: TCanvas);
function GetBrushColor(AColor: TColor): TColor;
function GetFontColor(AColor: TColor): TColor;
function GetPenColor(AColor: TCOlor): TColor;
procedure LayoutPagebreaks;
procedure LayoutPageBreaks;
procedure Loaded; override;
procedure Measure(APageWidth, APageHeight, XDpi, YDpi: Integer);
procedure NewPage;
@ -246,6 +259,8 @@ type
function ScaleY(AValue: Integer): Integer; inline;
procedure UpdatePreview;
property Canvas: TCanvas read GetCanvas;
property ColCount: Integer read FColCount;
property ColWidth[AIndex: Integer]: Double read GetColWidth;
property FooterMargin: Integer read FFooterMargin;
property HeaderMargin: Integer read FHeaderMargin;
property PageHeight: Integer read FPageHeight;
@ -259,6 +274,8 @@ type
property PrintScaleToNumHorPages: Integer read FPrintScaleToNumHorPages write FPrintScaleToNumHorPages;
property PrintScaleToNumVertPages: Integer read FPrintScaleToNumVertPages write FPrintScaleToNumVertPages;
property PrintScalingMode: TGridPrnScalingMode read FPrintScalingMode write FPrintScalingMode;
property RowCount: Integer read FRowCount;
property RowHeight[AIndex: Integer]: Double read GetRowHeight;
published
property Grid: TCustomGrid read FGrid write SetGrid;
property BorderLineColor: TColor read FBorderLineColor write SetBorderLineColor default clDefault;
@ -284,6 +301,8 @@ type
property OnGetCellText: TGridPrnGetCellTextEvent read FOnGetCellText write FOnGetCellText;
property OnGetRowCount: TGridPrnGetRowCountEvent read FOnGetRowCount write FOnGetRowCount;
property OnGetColCount: TGridPrnGetColCountEvent read FOnGetColCount write FOnGetColCount;
property OnLinePrinted: TGridPrnLinePrintedEvent read FOnLinePrinted write FOnLinePrinted; // Finished printing a line
property OnNewPage: TGridPrnNewPageEvent read FOnNewPage write FOnNewPage; // Started printing a new page
property OnPrepareCanvas: TOnPrepareCanvasEvent read FOnPrepareCanvas write FOnPrepareCanvas;
property OnPrintCell: TGridPrnPrintCellEvent read FOnPrintCell write FOnPrintCell;
property OnUpdatePreview: TNotifyEvent read FOnUpdatePreview write FOnUpdatePreview;
@ -714,12 +733,34 @@ begin
Result := FPreviewBitmap;
end;
procedure TGridPrinter.DoLinePrinted(ARow, ALastCol: Integer);
begin
if Assigned(FOnLinePrinted) then
FOnLinePrinted(Self, FGrid, ARow, ALastCol);
end;
procedure TGridPrinter.DoNewPage(AStartCol, AStartRow, AEndCol, AEndRow: Integer);
begin
if Assigned(FOnNewPage) then
FOnNewPage(Self, FGrid, FPageNumber, AStartCol, AStartRow, AEndCol, AEndRow);
end;
procedure TGridPrinter.DoPrepareCanvas(ACol, ARow: Integer);
begin
if Assigned(FOnPrepareCanvas) then
FOnPrepareCanvas(Self, ACol, ARow, []);
end;
procedure TGridPrinter.DoPrintCell(ACanvas: TCanvas; ACol, ARow: Integer;
ARect: TRect);
begin
if Assigned(FOnPrintCell) then
begin
FOnPrintCell(Self, FGrid, ACanvas, ACol, ARow, ARect);
exit;
end;
end;
procedure TGridPrinter.DoUpdatePreview;
begin
if Assigned(FOnUpdatePreview) and (FOutputDevice = odPreview) then
@ -794,6 +835,11 @@ begin
Result := nil;
end;
function TGridPrinter.GetColWidth(AIndex: Integer): Double;
begin
Result := FColWidths[AIndex];
end;
function TGridPrinter.GetCellText(ACol, ARow: Integer): String;
var
col: TGridColumn;
@ -804,7 +850,7 @@ begin
exit;
lGrid := TGridAccess(FGrid);
if lGrid.Columns.Enabled and (ACol >= FFixedCols) and (ARow = 0) then
if lGrid.Columns.Enabled and (FFixedCols > 0) and (ACol >= FFixedCols) and (ARow = 0) then
begin
col := lGrid.Columns[ACol - FFixedCols];
Result := col.Title.Caption;
@ -868,6 +914,11 @@ begin
Result := FPageNumber;
end;
function TGridPrinter.GetRowHeight(AIndex: Integer): Double;
begin
Result := FRowHeights[AIndex];
end;
function TGridPrinter.IsBorderLineWidthStored: Boolean;
begin
Result := FBorderLineWidth >= 0.0;
@ -1141,7 +1192,7 @@ procedure TGridPrinter.PrintByCols(ACanvas: TCanvas);
var
vertPage, horPage: Integer;
col1, col2: Integer;
row1, row2: Integer;
row1, row2, row: Integer;
firstPrintPage, lastPrintPage: Integer;
printThisPage: Boolean;
begin
@ -1175,8 +1226,12 @@ begin
else
raise Exception.Create('[TGridPrinter.PrintByCols] Unknown output device.');
end;
DoNewPage(col1, row1, col2, row2);
if printThisPage then
PrintPage(ACanvas, col1, row1, col2, row2);
PrintPage(ACanvas, col1, row1, col2, row2)
else
for row := row1 to row2 do
DoLinePrinted(row, col2);
inc(FPageNumber);
end;
end;
@ -1187,7 +1242,7 @@ procedure TGridPrinter.PrintByRows(ACanvas: TCanvas);
var
vertPage, horPage: Integer;
col1, col2: Integer;
row1, row2: Integer;
row1, row2, row: Integer;
firstPrintPage, lastPrintPage: Integer;
printThisPage: Boolean;
begin
@ -1221,8 +1276,12 @@ begin
else
raise Exception.Create('[TGridPrinter.PrintByRows] Unknown output device.');
end;
DoNewPage(col1, row1, col2, row2);
if printThisPage then
PrintPage(ACanvas, col1, row1, col2, row2);
PrintPage(ACanvas, col1, row1, col2, row2)
else
for row := row1 to row2 do
DoLinePrinted(row, col2);
inc(FPageNumber);
end;
end;
@ -1237,11 +1296,7 @@ var
lGrid: TGridAccess;
checkedState: TCheckboxState;
begin
if Assigned(FOnPrintCell) then
begin
FOnPrintCell(Self, FGrid, ACanvas, ACol, ARow, ARect);
exit;
end;
DoPrintCell(ACanvas, ACol, ARow, ARect);
lGrid := TGridAccess(FGrid);
@ -1650,6 +1705,7 @@ begin
PrintCell(ACanvas, col, row, R);
x := x2;
end;
DoLinePrinted(row, AEndCol);
y := y2;
end;