pascal/kolmck
pascal/kolmck
1
0
Fork 0
Code Issues Releases Activity
cb7f421737
kolmck/Addons/KOLReport.pas
dkolmck ec2ce65753 3.00F 
git-svn-id: https://svn.code.sf.net/p/kolmck/code@76 91bb2d04-0c0c-4d2d-88a5-bbb6f4c1fa07
2010-10-09 13:35:54 +00:00

1277 lines
40 KiB
ObjectPascal
Raw Blame History

{ KOLReport v2.0 (C) 2002 by Vladimir Kladov.
See Demo project attached for documentation. All other documentation planned
to be added later.
In version 2.0:
[+] metafiles used, spooling size became less, printing quality increased.
[+] with new version of KOLPrinters by Boguslaw Brandys, printer setup dialog provided.
}
unit KOLReport;
interface
//{$DEFINE use_MHPRINTER}
// (uncomment line above to use TKOLMHPrinter prior to TKOLPrinter)
uses Windows, Messages, KOL,
{$IFDEF use_MHPRINTER} KOLMHPrinters
{$ELSE} KOLPrinters, KOLPageSetupDialog
{$ENDIF};
type
{$IFDEF use_MHPRINTER} PPrinter = PMHPrinter; {$ENDIF}
TPaperSize = ( psA4, psA5, psA6, psA3, psLetter, psCustom );
{* Available paper sizes. }
TBandLayout = ( blLeft, blCenter, blRight, blExpandRight );
{* Available band layouts. }
TMargins = TRect;
TMF = HDC; // used as a handle to memory-based EnhMetafile.
PReport = ^TReport;
PPreviewObj = ^TPreviewObj;
TPreviewObj = object( TObj )
{* Preview form container object. }
private
procedure SetCurPage(const Value: Integer);
procedure SetFitMode(const Value: Integer);
public
Form: PControl;
{* Form. }
TB: PControl;
{* Toolbar. }
SB: PControl;
{* Scrollbar. }
PB: PControl;
{* PaintBox. }
LB: PControl;
PSD: PPageSetupDlg; {Brandys}
Options: TPageSetupOptions;
{* Label to show current page number and total pages count. }
FFitMode: Integer;
{* Fit mode: 0 - fit height, 1 - fit width, 2 - 1:1 }
ViewMenu: PMenu;
{* Drop down menu for toolbar button TBView. }
FBuf: PBitmap;
{* Buffer where current page stored (scaled). }
protected
FReport: PReport;
{* Reference to parent Report object. }
FCurPage: Integer;
{* Current page index. }
FBufPage: Integer;
{* Buffered page index. }
procedure TBClick( Sender: PObj );
procedure TBDropDownViewMenu( Sender: PObj );
procedure TBViewMenuClick( Sender: PMenu; Item: Integer );
procedure AdjustButtons( Sender: PObj );
procedure PaintPage( Sender: PControl; DC: HDC );
procedure AdjustFitMode;
procedure PrinterSetup;
procedure ResizePreviewForm( Sender: PObj );
public
destructor Destroy; virtual;
{* }
property CurPage: Integer read FCurPage write SetCurPage;
{* Current page index (starting from 0). }
function PageCount: Integer;
{* Total pages count. Could be 0, if a report is empty (nothing to show). }
procedure PrintAllPages;
{* Call this method to print all pages. }
property FitMode: Integer read FFitMode write SetFitMode;
{* Fit mode: 0 - fit height, 1 - fit width, 2 - 1:1. }
end;
TReport = object( TObj )
{* Report object. It is used to create report and to print or preview it}
private
FDocName: String;
FReplaceFontHeight0: Integer;
FMargins: TMargins;
function GetPages(Idx: Integer): TMF;
function GetImages(Idx: Integer): HENHMETAFILE;
procedure SetMargins(const Value: TMargins);
function GetMarginsPixels( const Index: Integer ): TMargins;
protected
FPageTop: Boolean;
FY: Integer;
FOnNewPage: TOnEvent;
FPrinter: PPrinter;
FX: Integer;
FPrinting: Boolean;
FDCPages: PList;
FHDPages: PList;
FStage: Integer;
FOnPrint: TOnEvent;
FPreviewForm: PPreviewObj;
FBottom: Integer;
FPagePixelsSize: TSize;
FPaperSize: TPaperSize;
FCustomPaperSize: TSize;
FPageWidth: Integer;
FPageHeight: Integer;
FDoubleBufferedPreview: Boolean;
FCurBandHeight: Integer;
FOnEndBand: TOnEvent;
fNewPageHandling: Boolean;
fNewBandHandling: Boolean;
procedure SetPageTop(const Value: Boolean);
procedure SetPrinter(const Value: PPrinter);
function GetPageCount: Integer;
function GetPreviewForm: PPreviewObj;
procedure SetPreviewForm(const Value: PPreviewObj);
function GetCurrentPage: TMF;
function GetPrinter: PPrinter;
function GetPagePixelsSize: TSize;
function GetOrientation: TPrinterOrientation;
procedure SetPaperSize(const Value: TPaperSize);
procedure SetCustomPaperSize(const Value: TSize);
function GetPageHeight: Integer;
function GetPageWidth: Integer;
procedure GetPageWidthHeight;
procedure SetX(const Value: Integer);
procedure SetY(const Value: Integer);
protected
function AddPage: TMF;
function PaintBand( MF: TMF; Band: PControl; Xpos, Ypos: Integer ): Integer;
function ScaleX( W: Integer ): Integer;
function ScaleY( H: Integer ): Integer;
procedure DoPrintPreview( Proc: TObjectMethod );
procedure DoPrint;
procedure DoPreview;
procedure DoPreviewModal;
public
Destructor Destroy; virtual;
procedure Clear;
{* Call this method to make report empty. If the preview form is active
for the report, it is closed too. }
procedure ClearPages;
{* Clears all pages. }
property PreviewForm: PPreviewObj read GetPreviewForm write SetPreviewForm;
{* Access to preview form object. }
property DoubleBufferedPreview: Boolean read FDoubleBufferedPreview write FDoubleBufferedPreview;
{* Set this value to TRUE, if you wish from PreviewForm to be shown
DoubleBuffered. }
property PagePixelsSize: TSize read GetPagePixelsSize;
{* Size of a page in screen pixels. }
property Orientation: TPrinterOrientation read GetOrientation;
{* Orientation of a Printer. }
property PaperSize: TPaperSize read FPaperSize write SetPaperSize;
{* Paper size type (psA4, psA3, ... psCustom). }
property CustomPaperSize: TSize read FCustomPaperSize write SetCustomPaperSize;
{* Custom paper size in millimeters. }
property PageWidth: Integer read GetPageWidth;
{* Paper width in Printer canvas pixels. }
property PageHeight: Integer read GetPageHeight;
{* Paper height in Printer canvas pixels. }
property CurrentPage: TMF read GetCurrentPage;
{* Current page metafile DC. Valid only while drawing the page. }
property Printer: PPrinter read GetPrinter write SetPrinter;
{* Printer object. }
property PageTop: Boolean read FPageTop write SetPageTop;
{* True, if current position is on top of current page. (It is set to
True just after calling OnNewPage event, i.e. *after* printing top
page colontitles). }
property X: Integer read FX write SetX;
{* Current X position. }
property Y: Integer read FY write SetY;
{* Current Y position. }
public
procedure AddBand( Band: PControl );
{* Call this method to add a band. Band could be any control, not only
created with NewBand or NewReportLabel etc. Before adding a band,
change its contant as you wish (change Caption, adjust Frames, Color,
Font, etc.) }
procedure AddBandEx( Band: PControl; BandLayout: TBandLayout );
{* Call this method to add a band with special aligning option. }
procedure AddFooter( Band: PControl );
{* Adds a footer band to a current page. It is possible to add several
footers, in such case the first is added to the bottom, and all the
follows above it. }
procedure AddFooterEx( Band: PControl; BandLayout: TBandLayout );
{* Adds a footer with special aligning option. }
procedure AddRight( Band: PControl );
{* Adds a band or a cell just right, without shifting current Y position
onto a height of a Band, like in AddBand or AddBandEx. Calling
AddRight ands AddRightEx several times it is possible to construct
desired band from prepared cells dynamically. If there are no place
for a new band between X position and right margin of the page, new
band is added from the starting of the next horizontal band
automatically. }
procedure AddRightEx( Band: PControl; BandLayout: TBandLayout );
{* Adds a band or a cell just right, and with additional layout options. }
procedure NewPage;
{* Forces new page. If called twice, empty page will be printed. }
property Bottom: Integer read FBottom;
{* Bottom available position (in screen pixels). Valid while drawing
onto current page. }
property PageCount: Integer read GetPageCount;
{* Total number of pages. }
property Pages[ Idx: Integer ]: TMF read GetPages;
{* Access to pages metafiles DC. Valid while drawing pages. }
property Images[ Idx: Integer ]: HENHMETAFILE read GetImages;
{* Access to page metafiles handles. If a handle for a certain page
is accessed, its metafile DC become unavailable. }
procedure Print;
{* Call this method to print all the pages. }
procedure PrintPages( FromPage, ToPage: Integer );
{* Call this method to print given pages range. }
procedure Preview;
{* Call this method to show preview non-modal. Be sure, that the Report
object is existing while preview is active. }
procedure PreviewModal;
{* Call this method to show preview form modal. }
procedure Abort;
{* Call this method to stop current printing. }
property Printing: Boolean read FPrinting;
{* True, if pages are currently printing. }
property Stage: Integer read FStage;
{* If OnPrint event is called, this value 1 or 2 shows a stage of
printing. In the first call of OnPrint event, it has value 1, in the
second its value is 2. }
property OnPrint: TOnEvent read FOnPrint write FOnPrint;
{* If this event is assigned, perform adding all bands in this event
handler. Please remember, that OnPrint is called twice. Be sure, that
all your initializations made correctly for both stages. Mainly, this
method is used to provide printing some data which depends on total
pages count (e.g. to print Page 1 From 10. You should store total
pages count after stage 1, and use this information on stage 2).
Also, this event allows to repeat printing after showing Printer setup
dialog in case when some settings are changed (page size, layout,
margins, etc.) }
property OnNewPage: TOnEvent read FOnNewPage write FOnNewPage;
{* This event is called when new page is started (by any reason). You can
add here page header or footers, if you wish. }
property OnEndBand: TOnEvent read FOnEndBand write FOnEndBand;
{* This event can be useful when bands are created dynamically from cells
calling AddRight or AddRightEx. }
function HeightAvailable: Integer;
{* Pixels available vertically on current page (in screen pixels). If
this value is not sufficient to add a band, new page is started. It
is possible to check this value manually to ensure that a certain
number of bands could be fit, and to force new page if you wish from
some data to be located always together, e.g. subdetail title +
column header + at least 1 band of subdetail data. }
property DocumentName: String read FDocName write FDocName;
{* Assign a name of your document here. This value is shown in spooler
queue and helps to identify your report among other printing documents. }
property ReplaceFontHeight0: Integer read FReplaceFontHeight0 write FReplaceFontHeight0;
{* Change this value, if default value 18 pixels is not satisfying you.
While adding a band, all its fonts with FontHeight=0 are replaced by this
value to provide correct scaling onto Printer device. }
property Margins: TMargins read FMargins write SetMargins;
{* Margins in 0.01 millimeters. }
property MarginsPrinterPixels: TMargins index 1 read GetMarginsPixels;
{* Margins in Printer's pixels. }
property MarginsScreenPixels: TMargins index 2 read GetMarginsPixels;
{* Margins in screen pixels. }
end;
TFrame = ( frLeft, frTop, frRight, frBottom );
{* Frames for special band control. }
TFrames = set of TFrame;
{* }
TPaddings = packed record
{* Paddings. }
LeftPadding, TopPadding, RightPadding, BottomPadding: Integer;
end;
const
AllFrames: TFrames = [ frLeft, frTop, frRight, frBottom ];
{* Use this constant to tell that all the frames are turned on. }
function NewReport: PReport;
{* Call this function to create report object. }
procedure NewPreviewForm( var PreviewObj: PPreviewObj; AParent: PControl );
{* This function is called automatically when Preview or PreviewModal method
is called for TReport object. }
function NewBand( AParent: PControl; Frames: TFrames ): PControl;
{* Call this function to create special band control. It is very similar to
a panel, and can contain other controls as children. }
function NewReportLabel( AParent: PControl; const Caption: String; Frames: TFrames ): PControl;
{* Call this function to create band label. It can be used along or as a
child of a band. }
function NewWordWrapReportLabel( AParent: PControl; const Caption: String; Frames: TFrames ): PControl;
{* Like NewReportLabel, but with WordWrap. }
procedure SetPaddings( BandCtl: PControl; LeftPadding, TopPadding, RightPadding, BottomPadding: Integer );
{* Use this function to change band paddings. }
type
TKOLReport = PReport;
TKOLBand = PControl;
TKOLReportLabel = PControl;
implementation
const TBFrst = 0;
TBPrev = 1;
TBNext = 2;
TBLast = 3;
TBPrnt = 4;
TBSetu = 5;
TBView = 6;
TBExit = 7;
function GetProviderPrinter: PPrinter;
begin
Result := Printer;
end;
function NewReport: PReport;
begin
new( Result, Create );
Result.FDocName := 'Report 1';
Result.FDCPages := NewList;
Result.FHDPages := NewList;
Result.FCustomPaperSize.cx := 210;
Result.FCustomPaperSize.cy := 270;
Result.FReplaceFontHeight0 := -12;
Result.FMargins := MakeRect( 500, 500, 500, 500 );
end;
procedure NewPreviewForm( var PreviewObj: PPreviewObj; AParent: PControl );
var Pn: PControl;
begin
new( PreviewObj, Create );
PreviewObj.Form := NewForm( AParent, 'Preview' ).SetSize( 600, 600 )
.SetPosition( (GetSystemMetrics( SM_CXSCREEN ) - 600) div 2,
(GetSystemMetrics( SM_CYSCREEN ) - 600) div 2 );
{Brandys}
PreviewObj.Options := [psdMargins,psdSamplePage,psdPaperControl,psdPrinterControl,psdWarning,psdHundredthsOfMillimeters,psdUseMargins,psdUseMinMargins];
PreviewObj.PSD := NewPageSetupDialog(PreviewObj.Form,PreviewObj.Options);
PreviewObj.PSD.SetMinMargins(500,500,500,500);
PreviewObj.Form.Border := 0;
Pn := NewPanel( PreviewObj.Form, esNone ).SetSize( 0, 25 ).SetAlign( caTop );
PreviewObj.TB := NewToolbar( Pn, caNone, [ tboNoDivider ],
THandle(-1), [ '<<', '<', '>', '>>', ' Print', 'Setup', '^View', 'Close' ],
[ -1, -1, -1, -1, 14, -2 ] ).SetAlign( caLeft ).SetSize( 440, 0 );
PreviewObj.TB.OnClick := PreviewObj.TBClick;
PreviewObj.TB.OnTBDropDown := PreviewObj.TBDropDownViewMenu;
NewMenu( PreviewObj.Form, 0, [ '' ], nil );
PreviewObj.ViewMenu := NewMenu( PreviewObj.Form, 0,
[ '-!Fit &Height', '-!Fit &Width', '-!&1:1' ],
PreviewObj.TBViewMenuClick );
PreviewObj.LB := NewLabel( Pn, '' ).SetAlign( caClient );
PreviewObj.LB.TextAlign := taRight;
PreviewObj.LB.VerticalAlign := vaCenter;
PreviewObj.Form.OnShow := PreviewObj.AdjustButtons;
PreviewObj.SB := NewScrollBoxEx( PreviewObj.Form, esLowered ).SetAlign( caClient );
PreviewObj.PB := NewPaintBox( PreviewObj.SB );
PreviewObj.PB.OnPaint := PreviewObj.PaintPage;
//PreviewObj.TB.TBButtonVisible[ TBSetu ] := FALSE;
PreviewObj.Form.OnResize := PreviewObj.ResizePreviewForm;
end;
type
PFramesData = ^TFramesData;
TFramesData = packed Record
Frames: TFrames;
Paddings: TPaddings;
end;
procedure PaintFrames( Self_, Sender: PControl; DC: HDC );
var Br: HBrush;
R: TRect;
procedure FillFrame( X1, Y1, X2, Y2: Integer );
begin
if X2 <= X1 then Exit;
if Y2 <= Y1 then Exit;
FillRect( DC, MakeRect( X1, Y1, X2, Y2 ), Br );
end;
var Data: PFramesData;
W, H, B: Integer;
Fmt: DWORD;
OldFont: HFont;
OldBk: Integer;
begin
Data := Self_.CustomData;
Br := CreateSolidBrush( Color2RGB( Self_.Font.Color ) );
W := Self_.ClientWidth;
H := Self_.ClientHeight;
B := Self_.Border;
R := Self_.ClientRect;
if frLeft in Data.Frames then
begin
FillFrame( 0, 0, B, H );
Inc( R.Left, B );
end;
if frTop in Data.Frames then
begin
FillFrame( 0, 0, W, B );
Inc( R.Top, B );
end;
if frRight in Data.Frames then
begin
FillFrame( W - B, 0, W, H );
Dec( R.Right, B );
end;
if frBottom in Data.Frames then
begin
FillFrame( 0, H - B, W, H );
Dec( R.Bottom, B );
end;
DeleteObject( Br );
Br := CreateSolidBrush( Color2RGB( Self_.Color ) );
FillRect( DC, R, Br );
Inc( R.Left, Data.Paddings.LeftPadding );
Inc( R.Top, Data.Paddings.TopPadding );
Dec( R.Right, Data.Paddings.RightPadding );
Dec( R.Bottom, Data.Paddings.BottomPadding );
DeleteObject( Br );
case Self_.TextAlign of
taCenter: Fmt := DT_CENTER;
taRight: Fmt := DT_RIGHT;
else Fmt := DT_LEFT;
end;
case Self_.VerticalAlign of
vaTop: Fmt := Fmt or DT_TOP;
vaCenter: Fmt := Fmt or DT_VCENTER;
vaBottom: Fmt := Fmt or DT_BOTTOM;
end;
if Self_.WordWrap then
Fmt := Fmt or DT_WORDBREAK
else
Fmt := Fmt or DT_SINGLELINE;
OldFont := SelectObject( DC, Self_.Font.Handle );
OldBk := SetBkMode( DC, TRANSPARENT );
DrawText( DC, PChar( Self_.Caption ), Length( Self_.Caption ), R, Fmt );
SetBkMode( DC, OldBk );
SelectObject( DC, OldFont );
end;
function NewBand( AParent: PControl; Frames: TFrames ): PControl;
var Data: PFramesData;
begin
Result := NewPanel( AParent, esNone );
Result.Color := clWhite;
Result.Border := 1;
Data := AllocMem( Sizeof( TFramesData ) );
Result.CustomData := Data;
Data.Frames := Frames;
Data.Paddings.LeftPadding := 4;
Data.Paddings.RightPadding := 4;
Result.OnPaint := TOnPaint( MakeMethod( Result, @ PaintFrames ) );
Result.Width := 400;
Result.Height := 40;
Result.aAutoSzX := 12;
end;
procedure InitBandLabel( L: PControl; Frames: TFrames );
var Data: PFramesData;
begin
L.Color := clWhite;
L.Border := 1;
Data := AllocMem( Sizeof( TFramesData ) );
L.CustomData := Data;
Data.Frames := Frames;
Data.Paddings.LeftPadding := 4;
Data.Paddings.RightPadding := 4;
L.OnPaint := TOnPaint( MakeMethod( L, @ PaintFrames ) );
L.aAutoSzX := 12;
end;
function NewReportLabel( AParent: PControl; const Caption: String; Frames: TFrames ): PControl;
begin
Result := NewLabel( AParent, Caption ).AutoSize( TRUE );
InitBandLabel( Result, Frames );
end;
function NewWordWrapReportLabel( AParent: PControl; const Caption: String; Frames: TFrames ): PControl;
begin
Result := NewWordWrapLabel( AParent, Caption ).AutoSize( TRUE );
InitBandLabel( Result, Frames );
end;
procedure SetPaddings( BandCtl: PControl; LeftPadding, TopPadding, RightPadding, BottomPadding: Integer );
var Data: PFramesData;
WasHPadding: Integer;
begin
Data := BandCtl.CustomData;
WasHPadding := Data.Paddings.LeftPadding + Data.Paddings.RightPadding;
Data.Paddings.LeftPadding := LeftPadding;
Data.Paddings.TopPadding := TopPadding;
Data.Paddings.RightPadding := RightPadding;
Data.Paddings.BottomPadding := BottomPadding;
BandCtl.aAutoSzX := BandCtl.aAutoSzX - WasHPadding + LeftPadding + RightPadding;
if BandCtl.IsAutoSize then
BandCtl.AutoSize( TRUE );
end;
{ TReport }
procedure TReport.Abort;
begin
Clear;
if Assigned( FPrinter ) then
begin
if Printer.Printing then
Printer.Abort;
end;
end;
procedure TReport.AddBand(Band: PControl);
begin
AddBandEx( Band, blLeft );
end;
procedure TReport.AddBandEx(Band: PControl; BandLayout: TBandLayout);
var MF: TMF;
OldW: Integer;
begin
if FCurBandHeight > 0 then
begin
if not fNewBandHandling then
if Assigned( OnEndBand ) then
begin
fNewBandHandling := TRUE;
OnEndBand( @ Self );
fNewBandHandling := FALSE;
end;
FX := MarginsScreenPixels.Left;
FY := FY + FCurBandHeight;
end;
if Band.Height > HeightAvailable then
NewPage;
MF := CurrentPage;
case BandLayout of
blLeft: FY := FY + PaintBand( MF, Band, X, Y );
blRight: FY := FY + PaintBand( MF, Band, PagePixelsSize.cx - Band.Width, Y );
blCenter: FY := FY + PaintBand( MF, Band, (PagePixelsSize.cx - Band.Width) div 2, Y );
blExpandRight: begin
OldW := Band.Width;
try
Band.Width := PagePixelsSize.cx - MarginsScreenPixels.Right - X;
FY := FY + PaintBand( MF, Band, X, Y );
finally
Band.Width := OldW;
end;
end;
end;
FPageTop := FALSE;
FCurBandHeight := 0;
end;
procedure TReport.AddFooter(Band: PControl);
begin
AddFooterEx( Band, blLeft );
end;
procedure TReport.AddFooterEx(Band: PControl; BandLayout: TBandLayout);
var MF: TMF;
OldW: Integer;
begin
if Band.Height > HeightAvailable then
NewPage;
MF := CurrentPage;
case BandLayout of
blLeft: FBottom := FBottom - PaintBand( MF, Band, 0, FBottom - Band.Height );
blRight: FBottom := FBottom - PaintBand( MF, Band,
PagePixelsSize.cx - Band.Width, FBottom - Band.Height );
blCenter: FBottom := FBottom - PaintBand( MF, Band,
(PagePixelsSize.cx - Band.Width) div 2, FBottom - Band.Height );
blExpandRight: begin
OldW := Band.Width;
try
Band.Width := PagePixelsSize.cx -
MarginsScreenPixels.Left - MarginsScreenPixels.Right;
FBottom := FBottom - PaintBand( MF, Band, 0, FBottom - Band.Height );
finally
Band.Width := OldW;
end;
end;
end;
end;
function TReport.AddPage: TMF;
var MF: TMF;
R: TRect;
DC0: HDC;
begin
DC0 := GetDC( 0 );
R := MakeRect( 0, 0,
MulDiv(PagePixelsSize.cx, GetDeviceCaps(DC0, HORZSIZE)*100, GetDeviceCaps(DC0, HORZRES)),
MulDiv(PagePixelsSize.cy, GetDeviceCaps(DC0, VERTSIZE)*100, GetDeviceCaps(DC0, VERTRES)) );
MF := CreateEnhMetaFile( DC0, nil, @ R, '' );
ReleaseDC( 0, DC0 );
FDCPages.Add( Pointer( MF ) );
Result := MF;
FPageTop := TRUE;
FBottom := PagePixelsSize.cy - MarginsScreenPixels.Bottom;
if not fNewPageHandling then
if Assigned( OnNewPage ) then
begin
fNewPageHandling := TRUE;
OnNewPage( @ Self );
fNewPageHandling := FALSE;
end;
end;
procedure TReport.AddRight(Band: PControl);
begin
AddRightEx( Band, blLeft );
end;
procedure TReport.AddRightEx(Band: PControl; BandLayout: TBandLayout);
var MF: TMF;
OldW: Integer;
begin
if Band.Height > HeightAvailable then
NewPage;
MF := CurrentPage;
if Band.Width > PagePixelsSize.cx - MarginsScreenPixels.Right - X then
begin
if not fNewBandHandling then
if Assigned( OnEndBand ) then
begin
fNewBandHandling := TRUE;
OnEndBand( @ Self );
fNewBandHandling := FALSE;
end;
FX := MarginsScreenPixels.Left;
FY := FY + FCurBandHeight;
FCurBandHeight := 0;
end;
case BandLayout of
blLeft: PaintBand( MF, Band, X, Y );
blRight: PaintBand( MF, Band, X + PagePixelsSize.cx - Band.Width, Y );
blCenter: PaintBand( MF, Band, X + (PagePixelsSize.cx - X - Band.Width) div 2, Y );
blExpandRight: begin
OldW := Band.Width;
try
Band.Width := PagePixelsSize.cx - MarginsScreenPixels.Right - X;
PaintBand( MF, Band, X, Y );
finally
Band.Width := OldW;
end;
end;
end;
FX := X + Band.Width;
if FCurBandHeight < Band.Height then
FCurBandHeight := Band.Height;
FPageTop := FALSE;
end;
procedure TReport.Clear;
begin
if FPreviewForm <> nil then
FPreviewForm.Form.Free;
ClearPages;
end;
destructor TReport.Destroy;
begin
Clear;
FDCPages.Free;
FHDPages.Free;
FDocName := '';
inherited;
end;
procedure TReport.DoPreview;
begin
if PageCount = 0 then Exit;
PreviewForm.Form.DoubleBuffered := DoubleBufferedPreview;
PreviewForm.FReport := @ Self;
PreviewForm.Form.Caption := FDocName;
PreviewForm.Form.Show;
end;
procedure TReport.DoPreviewModal;
begin
if PageCount = 0 then Exit;
PreviewForm.Form.DoubleBuffered := DoubleBufferedPreview;
PreviewForm.FReport := @ Self;
PreviewForm.Form.Caption := FDocName;
PreviewForm.Form.ShowModal;
FPreviewForm.Form.Free;
FPreviewForm := nil;
end;
procedure TReport.DoPrint;
begin
PrintPages( 0, PageCount-1 );
end;
procedure TReport.DoPrintPreview(Proc: TObjectMethod);
begin
if Printing then Abort;
if Assigned( FOnPrint ) then
begin
Clear;
FStage := 1;
FOnPrint( @ Self );
if PageCount = 0 then Exit;
Clear;
FStage := 2;
FOnPrint( @ Self );
end;
Proc;
end;
function TReport.GetCurrentPage: TMF;
begin
if PageCount = 0 then
Result := AddPage
else
Result := Pages[ PageCount-1 ];
end;
function TReport.GetOrientation: TPrinterOrientation;
begin
Result := Printer.Orientation;
end;
function TReport.GetPageHeight: Integer;
begin
GetPageWidthHeight;
Result := FPageHeight;
end;
function TReport.GetPagePixelsSize: TSize;
var I: Integer;
P: TPoint;
DC0: HDC;
begin
if (FPagePixelsSize.cx = 0) or (FPagePixelsSize.cy = 0) then
begin
case PaperSize of
psA3: P := MakePoint( 297, 420 );
psA4: P := MakePoint( 210, 297 );
psA5: P := MakePoint( 148, 210 );
psA6: P := MakePoint( 105, 148 );
psLetter: P := MakePoint( 216, 280 );
else P := MakePoint( FCustomPaperSize.cx, FCustomPaperSize.cy );
end;
DC0 := GetDC( 0 );
FPagePixelsSize.cx := Round( (P.x * 0.039370) * GetDeviceCaps( DC0, LOGPIXELSX ) );
FPagePixelsSize.cy := Round( (P.y * 0.039370) * GetDeviceCaps( DC0, LOGPIXELSY ) );
ReleaseDC( 0, DC0 );
end;
Result := FPagePixelsSize;
if Orientation = poLandscape then
begin
I := Result.cx;
Result.cx := Result.cy;
Result.cy := I;
end;
end;
function TReport.GetPageCount: Integer;
begin
Result := FDCPages.Count;
end;
function TReport.GetPageWidth: Integer;
begin
GetPageWidthHeight;
Result := FPageWidth;
end;
procedure TReport.GetPageWidthHeight;
begin
if (FPageWidth <> 0) and (FPageHeight <> 0) then Exit;
if Printer.Printing then
begin
FPageWidth := Printer.PageWidth;
FPageHeight := Printer.PageHeight;
end
else
begin
Printer.BeginDoc;
TRY
FPageWidth := Printer.PageWidth;
FPageHeight := Printer.PageHeight;
FINALLY
Printer.Abort;
END;
end;
end;
function TReport.GetPreviewForm: PPreviewObj;
begin
if FPreviewForm = nil then
begin
NewPreviewForm( FPreviewForm, Applet );
FPreviewForm.FReport := @ Self;
end;
Result := FPreviewForm;
end;
function TReport.GetPrinter: PPrinter;
begin
if FPrinter = nil then
FPrinter := GetProviderPrinter;
Result := FPrinter;
end;
function TReport.HeightAvailable: Integer;
begin
Result := FBottom - FY;
end;
procedure TReport.NewPage;
begin
FY := MarginsScreenPixels.Top;
FX := MarginsScreenPixels.Left;
AddPage;
end;
function TReport.PaintBand(MF: TMF; Band: PControl; Xpos, Ypos: Integer): Integer;
procedure PaintBandWithChildren( Band: PControl; DC: HDC );
var I: Integer;
C: PControl;
P0, P: TPoint;
R0, R1, R2: TRect;
Save: Integer;
FontHeight0Replaced: Boolean;
begin
FontHeight0Replaced := FALSE;
if (ReplaceFontHeight0 <> 0) and (Band.Font.FontHeight = 0) then
begin
FontHeight0Replaced := TRUE;
Band.Font.FontHeight := ReplaceFontHeight0;
end;
Band.Perform( WM_PRINT, DC, PRF_NONCLIENT );
GetClientRect( Band.Handle, R0 );
P0 := MakePoint( 0, 0 );
ClientToScreen( Band.Handle, P0 );
GetWindowOrgEx( DC, P );
GetWindowRect( Band.Handle, R1 );
OffsetRect( R0, P0.x - R1.Left, P0.y - R1.Top );
SetWindowOrgEx( DC, P.x - (P0.x - R1.Left), P.y - (P0.y - R1.Top), @ P );
IntersectClipRect( DC, R0.Left, R0.Top, R0.Right, R0.Bottom );
Band.Perform( WM_ERASEBKGND, DC, 0 );
Band.Perform( WM_PAINT, DC, 0 );
GetWindowRect( Band.Handle, R1 );
for I := 0 to Band.ChildCount-1 do
begin
Save := SaveDC( DC );
C := Band.Children[ I ];
GetWindowRect( C.Handle, R2 );
SetWindowOrgEx( DC, P.x - (R2.Left - R1.Left), P.y - (R2.Top - R1.Top), nil );
IntersectClipRect( DC, 0, 0, R2.Right - R2.Left, R2.Bottom - R2.Top );
PaintBandWithChildren( C, DC );
RestoreDC( DC, Save );
end;
if FontHeight0Replaced then
Band.Font.FontHeight := 0;
end;
var OldParent: PControl;
WasVisible: Boolean;
WasBR: TRect;
P: TPoint;
Save: Integer;
begin
OldParent := Band.Parent;
OldParent.CreateWindow;
WasVisible := Band.Visible;
WasBR := Band.BoundsRect;
try
Band.Visible := FALSE;
Band.Parent := Applet;
Band.Top := Applet.Height;
SetParent( Band.GetWindowHandle, Applet.Handle );
Band.Visible := TRUE;
Save := SaveDC( MF );
GetWindowOrgEx( MF, P );
SetWindowOrgEx( MF, P.x - Xpos, P.y - Ypos, nil );
PaintBandWithChildren( Band, MF );
SetWindowOrgEx( MF, P.x, P.y, nil );
RestoreDC( MF, Save );
finally
Band.Visible := FALSE;
Band.Parent := OldParent;
SetParent( Band.Handle, OldParent.Handle );
Band.BoundsRect := WasBR;
Band.Visible := WasVisible;
end;
Result := Band.Height;
end;
procedure TReport.Preview;
begin
DoPrintPreview( DoPreview );
end;
procedure TReport.PreviewModal;
begin
DoPrintPreview( DoPreviewModal );
end;
procedure TReport.Print;
begin
DoPrintPreview( DoPrint );
end;
function TReport.ScaleX(W: Integer): Integer;
begin
Result := Round( W * Printer.PageWidth / PagePixelsSize.cx );
end;
function TReport.ScaleY(H: Integer): Integer;
begin
Result := Round( H * Printer.PageHeight / PagePixelsSize.cy );
end;
procedure TReport.SetCustomPaperSize(const Value: TSize);
const PapSizes: array[ TPaperSize, 1..2] of Integer = ( ( 210, 297 ),
( 148, 210 ), ( 105, 148 ), ( 297, 420 ), (216, 280), ( 0, 0 ) );
var PSidx: TPaperSize;
begin
FCustomPaperSize := Value;
for PSidx := Low( TPaperSize ) to Pred( High( TPaperSize ) ) do
begin
if (PapSizes[ PSidx ][ 1 ] = Value.cx) and
(PapSizes[ PSidx ][ 2 ] = Value.cy) then
begin
PaperSize := PSidx;
exit;
end;
end;
PaperSize := psCustom;
end;
procedure TReport.SetPageTop(const Value: Boolean);
begin
FPageTop := Value;
end;
procedure TReport.SetPaperSize(const Value: TPaperSize);
begin
if FPaperSize = Value then Exit;
if FPrinting then Abort;
FPaperSize := Value;
end;
procedure TReport.SetPreviewForm(const Value: PPreviewObj);
begin
if FPreviewForm = Value then Exit;
if FPreviewForm <> nil then
FPreviewForm.Form.Free;
FPreviewForm := Value;
end;
procedure TReport.SetPrinter(const Value: PPrinter);
begin
if FPrinter = Value then Exit;
if FPrinting then Abort;
FPrinter := Value;
FPageWidth := 0;
FPageHeight := 0;
end;
procedure TReport.SetX(const Value: Integer);
begin
if FX = Value then Exit;
FX := Value;
end;
procedure TReport.SetY(const Value: Integer);
begin
if FY = Value then Exit;
FY := Value;
FCurBandHeight := 0;
end;
function TReport.GetPages(Idx: Integer): TMF;
begin
Result := TMF( FDCPages.Items[ Idx ] );
end;
function TReport.GetImages(Idx: Integer): HENHMETAFILE;
begin
while FHDPages.Count <= Idx do
FHDPages.Add( nil );
if FHDPages.Items[ Idx ] = nil then
begin
FHDPages.Items[ Idx ] := Pointer( CloseEnhMetafile( Pages[ Idx ] ) );
FDCPages.Items[ Idx ] := nil;
end;
Result := HENHMETAFILE( FHDPages.Items[ Idx ] );
end;
procedure TReport.PrintPages(FromPage, ToPage: Integer);
var I: Integer;
MF: HENHMETAFILE;
PrintingStarted: Boolean;
N: Integer;
begin
PrintingStarted := FALSE;
TRY
for I := FromPage to ToPage do
begin
MF := Images[ I ];
if I = 0 then
begin
Printer.Title := FDocName;
Printer.BeginDoc;
PrintingStarted := TRUE;
end;
N := 1;
while PageWidth > PagePixelsSize.cx * N do
Inc( N );
PlayEnhMetaFile( Printer.Canvas.Handle, MF,
MakeRect( 0, 0, PageWidth-1, PageHeight-1 ) );
if I < ToPage then
Printer.NewPage;
end;
FINALLY
if PrintingStarted then
Printer.EndDoc;
END;
end;
procedure TReport.ClearPages;
var I: Integer;
begin
for I := PageCount-1 downto 0 do
DeleteEnhMetaFile( Images[ I ] );
FDCPages.Clear;
FHDPages.Clear;
FY := MarginsScreenPixels.Top;
FX := MarginsScreenPixels.Left;
FPagePixelsSize.cx := 0; // force recalculation of Page size
end;
procedure TReport.SetMargins(const Value: TMargins);
begin
if (fMargins.Left = Value.Left) and
(fMargins.Top = Value.Top) and
(fMargins.Right = Value.Right) and
(fMargins.Bottom = Value.Bottom) then Exit;
if FPrinting then Abort;
FMargins := Value;
end;
function TReport.GetMarginsPixels( const Index: Integer ): TMargins;
var DC: HDC;
begin
if Index = 1 then DC := Printer.Canvas.Handle
else DC := GetDC( 0 );
Result.Left := Round( Margins.Left / 1000 / 2.55 * GetDeviceCaps( DC, LOGPIXELSX ) );
Result.Right := Round( Margins.Right / 1000 / 2.55 * GetDeviceCaps( DC, LOGPIXELSX ) );
Result.Top := Round( Margins.Top / 1000 / 2.55 * GetDeviceCaps( DC, LOGPIXELSY ) );
Result.Bottom := Round( Margins.Bottom / 1000 / 2.55 * GetDeviceCaps( DC, LOGPIXELSY ) );
if Index <> 1 then
ReleaseDC( 0, DC );
end;
{ TPreviewObj }
procedure TPreviewObj.AdjustButtons( Sender: PObj );
begin
TB.TBButtonEnabled[ TBFrst ] := FCurPage > 0;
TB.TBButtonEnabled[ TBPrev ] := FCurPage > 0;
TB.TBButtonEnabled[ TBNext ] := FCurPage < PageCount - 1;
TB.TBButtonEnabled[ TBLast ] := FCurPage < PageCount - 1;
TB.TBButtonEnabled[ TBPrnt ] := PageCount > 0;
{$IFDEF use_MHPRINTER}
TB.TBButtonEnabled[ TBExit ] := TRUE;
{$ENDIF}
if PageCount = 0 then
LB.Caption := ''
else
LB.Caption := 'Page ' + Int2Str( FCurPage + 1 ) + ' from ' + Int2Str( PageCount );
end;
procedure TPreviewObj.AdjustFitMode;
var K: Double;
begin
if PageCount = 0 then Exit;
case FFitMode of
0: begin // fit Height
PB.Height := SB.ClientHeight;
K := FReport.PagePixelsSize.cx / FReport.PagePixelsSize.cy;
PB.Width := Round( K * SB.ClientHeight );
SetScrollPos( SB.Handle, SB_VERT, 0, TRUE );
end;
1: begin // fit Width
PB.Width := SB.ClientWidth;
K := FReport.PagePixelsSize.cy / FReport.PagePixelsSize.cx;
PB.Height := Round( K * SB.ClientWidth );
end;
2: begin // 1:1
PB.Width := FReport.PagePixelsSize.cx;
PB.Height := FReport.PagePixelsSize.cy;
end;
end;
end;
destructor TPreviewObj.Destroy;
begin
FBuf.Free;
PSD.Free;{Brandys}
inherited;
end;
function TPreviewObj.PageCount: Integer;
begin
Result := FReport.FDCPages.Count;
end;
procedure TPreviewObj.PaintPage(Sender: PControl; DC: HDC);
var MF: HENHMETAFILE;
Tmp: PBitmap;
R: TRect;
begin
if FCurPage >= PageCount then Exit;
MF := FReport.Images[ FCurPage ];
AdjustFitMode;
{if (PB.Width = FReport.PagePixelsSize.cx) and
(PB.Height = FReport.PagePixelsSize.cy) then
PlayEnhMetaFile( DC, MF, MakeRect( 0, 0, PB.Width, PB.Height ) )
else}
begin
if (FBufPage <> FCurPage) or (FBuf = nil) or
(FBuf.Width <> PB.ClientWidth) or (FBuf.Height <> PB.ClientHeight) then
begin
FBuf.Free;
FBufPage := FCurPage;
FBuf := NewDIBBitmap( PB.ClientWidth, PB.ClientHeight, pf24bit );
FBuf.Canvas.Brush.Color := clWhite;
FBuf.Canvas.FillRect( MakeRect( 0, 0, FBuf.Width, FBuf.Height ) );
SetStretchBltMode( FBuf.Canvas.Handle, HALFTONE );
SetBrushOrgEx( FBuf.Canvas.Handle, 0, 0, nil );
{R := MakeRect( FReport.MarginsScreenPixels.Left,
FReport.MarginsScreenPixels.Top,
FBuf.Width-1 - FReport.MarginsScreenPixels.Right,
FBuf.Height-1 - FReport.MarginsScreenPixels.Bottom );}
R := MakeRect( 0, 0, FBuf.Width-1, FBuf.Height-1 );
if FBuf.Width >= FReport.PagePixelsSize.cx then
PlayEnhMetaFile( FBuf.Canvas.Handle, MF, R )
else
begin
Tmp := NewDIBBitmap( FReport.PagePixelsSize.cx, FReport.PagePixelsSize.cy, pf24bit );
Tmp.Canvas.Brush.Color := clWhite;
Tmp.Canvas.FillRect( MakeRect( 0, 0, Tmp.Width, Tmp.Height ) );
PlayEnhMetaFile( Tmp.Canvas.Handle, MF, MakeRect( 0, 0, Tmp.Width-1, Tmp.Height-1 ) );
Inc( R.Right ); Inc( R.Bottom );
Tmp.StretchDraw( FBuf.Canvas.Handle, R );
Tmp.Free;
end;
end;
FBuf.Draw( DC, 0, 0 );
end;
end;
{$IFDEF use_MHPRINTER}
procedure TPreviewObj.PrinterSetup;
begin
ShowMessage( 'Not implementer.' );
end;
{$ELSE}
procedure TPreviewObj.PrinterSetup;
var
Orientation: TPrinterOrientation;
PgSz: TSize;
M: TRect;
begin
Orientation := Printer.Orientation;
PgSz.cx := Printer.PageWidth;
PgSz.cy := Printer.PageHeight;
if not Assigned( FReport.OnPrint ) then
Options := Options - [ psdOrientation ];
if PSD = nil then
PSD := NewPageSetupDialog( Form, Options );
PSD.SetMargins( FReport.FMargins.Left, FReport.FMargins.Top,
FReport.FMargins.Right, FReport.FMargins.Bottom );
if PSD.Execute then
begin
Printer.Assign(PSD.Info);//assign selected options to printer DC
M := PSD.GetMargins;
if Assigned( FReport.OnPrint ) then
if (Printer.Orientation <> Orientation) or
(Printer.PageWidth <> PgSz.cx) or
(Printer.PageHeight <> PgSz.cy) or
not CompareMem( @ M, @ FReport.FMargins, Sizeof( M ) ) then
begin
FReport.FMargins := M;
FCurPage := 0;
FReport.ClearPages;
PgSz.cx := GetDeviceCaps( Printer.Canvas.Handle, HORZSIZE );
PgSz.cy := GetDeviceCaps( Printer.Canvas.Handle, VERTSIZE );
FReport.CustomPaperSize := PgSz;
FReport.OnPrint( FReport );
end;
Printer.AssignMargins(M,mgMillimeters);
end;
end;
{$ENDIF}
procedure TPreviewObj.PrintAllPages;
begin
FReport.DoPrint;
end;
procedure TPreviewObj.ResizePreviewForm(Sender: PObj);
begin
AdjustFitMode;
end;
procedure TPreviewObj.SetCurPage(const Value: Integer);
begin
FCurPage := Value;
AdjustButtons( @ Self );
end;
procedure TPreviewObj.SetFitMode(const Value: Integer);
begin
if FFitMode = Value then Exit;
FFitMode := Value;
AdjustFitMode;
PB.Invalidate;
end;
procedure TPreviewObj.TBClick(Sender: PObj);
begin
case PControl(Sender).CurIndex of
TBFrst: { << } FCurPage := 0;
TBPrev: { < } if FCurPage > 0 then Dec( FCurPage );
TBNext: { > } if FCurPage < PageCount - 1 then Inc( FCurPage );
TBLast: { >> } FCurPage := PageCount - 1;
TBPrnt: {Print} PrintAllPages;
TBSetu: {Setup} PrinterSetup;
TBView: {View} TBDropDownViewMenu( TB );
TBExit: {Close} begin Form.Close; Exit; end;
end;
AdjustButtons( @ Self );
end;
procedure TPreviewObj.TBDropDownViewMenu(Sender: PObj);
var R: TRect;
begin
R := TB.TBButtonRect[ TBView ];
R.Top := R.Bottom;
R.TopLeft := TB.Client2Screen( R.TopLeft );
ViewMenu.RadioCheck( FitMode );
ViewMenu.Popup( R.Left, R.Top );
end;
procedure TPreviewObj.TBViewMenuClick(Sender: PMenu; Item: Integer);
begin
FitMode := Item;
end;
end.
Reference in New Issue View Git Blame Copy Permalink