5583 lines
193 KiB
ObjectPascal
5583 lines
193 KiB
ObjectPascal
/// Reporting unit
|
||
// - this unit is a part of the freeware Synopse framework,
|
||
// licensed under a MPL/GPL/LGPL tri-license; version 1.18
|
||
unit mORMotReport;
|
||
|
||
(*
|
||
This file is part of Synopse framework.
|
||
|
||
Synopse framework. Copyright (C) 2022 Arnaud Bouchez
|
||
Synopse Informatique - https://synopse.info
|
||
|
||
*** BEGIN LICENSE BLOCK *****
|
||
Version: MPL 1.1/GPL 2.0/LGPL 2.1
|
||
|
||
The contents of this file are subject to the Mozilla Public License Version
|
||
1.1 (the "License"); you may not use this file except in compliance with
|
||
the License. You may obtain a copy of the License at
|
||
http://www.mozilla.org/MPL
|
||
|
||
Software distributed under the License is distributed on an "AS IS" basis,
|
||
WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
|
||
for the specific language governing rights and limitations under the License.
|
||
|
||
The Original Code is Synopse framework.
|
||
|
||
The Initial Developer of the Original Code is Angus Johnson.
|
||
|
||
Portions created by the Initial Developer are Copyright (C) 2003
|
||
the Initial Developer. All Rights Reserved.
|
||
Portions created by Arnaud Bouchez for Synopse are Copyright (C) 2022
|
||
Arnaud Bouchez. All Rights Reserved.
|
||
|
||
Contributor(s):
|
||
- Celery
|
||
- Kevinday
|
||
- Leo
|
||
- Mike Lamusse (mogulza)
|
||
|
||
Alternatively, the contents of this file may be used under the terms of
|
||
either the GNU General Public License Version 2 or later (the "GPL"), or
|
||
the GNU Lesser General Public License Version 2.1 or later (the "LGPL"),
|
||
in which case the provisions of the GPL or the LGPL are applicable instead
|
||
of those above. If you wish to allow use of your version of this file only
|
||
under the terms of either the GPL or the LGPL, and not to allow others to
|
||
use your version of this file under the terms of the MPL, indicate your
|
||
decision by deleting the provisions above and replace them with the notice
|
||
and other provisions required by the GPL or the LGPL. If you do not delete
|
||
the provisions above, a recipient may use your version of this file under
|
||
the terms of any one of the MPL, the GPL or the LGPL.
|
||
|
||
***** END LICENSE BLOCK *****
|
||
|
||
|
||
Initial Notes and Copyright:
|
||
******************************
|
||
|
||
Component Name: TPages
|
||
Module: Pages
|
||
Description: Report writer and previewer
|
||
Version: 1.6
|
||
Date: 25-MAY-2004 (initial version)
|
||
Target: Win32, Delphi 3 - Delphi 7
|
||
Author: Angus Johnson, http://www.angusj.com
|
||
Copyright <20> 2003 Angus Johnson
|
||
|
||
Notes:
|
||
* TGDIPages is designed as a simple lightweight report writer. Reports are
|
||
created in code, they are not banded, nor are they directly linked to
|
||
TDatasets. If you're looking for a dataset aware report writer then
|
||
TGDIPages is not for you. TGDIPages is a visual component based on a
|
||
TScrollbox, though it isn't necessary to view reports prior to printing.
|
||
|
||
* Main features include:
|
||
+ Text can be output either wrapped between page margins, in columns
|
||
or at specified offsets.
|
||
+ Multiple alignment options -
|
||
> left, right and justified in non-columned text
|
||
> left, right and currency in columned text
|
||
+ Tabs to Assigned tabstops
|
||
+ Multi-line page headers, footers and column headers
|
||
+ Multiple fonts can be used.
|
||
+ Angled text output
|
||
+ Single, line & half, and double line spacing
|
||
+ Methods for printing bitmaps, metafiles, lines, boxes and arrows
|
||
+ Page numbering can be redefined
|
||
+ Text output 'groups' prevent blocks of text spanning across pages
|
||
+ Designed around a TScrollbox descendant preview window with:
|
||
mouse click zoom control; keyboard handling of lineup, linedown,
|
||
pageup and pagedown srolling; mouse wheel scrolling.
|
||
|
||
* In order to get the best print quality, TGDIPages uses the selected
|
||
printer driver's resolution to prepare reports.
|
||
If a report will be printed to a different printer (eg by using a
|
||
PrintDialog), it's preferable to change to that printer object BEFORE
|
||
preparing the report. Otherwise, the report will be stretch down to the
|
||
printer canvas resulting in a slight degradation in print quality.
|
||
|
||
|
||
Enhanced for the freeware Synopse framework:
|
||
**********************************************
|
||
|
||
- Windows XP, Vista and Seven compatibility adding
|
||
- fix printing metafiles and page groups on some printer (with bad drivers)
|
||
- optionnaly use antialiaised drawing (via SynGdiPlus unit)
|
||
- popup menu creation, with zoom, print or copy features (and custom entries)
|
||
- direct PDF export (if a PDF printer is installed, or via SynPdf unit)
|
||
- direct page export to clipboard as text
|
||
- optional Black and White / Duplex mode (with out TPrinterNew custom class)
|
||
- new useful methods for easy text adding (especially column definition)
|
||
- new fast double buffering drawing
|
||
- full Unicode text process (even before Delphi 2009)
|
||
- speed up and various bug fixes to work with Delphi 5 up to XE3
|
||
|
||
Modifications (c) 2009-2022 Arnaud Bouchez
|
||
|
||
Version 1.4 - February 8, 2010
|
||
- whole Synopse SQLite3 database framework released under the GNU Lesser
|
||
General Public License version 3, instead of generic "Public Domain"
|
||
|
||
Version 1.6
|
||
- new version, using our SynGdiPlus unit: if the GDI+ is available,
|
||
it will use it to render the page using its AntiAliased engine;
|
||
under Windows 98 or 2000, no antialiasing will occur, but the program
|
||
will still run (since our SynGdiPlus unit use dynamic linking of the
|
||
gdiplus.dll library);
|
||
if only GDI+ 1.0 is available (i.e. with a Windows XP without any Office
|
||
2003/2007 installed) a pure Delphi version of GDI+ drawing is used, which
|
||
should not be able to convert 100% of page content, but should work on
|
||
most cases
|
||
|
||
Version 1.8
|
||
- some fixes for compilation under Delphi 2009/2010
|
||
|
||
Version 1.9
|
||
- new AppendRichEdit method to draw RichEdit content
|
||
- new WordWrapLeftCols property used to optionaly word wrap caLeft columns
|
||
into multiple lines, i.e. if the text is wider than the column width, its
|
||
content is wrapped to the next line (set to false by default) - this
|
||
also will handle #13/#10 in column text as a "go to next line" command
|
||
|
||
Version 1.9.2
|
||
- fix font color issue in header and footers
|
||
- safety additional code to avoid any division per 0 exception
|
||
|
||
Version 1.11
|
||
- fixed issue in TGDIPages.AppendRichEdit - see user feedback from
|
||
https://synopse.info/forum/viewtopic.php?pid=671#p671
|
||
- added Author, Subject and Keywords optional parameters to TGDIPages.ExportPDF
|
||
|
||
Version 1.12
|
||
- fixed one issue (in SynGdiPlus) for displaying bitmaps in anti-aliased mode
|
||
and displaying underlined or stroken out text - new ForceInternalAntiAliased
|
||
method (true by default) using SynGdiPlus instead of GDI+ 1.1 native conversion
|
||
- OnStringToUnicodeEvent is now called for all text, whatever the alignment is
|
||
- new property BiDiMode, for formatting the text in right to left order
|
||
- added new DrawBMP overloaded method to add some bitmap as a (centered)
|
||
paragraph, with some optional legend - bitmaps are now cached and reused
|
||
in the exported PDF, if the same one is drawn multiple time in the document
|
||
- added new AddBookMark, AddOutline and AddLink methods (working also with
|
||
the PDF export using SynPdf) :)
|
||
- live navigation via links in the preview screen, and via the new 'Bookmarks'
|
||
popup menu entry
|
||
- additional ExportPDF* properties used during PDF export
|
||
- introducing the new TRenderPages class, for high-quality document rendering
|
||
(used e.g. within SynProject for document preview and PDF generation,
|
||
with basic understanding of the rtf format)
|
||
|
||
Version 1.15
|
||
- fixed an endless loop in TGDIPages.DrawTextAcrossCols when wrapping text
|
||
- fixed an issue in TGDIPages.DrawTextAcrossCols when test is exported to pdf
|
||
(wrong clipping region set)
|
||
- if TGDIPages.WordWrapLeftCols=TRUE, won't wrap column headers
|
||
|
||
Version 1.16
|
||
- includes new TSynAnsiConvert classes for handling Ansi charsets
|
||
- some minor fixes (e.g. preview landscape or keys for popup menu)
|
||
- fix issue in TGDIPages.AppendRichEdit() when called on a blank page
|
||
- enhanced the print preview screen with a left-sided button bar
|
||
- new TGdiPages.RenderGraphic method (accepting both TBitmap and TMetaFile)
|
||
|
||
Version 1.17
|
||
- now whole text process is UNICODE-ready, even on pre-Delphi-2009 versions
|
||
- now implements font fall-back in internal Anti-Aliaised drawing,
|
||
if the new ForceInternalAntiAliasedFontFallBack property is set to TRUE
|
||
|
||
Version 1.18
|
||
- renamed SQLite3Pages.pas to mORMotReport.pas
|
||
- TGdiPages now handles several page layouts per report - see new overloaded
|
||
TGDIPages.NewPageLayout() methods and also Orientation property which now
|
||
allows several page orientations per report - feature request [204b698b3d]
|
||
- now internal page content (TMetaFile) is compressed using our SynLZ
|
||
algorithm: we were able to generate reports with more than 20,000 pages!
|
||
- added optional EndOfPagePositions parameter to TGDIPages.AppendRichEdit()
|
||
- speed up and memory resource decrease for pdf export of huge reports
|
||
- fixed issue about disabled Zoom menu entry if no Outline is defined
|
||
- fixed unexpected exception with TGDIPages.DrawText() and huge string
|
||
- proper function TGDIPages.GetLineHeight() computation - from kln feedback
|
||
- added ExportPDFBackground and ExportPDFGeneratePDF15File properties
|
||
- added ExportPDFEncryptionLevel/User/OwnerPassword/Permissions properties to
|
||
optionally export report as 40 bit or 128 bit encrypted pdf
|
||
- added setter method for ZoomStatus property (during preview) - [dd656b470b]
|
||
- added TGDIPages.ExportPDFStream() method - to be used e.g. on servers
|
||
- fixed [cfdc644038] about truncated parenthesis in pdf export for caCurrency
|
||
- fixed [e7ffb69131] about TGDIPages.DrawGraphic() when the TGraphic is Empty
|
||
- allow preview as a blank colored component at design time (thanks to Celery)
|
||
- added VisibleButtons optional parameter to TGDIPages.ShowPreviewForm method
|
||
as requested by [4d64a52675]
|
||
- added withNewLine optional parameter to DrawText*() methods so that you
|
||
may be able to append some text without creating a new paragraph - from a
|
||
proposal patch by Mike Lamusse (mogulza): thanks for sharing!
|
||
- added TGDIPages.DrawColumnLine method - thanks kevinday for the patch
|
||
|
||
*)
|
||
|
||
interface
|
||
|
||
{.$define MOUSE_CLICK_PERFORM_ZOOM} // old not user-friendly behavior
|
||
{.$define RENDERPAGES} // TRenderBox and TRenderPages are not yet finished
|
||
|
||
{$define GDIPLUSDRAW}
|
||
// optionaly (if ForceNoAntiAliased=false) use GDI+ to draw for antialiasing:
|
||
// slower but smoother (need the GDI+ library, best with version 1.1)
|
||
|
||
{.$define USEPDFPRINTER}
|
||
// do not use the Synopse PDF engine, in Delphi code, but a PDF virtual printer
|
||
|
||
{.$define PRINTERNEW}
|
||
// if our custom Printer.pas unit is installed, use TPrinterNew class instead
|
||
// of TPrinter to allow Black&White and Duplex printing
|
||
// -> disabled by default, should be enabled globaly from the Project Options
|
||
|
||
{$ifndef ENHANCEDRTL}
|
||
{$undef PRINTERNEW}
|
||
// Black&White and Duplex printing are only available with our Enhanced RTL
|
||
{$endif}
|
||
|
||
{$I Synopse.inc} // define HASINLINE CPU32 CPU64 OWNNORMTOUPPER
|
||
|
||
uses
|
||
SynCommons, SynLZ,
|
||
{$ifndef USEPDFPRINTER}
|
||
SynPdf,
|
||
{$endif}
|
||
Windows, Messages, SysUtils, Classes, Contnrs,
|
||
{$ifdef GDIPLUSDRAW}
|
||
SynGdiPlus,
|
||
{$endif}
|
||
Graphics, Controls, Dialogs, Forms, StdCtrls,
|
||
ExtCtrls, WinSpool, Printers, Menus, ShellAPI, RichEdit;
|
||
|
||
const
|
||
MAXCOLS = 20;
|
||
MAXTABS = 20;
|
||
|
||
/// this constant can be used to be replaced by the page number in
|
||
// the middle of any text
|
||
PAGENUMBER = '<<pagenumber>>';
|
||
|
||
type
|
||
|
||
/// text paragraph alignment
|
||
TTextAlign = (taLeft,taRight,taCenter,taJustified);
|
||
|
||
/// text column alignment
|
||
TColAlign = (caLeft,caRight,caCenter, caCurrency);
|
||
|
||
/// text line spacing
|
||
TLineSpacing = (lsSingle, lsOneAndHalf, lsDouble);
|
||
|
||
/// available zoom mode
|
||
// - zsPercent is used with a zoom percentage (e.g. 100% or 50%)
|
||
// - zsPageFit fits the page to the report
|
||
// - zsPageWidth zooms the page to fit the report width on screen
|
||
TZoomStatus = (zsPercent, zsPageFit, zsPageWidth);
|
||
|
||
/// Event triggered when a new page is added
|
||
TNewPageEvent = procedure(Sender: TObject; PageNumber: integer) of object;
|
||
|
||
/// Event triggered when the Zoom was changed
|
||
TZoomChangedEvent = procedure(Sender: TObject;
|
||
Zoom: integer; ZoomStatus: TZoomStatus) of object;
|
||
|
||
/// Event triggered to allow custom unicode character display on the screen
|
||
// - called for all text, whatever the alignment is
|
||
// - Text content can be modified by this event handler to customize
|
||
// some characters (e.g. '>=' can be converted to the one Unicode glyph)
|
||
TOnStringToUnicodeEvent = function(const Text: SynUnicode): SynUnicode of object;
|
||
|
||
/// available known paper size for NewPageLayout() method
|
||
TGdiPagePaperSize = (
|
||
psA4, psA5, psA3, psLetter, psLegal);
|
||
|
||
TGDIPages = class;
|
||
|
||
/// a report layout state, as used by SaveLayout/RestoreSavedLayout methods
|
||
TSavedState = record
|
||
FontName: string;
|
||
FontColor: integer;
|
||
Flags: integer;
|
||
LeftMargin: integer;
|
||
RightMargin: integer;
|
||
BiDiMode: TBiDiMode;
|
||
end;
|
||
|
||
/// internal format of the header or footer text
|
||
THeaderFooter = class
|
||
public
|
||
Text: SynUnicode;
|
||
State: TSavedState;
|
||
/// initialize the header or footer parameters with current report state
|
||
constructor Create(Report: TGDIPages; doubleline: boolean;
|
||
const aText: SynUnicode=''; IsText: boolean=false);
|
||
end;
|
||
|
||
/// internal format of a text column
|
||
TColRec = record
|
||
ColLeft, ColRight: integer;
|
||
ColAlign: TColAlign;
|
||
ColBold: boolean;
|
||
end;
|
||
|
||
TPopupMenuClass = class of TPopupMenu;
|
||
|
||
/// hack the TPaintBox to allow custom background erase
|
||
TPagePaintBox = class(TPaintBox)
|
||
private
|
||
procedure WMEraseBkgnd(var Message: TWmEraseBkgnd); message WM_ERASEBKGND;
|
||
end;
|
||
|
||
/// internal structure used to store bookmarks or links
|
||
TGDIPagereference = class
|
||
public
|
||
/// the associated page number (starting at 1)
|
||
Page: Integer;
|
||
/// graphical coordinates of the hot zone
|
||
// - for bookmarks, Top is the Y position
|
||
// - for links, the TRect will describe the hot region
|
||
// - for Outline, Top is the Y position and Bottom the outline tree level
|
||
Rect: TRect;
|
||
/// coordinates on screen of the hot zone
|
||
Preview: TRect;
|
||
/// initialize the structure with the current page
|
||
constructor Create(PageNumber: integer; Left, Top, Right, Bottom: integer);
|
||
/// compute the coordinates on screen into Preview
|
||
procedure ToPreview(Pages: TGDIPages);
|
||
end;
|
||
|
||
/// contains one page
|
||
TGDIPageContent = record
|
||
/// SynLZ-compressed content of the page
|
||
MetaFileCompressed: RawByteString;
|
||
/// text equivalent of the page
|
||
Text: string;
|
||
/// the physical page size
|
||
SizePx: TPoint;
|
||
/// margin of the page
|
||
MarginPx: TRect;
|
||
/// non printable offset of the page
|
||
OffsetPx: TPoint;
|
||
end;
|
||
|
||
/// used to store all pages of the report
|
||
TGDIPageContentDynArray = array of TGDIPageContent;
|
||
|
||
/// the available menu items
|
||
TGdiPagePreviewButton = (
|
||
rNone, rNextPage, rPreviousPage, rGotoPage, rZoom, rBookmarks,
|
||
rPageAsText, rPrint, rExportPDF, rClose);
|
||
|
||
/// set of menu items
|
||
TGdiPagePreviewButtons = set of TGdiPagePreviewButton;
|
||
|
||
/// Report class for generating documents from code
|
||
// - data is drawn in memory, they displayed or printed as desired
|
||
// - allow preview and printing, and direct pdf export
|
||
// - handle bookmark, outlines and links inside the document
|
||
// - page coordinates are in mm's
|
||
TGDIPages = class(TScrollBox)
|
||
protected
|
||
fPreviewSurface: TPagePaintbox;
|
||
fCanvas: TMetafileCanvas;
|
||
fCanvasText: string;
|
||
fBeforeGroupText: string;
|
||
fGroupPage: TMetafile;
|
||
fPages: TGDIPageContentDynArray;
|
||
fHeaderLines: TObjectList;
|
||
fFooterLines: TObjectList;
|
||
fColumns: array of TColRec;
|
||
fColumnHeaderList: array of record
|
||
headers: TSynUnicodeDynArray;
|
||
flags: integer;
|
||
end;
|
||
{$ifdef MOUSE_CLICK_PERFORM_ZOOM}
|
||
fZoomTimer: TTimer;
|
||
{$endif}
|
||
fPtrHdl: THandle;
|
||
fTabCount: integer;
|
||
fCurrentPrinter: string;
|
||
fOrientation: TPrinterOrientation;
|
||
fDefaultLineWidth: integer; //drawing line width (boxes etc)
|
||
fVirtualPageNum: integer;
|
||
fCurrPreviewPage: integer;
|
||
fZoomIn: boolean;
|
||
fLineHeight: integer; //Text line height
|
||
fLineSpacing: TLineSpacing;
|
||
fCurrentYPos: integer;
|
||
fCurrentTextTop, fCurrentTextPage: integer;
|
||
fHeaderHeight: integer;
|
||
fHangIndent: integer;
|
||
fAlign: TTextAlign;
|
||
fBiDiMode: TBiDiMode;
|
||
fPageMarginsPx: TRect;
|
||
fHasPrinterInstalled: boolean;
|
||
{$ifdef USEPDFPRINTER}
|
||
fHasPDFPrinterInstalled: boolean;
|
||
fPDFPrinterIndex: integer;
|
||
{$else}
|
||
fForceJPEGCompression: Integer;
|
||
fExportPDFApplication: string;
|
||
fExportPDFAuthor: string;
|
||
fExportPDFSubject: string;
|
||
fExportPDFKeywords: string;
|
||
fExportPDFEmbeddedTTF: boolean;
|
||
fExportPDFA1: boolean;
|
||
fExportPDFBackground: TGraphic;
|
||
{$ifndef NO_USE_UNISCRIBE}
|
||
fExportPDFUseUniscribe: boolean;
|
||
{$endif}
|
||
fExportPDFUseFontFallBack: boolean;
|
||
fExportPDFFontFallBackName: string;
|
||
fExportPDFEncryptionLevel: TPdfEncryptionLevel;
|
||
fExportPDFEncryptionUserPassword: string;
|
||
fExportPDFEncryptionOwnerPassword: string;
|
||
fExportPDFEncryptionPermissions: TPdfEncryptionPermissions;
|
||
fExportPDFGeneratePDF15File: boolean;
|
||
{$endif}
|
||
fPrinterPxPerInch: TPoint;
|
||
fPhysicalSizePx: TPoint; //size of page in printer pixels
|
||
fPhysicalOffsetPx: TPoint; //size of non-printing margins in pixels
|
||
fCustomPxPerInch: TPoint;
|
||
fCustomPageSize: TPoint;
|
||
fCustomNonPrintableOffset: TPoint;
|
||
fCustomPageMargins: TRect;
|
||
fZoom: integer;
|
||
fZoomStatus: TZoomStatus;
|
||
fNegsToParenthesesInCurrCols: boolean;
|
||
fWordWrapLeftCols: boolean;
|
||
fUseOutlines: boolean;
|
||
fForceScreenResolution: boolean;
|
||
fHeaderDone: boolean;
|
||
fFooterHeight: integer;
|
||
fFooterGap: integer;
|
||
fInHeaderOrFooter: boolean;
|
||
fColumnHeaderPrinted: boolean;
|
||
fColumnHeaderPrintedAtLeastOnce: boolean;
|
||
fDrawTextAcrossColsDrawingHeader: boolean;
|
||
fColumnHeaderInGroup: boolean;
|
||
fColumnsUsedInGroup: boolean;
|
||
fGroupVerticalSpace: integer;
|
||
fGroupVerticalPos: integer;
|
||
fZoomChangedEvent: TZoomChangedEvent;
|
||
fPreviewPageChangedEvent: TNotifyEvent;
|
||
fStartNewPage: TNewPageEvent;
|
||
fStartPageHeader: TNotifyEvent;
|
||
fEndPageHeader: TNotifyEvent;
|
||
fStartPageFooter: TNotifyEvent;
|
||
fEndPageFooter: TNotifyEvent;
|
||
fStartColumnHeader: TNotifyEvent;
|
||
fEndColumnHeader: TNotifyEvent;
|
||
fSavedCount: integer;
|
||
fSaved: array of TSavedState;
|
||
fTab: array of integer;
|
||
fColumnsWithBottomGrayLine: boolean;
|
||
fColumnsRowLineHeight: integer;
|
||
fOnDocumentProducedEvent: TNotifyEvent;
|
||
PageRightButton, PageLeftButton: TPoint;
|
||
fPagesToFooterText: string; // not SynUnicode, since calls format()
|
||
fPagesToFooterAt: TPoint;
|
||
fPagesToFooterState: TSavedState;
|
||
fMetaFileForPage: TMetaFile;
|
||
fCurrentMetaFile: TMetaFile;
|
||
|
||
procedure GetPrinterParams;
|
||
procedure SetAnyCustomPagePx;
|
||
function GetPaperSize: TSize;
|
||
procedure FlushPageContent;
|
||
function PrinterPxToScreenPxX(PrinterPx: integer): integer;
|
||
function PrinterPxToScreenPxY(PrinterPx: integer): integer;
|
||
procedure ResizeAndCenterPaintbox;
|
||
function GetMetaFileForPage(PageIndex: integer): TMetaFile;
|
||
procedure SetMetaFileForPage(PageIndex: integer; MetaFile: TMetaFile);
|
||
|
||
function GetOrientation: TPrinterOrientation;
|
||
procedure SetOrientation(orientation: TPrinterOrientation);
|
||
procedure SetTextAlign(Value: TTextAlign);
|
||
procedure SetPage(NewPreviewPage: integer);
|
||
function GetPageCount: integer;
|
||
function GetLineHeight: integer;
|
||
function GetLineHeightMm: integer;
|
||
procedure CheckYPos; //ie: if not vertical room force new page
|
||
function GetYPos: integer;
|
||
procedure SetYPos(YPos: integer);
|
||
procedure NewPageInternal; virtual;
|
||
function CreateMetaFile(aWidth, aHeight: integer): TMetaFile;
|
||
function CreateMetafileCanvas(Page: TMetafile): TMetafileCanvas;
|
||
procedure UpdateMetafileCanvasFont(aCanvas: TMetafileCanvas);
|
||
function TextFormatsToFlags: integer;
|
||
procedure SetFontWithFlags(flags: integer);
|
||
function GetPageMargins: TRect;
|
||
procedure SetPageMargins(Rect: TRect);
|
||
|
||
procedure DoHeader;
|
||
procedure DoFooter;
|
||
procedure DoHeaderFooterInternal(Lines: TObjectList);
|
||
procedure CalcFooterGap;
|
||
|
||
function GetColumnCount: integer;
|
||
function GetColumnRec(col: integer): TColRec;
|
||
procedure PrintColumnHeaders;
|
||
|
||
procedure SetZoom(zoom: integer);
|
||
procedure SetZoomStatus(aZoomStatus: TZoomStatus);
|
||
procedure ZoomTimerInternal(X,Y: integer; ZoomIn: boolean);
|
||
procedure ZoomTimer(Sender: TObject);
|
||
|
||
procedure LineInternal(start, finish : integer; doubleline : boolean); overload;
|
||
procedure LineInternal(aty, start, finish : integer; doubleline : boolean); overload;
|
||
procedure PrintFormattedLine(s: SynUnicode; flags: integer;
|
||
const aBookmark: string=''; const aLink: string=''; withNewLine: boolean=true;
|
||
aLinkNoBorder: boolean=false);
|
||
procedure LeftOrJustifiedWrap(const s: SynUnicode; withNewLine: boolean=true);
|
||
procedure RightOrCenterWrap(const s: SynUnicode);
|
||
procedure GetTextLimitsPx(var LeftOffset, RightOffset: integer);
|
||
procedure HandleTabsAndPrint(const leftstring: SynUnicode;
|
||
var rightstring: SynUnicode; leftOffset, rightOffset: integer);
|
||
procedure PreviewPaint(Sender: TObject);
|
||
procedure PreviewMouseDown(Sender: TObject; Button: TMouseButton;
|
||
Shift: TShiftState; X, Y: Integer);
|
||
procedure PreviewMouseUp(Sender: TObject; Button: TMouseButton;
|
||
Shift: TShiftState; X, Y: Integer);
|
||
procedure PreviewMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
|
||
function GetLeftMargin: integer;
|
||
procedure SetLeftMargin(const Value: integer);
|
||
function GetRightMarginPos: integer;
|
||
function GetSavedState: TSavedState;
|
||
procedure SetSavedState(const SavedState: TSavedState);
|
||
/// can be used internaly (for instance by fPagesToFooterState)
|
||
property SavedState: TSavedState read GetSavedState write SetSavedState;
|
||
protected
|
||
fMousePos: TPoint;
|
||
{$ifndef MOUSE_CLICK_PERFORM_ZOOM}
|
||
fButtonDown, fButtonDownScroll: TPoint;
|
||
{$endif}
|
||
/// Strings[] are the bookmark names, and Objects[] are TGDIPagereference
|
||
// to get the Y position
|
||
fBookmarks: TStringList;
|
||
/// Strings[] are the bookmark names, and Objects[] are TGDIPagereference to
|
||
// get the hot region
|
||
fLinks: TStringList;
|
||
fLinksCurrent: integer;
|
||
/// Strings[] are the outline titles, and Objects[] are TGDIPagereference
|
||
// to get the Y position of the destination
|
||
fOutline: TStringList;
|
||
fInternalUnicodeString: SynUnicode;
|
||
fForcedLeftOffset : integer;
|
||
PreviewForm: TForm;
|
||
PreviewButtons: array of TButton;
|
||
PreviewPageCountLabel: TLabel;
|
||
procedure CMFontChanged(var Msg: TMessage); message CM_FONTCHANGED;
|
||
procedure WMGetDlgCode(var Message: TWMGetDlgCode); message WM_GETDLGCODE;
|
||
procedure WMEraseBkgnd(var Message: TWmEraseBkgnd); message WM_ERASEBKGND;
|
||
procedure KeyDown(var Key: Word; Shift: TShiftState); override;
|
||
procedure CreateWnd; override;
|
||
procedure Resize; override;
|
||
procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
|
||
procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
|
||
{$IFNDEF VER100}
|
||
function DoMouseWheel(Shift: TShiftState; WheelDelta: Integer;
|
||
MousePos: TPoint): Boolean; override; //no mousewheel support in Delphi 3
|
||
{$ENDIF}
|
||
procedure PopupMenuPopup(Sender: TObject);
|
||
procedure CheckHeaderDone; virtual;
|
||
// warning: PW buffer is overwritten at the next method call
|
||
procedure InternalUnicodeString(const s: SynUnicode;
|
||
var PW: PWideChar; var PWLen: integer; size: PSize);
|
||
public
|
||
/// Event triggered when the ReportPopupMenu is displayed
|
||
// - default handling (i.e. leave this field nil) is to add Page naviguation
|
||
// - you can override this method for adding items to the ReportPopupMenu
|
||
OnPopupMenuPopup: TNotifyEvent;
|
||
/// Event triggered when a ReportPopupMenu item is selected
|
||
// - default handling (i.e. leave this field nil) is for Page navigation
|
||
// - you can override this method for handling additionnal items to the menu
|
||
// - the Tag component of the custom TMenuItem should be 0 or greater than
|
||
// Report pages count: use 1000 as a start for custom TMenuItem.Tag values
|
||
OnPopupMenuClick: TNotifyEvent;
|
||
/// user can customize this class to create an advanced popup menu instance
|
||
PopupMenuClass: TPopupMenuClass;
|
||
/// the title of the report
|
||
// - used for the preview caption form
|
||
// - used for the printing document name
|
||
Caption: string;
|
||
/// if true, the PrintPages() method will use a temporary bitmap for printing
|
||
// - some printer device drivers have problems with printing metafiles
|
||
// which contains other metafiles; should have been fixed
|
||
// - not useful, since slows the printing a lot and makes huge memory usage
|
||
ForcePrintAsBitmap: boolean;
|
||
/// if true the preview will not use GDI+ library to draw anti-aliaised graphics
|
||
// - this may be slow on old computers, so caller can disable it on demand
|
||
ForceNoAntiAliased: boolean;
|
||
/// if true, drawing will NOT to use native GDI+ 1.1 conversion
|
||
// - we found out that GDI+ 1.1 was not as good as our internal conversion
|
||
// function written in Delphi, e.g. for underlined fonts
|
||
// - so this property is set to true by default for proper display on screen
|
||
// - will only be used if ForceNoAntiAliased is false, of course
|
||
ForceInternalAntiAliased: boolean;
|
||
/// if true, internal text drawing will use a font-fallback mechanism
|
||
// for characters not existing within the current font (just as with GDI)
|
||
// - is disabled by default, but could be set to TRUE to force enabling
|
||
// TGDIPlusFull.ForceUseDrawString property
|
||
ForceInternalAntiAliasedFontFallBack: boolean;
|
||
|
||
{$ifdef PRINTERNEW}
|
||
// the PrintPages() will use this parameter to force black and white, or
|
||
// color mode, whatever the global printer setting is
|
||
ForcePrintColorMode: (printColorDefault, printBW, printColor);
|
||
// the PrintPages() will use this parameter to force duplex mode,
|
||
// whatever the global printer setting is
|
||
ForcePrintDuplexMode: (printDuplexDefault, printSimplex, printDuplex);
|
||
{$endif}
|
||
/// if true, the headers are copied only once to the text
|
||
ForceCopyTextAsWholeContent: boolean;
|
||
/// customize text conversion before drawing
|
||
// - Text content can be modified by this event handler to customize
|
||
// some characters (e.g. '>=' can be converted to its Unicode glyph)
|
||
OnStringToUnicode: TOnStringToUnicodeEvent;
|
||
/// set group page fill method
|
||
// - if set to true, the groups will be forced to be placed on the same page
|
||
// (this was the original default "Pages" component behavior, but this
|
||
// is not usual in page composition, so is disabled by default in TGDIPages)
|
||
// - if set to false, the groups will force a page feed if there is not
|
||
// enough place for 20 lines on the current page (default behavior)
|
||
GroupsMustBeOnSamePage: boolean;
|
||
/// the bitmap used to draw the page
|
||
PreviewSurfaceBitmap: TBitmap;
|
||
|
||
/// creates the reporting component
|
||
constructor Create(AOwner: TComponent); override;
|
||
/// finalize the component, releasing all used memory
|
||
destructor Destroy; override;
|
||
/// customized invalidate
|
||
procedure Invalidate; override;
|
||
|
||
/// Begin a Report document
|
||
// - Every report must start with BeginDoc and end with EndDoc
|
||
// - note that Printers.SetPrinter() should be set BEFORE calling BeginDoc,
|
||
// otherwise you may have a "canvas does not allow drawing" error
|
||
procedure BeginDoc;
|
||
/// Clear the current Report document
|
||
procedure Clear; virtual;
|
||
/// draw some text as a paragraph, with the current alignment
|
||
// - this method does all word-wrapping and formating if necessary
|
||
// - this method handle multiple paragraphs inside s (separated by newlines -
|
||
// i.e. #13)
|
||
// - by default, will write a paragraph, unless withNewLine is set to FALSE,
|
||
// so that the next DrawText() will continue drawing at the current position
|
||
procedure DrawText(const s: string; withNewLine: boolean=true);
|
||
{$ifdef HASINLINE}inline;{$endif}
|
||
/// draw some UTF-8 text as a paragraph, with the current alignment
|
||
// - this method does all word-wrapping and formating if necessary
|
||
// - this method handle multiple paragraphs inside s (separated by newlines -
|
||
// i.e. #13)
|
||
// - by default, will write a paragraph, unless withNewLine is set to FALSE,
|
||
// so that the next DrawText() will continue drawing at the current position
|
||
procedure DrawTextU(const s: RawUTF8; withNewLine: boolean=true);
|
||
{$ifdef HASINLINE}inline;{$endif}
|
||
/// draw some Unicode text as a paragraph, with the current alignment
|
||
// - this method does all word-wrapping and formating if necessary
|
||
// - this method handle multiple paragraphs inside s (separated by newlines -
|
||
// i.e. #13)
|
||
// - by default, will write a paragraph, unless withNewLine is set to FALSE,
|
||
// so that the next DrawText() will continue drawing at the current position
|
||
procedure DrawTextW(const s: SynUnicode; withNewLine: boolean=true);
|
||
/// draw some text as a paragraph, with the current alignment
|
||
// - this method use format() like parameterss
|
||
procedure DrawTextFmt(const s: string; const Args: array of const;
|
||
withNewLine: boolean=true);
|
||
/// get the formating flags associated to a Title
|
||
function TitleFlags: integer;
|
||
/// draw some text as a paragraph title
|
||
// - the outline level can be specified, if UseOutline property is enabled
|
||
// - if aBookmark is set, a bookmark is created at this position
|
||
// - if aLink is set, a link to the specified bookmark name (in aLink) is made
|
||
procedure DrawTitle(const s: SynUnicode; DrawBottomLine: boolean=false; OutlineLevel: Integer=0;
|
||
const aBookmark: string=''; const aLink: string=''; aLinkNoBorder: boolean=false);
|
||
/// draw one line of text, with the current alignment
|
||
procedure DrawTextAt(s: SynUnicode; XPos: integer; const aLink: string='';
|
||
CheckPageNumber: boolean=false; aLinkNoBorder: boolean=false);
|
||
/// draw one line of text, with a specified Angle and X Position
|
||
procedure DrawAngledTextAt(const s: SynUnicode; XPos, Angle: integer);
|
||
/// draw a square box at the given coordinates
|
||
procedure DrawBox(left,top,right,bottom: integer);
|
||
/// draw a filled square box at the given coordinates
|
||
procedure DrawBoxFilled(left,top,right,bottom: integer; Color: TColor);
|
||
/// Stretch draws a bitmap image at the specified page coordinates in mm's
|
||
procedure DrawBMP(rec: TRect; bmp: TBitmap); overload;
|
||
/// add the bitmap at the specified X position
|
||
// - if there is not enough place to draw the bitmap, go to next page
|
||
// - then the current Y position is updated
|
||
// - bLeft (in mm) is calculated in reference to the LeftMargin position
|
||
// - if bLeft is maxInt, the bitmap is centered to the page width
|
||
// - bitmap is stretched (keeping aspect ratio) for the resulting width to
|
||
// match the bWidth parameter (in mm)
|
||
procedure DrawBMP(bmp: TBitmap; bLeft, bWidth: integer; const Legend: string=''); overload;
|
||
/// Stretch draws a metafile image at the specified page coordinates in mm's
|
||
procedure DrawMeta(rec: TRect; meta: TMetafile);
|
||
/// add the graphic (bitmap or metafile) at the specified X position
|
||
// - handle only TBitmap and TMetafile kind of TGraphic
|
||
// - if there is not enough place to draw the bitmap, go to next page
|
||
// - then the current Y position is updated
|
||
// - bLeft (in mm) is calculated in reference to the LeftMargin position
|
||
// - if bLeft is maxInt, the bitmap is centered to the page width
|
||
// - bitmap is stretched (keeping aspect ratio) for the resulting width to
|
||
// match the bWidth parameter (in mm)
|
||
procedure DrawGraphic(graph: TGraphic; bLeft, bWidth: integer; const Legend: SynUnicode='');
|
||
/// draw an Arrow
|
||
procedure DrawArrow(Point1, Point2: TPoint; HeadSize: integer; SolidHead: boolean);
|
||
/// draw a Line, either simple or double, between the left & right margins
|
||
procedure DrawLine(doubleline: boolean=false);
|
||
/// draw a Dashed Line between the left & right margins
|
||
procedure DrawDashedLine;
|
||
/// draw a Line, following a column layout
|
||
procedure DrawColumnLine(ColIndex: integer; aAtTop: boolean;
|
||
aDoDoubleLine: boolean);
|
||
/// append a Rich Edit content to the current report
|
||
// - note that if you want the TRichEdit component to handle more than 64 KB
|
||
// of RTF content, you have to set its MaxLength property as expected (this
|
||
// is a limitation of the VCL, not of this method)
|
||
// - you can specify optionally a pointer to a TIntegerDynArray variable,
|
||
// which will be filled with the position of each page last char: it may
|
||
// be handy e.g. to add some cross-reference table about the rendered content
|
||
procedure AppendRichEdit(RichEditHandle: HWnd; EndOfPagePositions: PIntegerDynArray=nil);
|
||
/// jump some line space between paragraphs
|
||
// - Increments the current Y Position the equivalent of a single line
|
||
// relative to the current font height and line spacing
|
||
procedure NewLine;
|
||
/// jump some half line space between paragraphs
|
||
// - Increments the current Y Position the equivalent of an half single line
|
||
// relative to the current font height and line spacing
|
||
procedure NewHalfLine;
|
||
/// jump some line space between paragraphs
|
||
// - Increments the current Y Position the equivalent of 'count' lines
|
||
// relative to the current font height and line spacing
|
||
procedure NewLines(count: integer);
|
||
/// save the current font and alignment
|
||
procedure SaveLayout; virtual;
|
||
/// restore last saved font and alignment
|
||
procedure RestoreSavedLayout; virtual;
|
||
/// jump to next page, i.e. force a page break
|
||
procedure NewPage(ForceEndGroup: boolean=false);
|
||
/// jump to next page, but only if some content is pending
|
||
procedure NewPageIfAnyContent;
|
||
/// change the page layout for the upcoming page
|
||
// - will then force a page break by a call to NewPage(true) method
|
||
// - can change the default margin if margin*>=0
|
||
// - can change the default non-printable printer margin if nonPrintable*>=0
|
||
procedure NewPageLayout(sizeWidthMM, sizeHeightMM: integer;
|
||
nonPrintableWidthMM: integer=-1; nonPrintableHeightMM: integer=-1); overload;
|
||
/// change the page layout for the upcoming page
|
||
// - will then force a page break by a call to NewPage(true) method
|
||
// - can change the default margin if margin*>=0
|
||
// - can change the default non-printable printer margin if nonPrintable*>=0
|
||
procedure NewPageLayout(paperSize: TGdiPagePaperSize;
|
||
orientation: TPrinterOrientation=poPortrait;
|
||
nonPrintableWidthMM: integer=-1; nonPrintableHeightMM: integer=-1); overload;
|
||
/// begin a Group: stops the contents from being split across pages
|
||
// - BeginGroup-EndGroup text blocks can't be nested
|
||
procedure BeginGroup;
|
||
/// end a previously defined Group
|
||
// - BeginGroup-EndGroup text blocks can't be nested
|
||
procedure EndGroup;
|
||
/// End the Report document
|
||
// - Every report must start with BeginDoc and end with EndDoc
|
||
procedure EndDoc;
|
||
/// Print the selected pages to the default printer of Printer unit
|
||
// - if PrintFrom=0 and PrintTo=0, then all pages are printed
|
||
// - if PrintFrom=-1 or PrintTo=-1, then a printer dialog is displayed
|
||
function PrintPages(PrintFrom, PrintTo: integer): boolean;
|
||
/// export the current report as PDF file
|
||
{$ifdef USEPDFPRINTER}
|
||
// - uses an external 'PDF' printer
|
||
{$else}
|
||
// - uses internal PDF code, from Synopse PDF engine (handle bookmarks,
|
||
// outline and twin bitmaps) - in this case, a file name can be set
|
||
{$endif}
|
||
function ExportPDF(aPdfFileName: TFileName; ShowErrorOnScreen: boolean;
|
||
LaunchAfter: boolean=true): boolean;
|
||
{$ifndef USEPDFPRINTER}
|
||
/// export the current report as PDF in a specified stream
|
||
// - uses internal PDF code, from Synopse PDF engine (handle bookmarks,
|
||
// outline and twin bitmaps) - in this case, a file name can be set
|
||
function ExportPDFStream(aDest: TStream): boolean;
|
||
{$endif}
|
||
/// show a form with the preview, allowing the user to browse pages and
|
||
// print the report
|
||
// - you can customize the buttons and popup menu actions displayed on
|
||
// the screen - by default, all buttons are visible
|
||
procedure ShowPreviewForm(VisibleButtons: TGdiPagePreviewButtons =
|
||
[rNextPage..High(TGdiPagePreviewButton)]);
|
||
|
||
/// set the Tabs stops on every line
|
||
// - if one value is provided, it will set the Tabs as every multiple of it
|
||
// - if more than one value are provided, they will be the exact Tabs positions
|
||
procedure SetTabStops(const tabs: array of integer);
|
||
/// returns true if there is enough space in the current Report for Count lines
|
||
// - Used to check if there's sufficient vertical space remaining on the page
|
||
// for the specified number of lines based on the current Y position
|
||
function HasSpaceForLines(Count: integer): boolean;
|
||
/// returns true if there is enough space in the current Report for a
|
||
// vertical size, specified in mm
|
||
function HasSpaceFor(mm: integer): boolean;
|
||
|
||
/// Clear all already predefined Headers
|
||
procedure ClearHeaders;
|
||
/// Adds either a single line or a double line (drawn between the left &
|
||
// right page margins) to the page header
|
||
procedure AddLineToHeader(doubleline: boolean);
|
||
/// Adds text using to current font and alignment to the page header
|
||
procedure AddTextToHeader(const s: SynUnicode);
|
||
/// Adds text to the page header at the specified horizontal position and
|
||
// using to current font.
|
||
// - No Line feed will be triggered: this method doesn't increment the YPos,
|
||
// so can be used to add multiple text on the same line
|
||
// - if XPos=-1, will put the text at the current right margin
|
||
procedure AddTextToHeaderAt(const s: SynUnicode; XPos: integer);
|
||
|
||
/// Clear all already predefined Footers
|
||
procedure ClearFooters;
|
||
/// Adds either a single line or a double line (drawn between the left &
|
||
// right page margins) to the page footer
|
||
procedure AddLineToFooter(doubleline: boolean);
|
||
/// Adds text using to current font and alignment to the page footer
|
||
procedure AddTextToFooter(const s: SynUnicode);
|
||
/// Adds text to the page footer at the specified horizontal position and
|
||
// using to current font. No Line feed will be triggered.
|
||
// - if XPos=-1, will put the text at the current right margin
|
||
procedure AddTextToFooterAt(const s: SynUnicode; XPos: integer);
|
||
/// Will add the current 'Page n/n' text at the specified position
|
||
// - PageText must be of format 'Page %d/%d', in the desired language
|
||
// - if XPos=-1, will put the text at the current right margin
|
||
// - if the vertical position does not fit your need, you could set
|
||
// YPosMultiplier to a value which will be multipled by fFooterHeight to
|
||
// compute the YPos
|
||
procedure AddPagesToFooterAt(const PageText: string; XPos: integer;
|
||
YPosMultiplier: integer=1);
|
||
|
||
/// register a column, with proper alignment
|
||
procedure AddColumn(left, right: integer; align: TColAlign; bold: boolean);
|
||
/// register same alignement columns, with percentage of page column width
|
||
// - sum of all percent width should be 100, but can be of any value
|
||
// - negative widths are converted into absolute values, but
|
||
// corresponding alignment is set to right
|
||
// - if a column need to be right aligned or currency aligned,
|
||
// use SetColumnAlign() method below
|
||
// - individual column may be printed in bold with SetColumnBold() method
|
||
procedure AddColumns(const PercentWidth: array of integer; align: TColAlign=caLeft);
|
||
/// register some column headers, with the current font formating
|
||
// - Column headers will appear just above the first text output in
|
||
// columns on each page
|
||
// - you can call this method several times in order to have diverse
|
||
// font formats across the column headers
|
||
procedure AddColumnHeaders(const headers: array of SynUnicode;
|
||
WithBottomGrayLine: boolean=false; BoldFont: boolean=false;
|
||
RowLineHeight: integer=0; flags: integer=0);
|
||
/// register some column headers, with the current font formating
|
||
// - Column headers will appear just above the first text output in
|
||
// columns on each page
|
||
// - call this method once with all columns text as CSV
|
||
procedure AddColumnHeadersFromCSV(var CSV: PWideChar;
|
||
WithBottomGrayLine: boolean; BoldFont: boolean=false; RowLineHeight: integer=0);
|
||
/// draw some text, split across every columns
|
||
// - if BackgroundColor is not clNone (i.e. clRed or clNavy or clBlack), the
|
||
// row is printed on white with this background color (e.g. to highlight errors)
|
||
procedure DrawTextAcrossCols(const StringArray: array of SynUnicode;
|
||
BackgroundColor: TColor=clNone); overload;
|
||
/// draw some text, split across every columns
|
||
// - you can specify an optional bookmark name to be used to link a column
|
||
// content via a AddLink() call
|
||
// - if BackgroundColor is not clNone (i.e. clRed or clNavy or clBlack), the
|
||
// row is printed on white with this background color (e.g. to highlight errors)
|
||
procedure DrawTextAcrossCols(const StringArray, LinkArray: array of SynUnicode;
|
||
BackgroundColor: TColor=clNone); overload;
|
||
/// draw some text, split across every columns
|
||
// - this method expect the text to be separated by commas
|
||
// - if BackgroundColor is not clNone (i.e. clRed or clNavy or clBlack), the
|
||
// row is printed on white with this background color (e.g. to highlight errors)
|
||
procedure DrawTextAcrossColsFromCSV(var CSV: PWideChar; BackgroundColor: TColor=clNone);
|
||
/// draw (double if specified) lines at the bottom of all currency columns
|
||
procedure DrawLinesInCurrencyCols(doublelines: boolean);
|
||
|
||
/// retrieve the current Column count
|
||
property ColumnCount: integer read GetColumnCount;
|
||
/// retrieve the attributes of a specified column
|
||
function GetColumnInfo(index: integer): TColRec;
|
||
/// individually set column alignment
|
||
// - useful after habing used AddColumns([]) method e.g.
|
||
procedure SetColumnAlign(index: integer; align: TColAlign);
|
||
/// individually set column bold state
|
||
// - useful after habing used AddColumns([]) method e.g.
|
||
procedure SetColumnBold(index: integer);
|
||
/// erase all columns and the associated headers
|
||
procedure ClearColumns;
|
||
/// clear the Headers associated to the Columns
|
||
procedure ClearColumnHeaders;
|
||
/// ColumnHeadersNeeded will force column headers to be drawn again just
|
||
// prior to printing the next row of columned text
|
||
// - Usually column headers are drawn once per page just above the first
|
||
// column. ColumnHeadersNeeded is useful where columns of text have been
|
||
// separated by a number of lines of non-columned text
|
||
procedure ColumnHeadersNeeded;
|
||
|
||
/// create a bookmark entry at the current position of the current page
|
||
// - return false if this bookmark name was already existing, true on success
|
||
// - if aYPosition is not 0, the current Y position will be used
|
||
function AddBookMark(const aBookmarkName: string; aYPosition: integer=0): Boolean; virtual;
|
||
/// go to the specified bookmark
|
||
// - returns true if the bookmark name was existing and reached
|
||
function GotoBookmark(const aBookmarkName: string): Boolean; virtual;
|
||
/// create an outline entry at the current position of the current page
|
||
// - if aYPosition is not 0, the current Y position will be used
|
||
procedure AddOutline(const aTitle: string; aLevel: Integer;
|
||
aYPosition: integer=0; aPageNumber: integer=0); virtual;
|
||
/// create a link entry at the specified coordinates of the current page
|
||
// - coordinates are specified in mm
|
||
// - the bookmark name is not checked by this method: a bookmark can be
|
||
// linked before being marked in the document
|
||
procedure AddLink(const aBookmarkName: string; aRect: TRect;
|
||
aPageNumber: integer=0; aNoBorder: boolean=false); virtual;
|
||
|
||
/// convert a rect of mm into pixel canvas units
|
||
function MmToPrinter(const R: TRect): TRect;
|
||
/// convert a rect of pixel canvas units into mm
|
||
function PrinterToMM(const R: TRect): TRect;
|
||
/// convert a mm X position into pixel canvas units
|
||
function MmToPrinterPxX(mm: integer): integer;
|
||
/// convert a mm Y position into pixel canvas units
|
||
function MmToPrinterPxY(mm: integer): integer;
|
||
/// convert a pixel canvas X position into mm
|
||
function PrinterPxToMmX(px: integer): integer;
|
||
/// convert a pixel canvas Y position into mm
|
||
function PrinterPxToMmY(px: integer): integer;
|
||
/// return the width of the specified text, in mm
|
||
function TextWidth(const Text: SynUnicode): integer;
|
||
/// the current Text Alignment, during text adding
|
||
property TextAlign: TTextAlign read fAlign write SetTextAlign;
|
||
/// specifies the reading order (bidirectional mode) of the box
|
||
// - only bdLeftToRight and bdRightToLeft are handled
|
||
// - this will be used by DrawText[At], DrawTitle, AddTextToHeader/Footer[At],
|
||
// DrawTextAcrossCols, SaveLayout/RestoreSavedLayout methods
|
||
property BiDiMode: TBiDiMode read fBiDiMode write fBiDiMode;
|
||
/// create a meta file and its associated canvas for displaying a picture
|
||
// - you must release manually both Objects after usage
|
||
function CreatePictureMetaFile(Width, Height: integer;
|
||
out MetaCanvas: TCanvas): TMetaFile;
|
||
/// Distance (in mm's) from the top of the page to the top of the current group
|
||
// - returns CurrentYPos if no group is in use
|
||
function CurrentGroupPosStart: integer;
|
||
/// go to the specified Y position on a given page
|
||
// - used e.g. by GotoBookmark() method
|
||
procedure GotoPosition(aPage: integer; aYPos: integer);
|
||
/// access to all pages content
|
||
// - numerotation begin with Pages[0] for page 1
|
||
// - the Pages[] property should be rarely needed
|
||
property Pages: TGDIPageContentDynArray read fPages;
|
||
/// add an item to the popup menu
|
||
// - used mostly internaly to add page browsing
|
||
// - default OnClick event is to go to page set by the Tag property
|
||
function NewPopupMenuItem(const aCaption: string; Tag: integer=0;
|
||
SubMenu: TMenuItem=nil; OnClick: TNotifyEvent=nil; ImageIndex: integer=-1): TMenuItem;
|
||
/// this is the main popup menu item click event
|
||
procedure PopupMenuItemClick(Sender: TObject);
|
||
/// can be used to draw directly using GDI commands
|
||
// - The Canvas property should be rarely needed
|
||
property Canvas: TMetaFileCanvas read fCanvas;
|
||
/// Distance (in mm's) from the top of the page to the top of the next line
|
||
property CurrentYPos: integer read GetYPos write SetYPos;
|
||
/// get current line height (mm)
|
||
property LineHeight: integer read GetLineHeightMm;
|
||
/// the name of the current selected printer
|
||
// - note that Printers.SetPrinter() should be set BEFORE calling BeginDoc,
|
||
// otherwise you may have a "canvas does not allow drawing" error
|
||
property PrinterName: string read fCurrentPrinter;
|
||
/// the index of the previewed page
|
||
// - please note that the first page is 1 (not 0)
|
||
property Page: integer read fCurrPreviewPage write SetPage;
|
||
/// total number of pages
|
||
property PageCount: integer read GetPageCount;
|
||
/// Size of each margin relative to its corresponding edge in mm's
|
||
property PageMargins: TRect read GetPageMargins write SetPageMargins;
|
||
/// Size of the left margin relative to its corresponding edge in mm's
|
||
property LeftMargin: integer read GetLeftMargin write SetLeftMargin;
|
||
/// Position of the right margin, in mm
|
||
property RightMarginPos: integer read GetRightMarginPos;
|
||
/// get the current selected paper size, in mm's
|
||
property PaperSize: TSize read GetPaperSize;
|
||
/// number of pixel per inch, for X and Y directions
|
||
property PrinterPxPerInch: TPoint read fPrinterPxPerInch;
|
||
{$ifdef USEPDFPRINTER}
|
||
/// true if any printer appears to be a PDF printer
|
||
property HasPDFPrinterInstalled: boolean read fHasPDFPrinterInstalled;
|
||
{$else}
|
||
/// this property can force saving all bitmaps as JPEG in exported PDF
|
||
// - by default, this property is set to 0 by the constructor of this class,
|
||
// meaning that the JPEG compression is not forced, and the engine will use
|
||
// the native resolution of the bitmap - in this case, the resulting
|
||
// PDF file content will be bigger in size (e.g. use this for printing)
|
||
// - 60 is the prefered way e.g. for publishing PDF over the internet
|
||
// - 80/90 is a good ration if you want to have a nice PDF to see on screen
|
||
// - of course, this doesn't affect vectorial (i.e. emf) pictures
|
||
property ExportPDFForceJPEGCompression: integer read fForceJPEGCompression write fForceJPEGCompression;
|
||
/// optional application name used during Export to PDF
|
||
// - if not set, global Application.Title will be used
|
||
property ExportPDFApplication: string read fExportPDFApplication write fExportPDFApplication;
|
||
/// optional Author name used during Export to PDF
|
||
property ExportPDFAuthor: string read fExportPDFAuthor write fExportPDFAuthor;
|
||
/// optional Subject text used during Export to PDF
|
||
property ExportPDFSubject: string read fExportPDFSubject write fExportPDFSubject;
|
||
/// optional Keywords name used during Export to PDF
|
||
property ExportPDFKeywords: string read fExportPDFKeywords write fExportPDFKeywords;
|
||
/// if set to TRUE, the used True Type fonts will be embedded to the exported PDF
|
||
// - not set by default, to save disk space and produce tiny PDF
|
||
property ExportPDFEmbeddedTTF: boolean read fExportPDFEmbeddedTTF write fExportPDFEmbeddedTTF;
|
||
/// if set to TRUE, the exported PDF is made compatible with PDF/A-1 requirements
|
||
property ExportPDFA1: Boolean read fExportPDFA1 write fExportPDFA1;
|
||
/// an optional background image, to be exported on every pdf page
|
||
// - note that no private copy of the TGraphic instance is made: the caller
|
||
// has to manage it, and free it after the pdf is generated
|
||
property ExportPDFBackground: TGraphic read fExportPDFBackground write fExportPDFBackground;
|
||
{$ifndef NO_USE_UNISCRIBE}
|
||
/// set if the exporting PDF engine must use the Windows Uniscribe API to
|
||
// render Ordering and/or Shaping of the text
|
||
// - useful for Hebrew, Arabic and some Asiatic languages handling
|
||
// - set to FALSE by default, for faster content generation
|
||
property ExportPDFUseUniscribe: boolean read fExportPDFUseUniscribe write fExportPDFUseUniscribe;
|
||
{$endif}
|
||
/// used to define if the exported PDF document will handle "font fallback" for
|
||
// characters not existing in the current font: it will avoid rendering
|
||
// block/square symbols instead of the correct characters (e.g. for Chinese text)
|
||
// - will use the font specified by FontFallBackName property to add any
|
||
// Unicode glyph not existing in the currently selected font
|
||
// - default value is TRUE
|
||
property ExportPDFUseFontFallBack: boolean read fExportPDFUseFontFallBack
|
||
write fExportPDFUseFontFallBack;
|
||
/// set the font name to be used for missing characters in exported PDF document
|
||
// - used only if UseFontFallBack is TRUE
|
||
// - default value is 'Arial Unicode MS', if existing
|
||
property ExportPDFFontFallBackName: string read fExportPDFFontFallBackName
|
||
write fExportPDFFontFallBackName;
|
||
/// set encryption level to be used in exporting PDF document
|
||
property ExportPDFEncryptionLevel: TPdfEncryptionLevel
|
||
read fExportPDFEncryptionLevel write fExportPDFEncryptionLevel;
|
||
/// set encryption user password to be used in exporting PDF document
|
||
// - leave it to '' unless you want the user to be asked for this password
|
||
// at document opening
|
||
// - ExportPDFEncryptionLevel = elRC4_40/elRC4_128 expects only ASCII-7 chars
|
||
property ExportPDFEncryptionUserPassword: string
|
||
read fExportPDFEncryptionUserPassword write fExportPDFEncryptionUserPassword;
|
||
/// set encryption owner password to be used in exporting PDF document
|
||
// - it is mandatory to set it to a non void value - by default, is set to
|
||
// 'SynopsePDFEngine' by should be overridden for security
|
||
// - ExportPDFEncryptionLevel = elRC4_40/elRC4_128 expects only ASCII-7 chars
|
||
property ExportPDFEncryptionOwnerPassword: string
|
||
read fExportPDFEncryptionOwnerPassword write fExportPDFEncryptionOwnerPassword;
|
||
/// set encryption Permissions to be used in exporting PDF document
|
||
// - can be either one of the PDF_PERMISSION_ALL / PDF_PERMISSION_NOMODIF /
|
||
// PDF_PERSMISSION_NOPRINT / PDF_PERMISSION_NOCOPY /
|
||
// PDF_PERMISSION_NOCOPYNORPRINT set of options
|
||
// - default value is PDF_PERMISSION_ALL (i.e. no restriction)
|
||
property ExportPDFEncryptionPermissions: TPdfEncryptionPermissions
|
||
read fExportPDFEncryptionPermissions write fExportPDFEncryptionPermissions;
|
||
/// set to TRUE to export in PDF 1.5 format, which may produce smaller files
|
||
property ExportPDFGeneratePDF15File: Boolean
|
||
read fExportPDFGeneratePDF15File write fExportPDFGeneratePDF15File;
|
||
{$endif}
|
||
/// the current page number, during text adding
|
||
// - Page is used during preview, after text adding
|
||
property VirtualPageNum: integer read fVirtualPageNum write fVirtualPageNum;
|
||
/// true if any header as been drawn, that is if something is to be printed
|
||
property HeaderDone: boolean read fHeaderDone;
|
||
{ /// used to set if columns must be delimited at their bottom with a gray line
|
||
property ColumnsWithBottomGrayLine: boolean read fColumnsWithBottomGrayLine
|
||
write fColumnsWithBottomGrayLine; }
|
||
published
|
||
/// accounting standard layout for caCurrency columns:
|
||
// - convert all negative sign into parentheses
|
||
// - using parentheses instead of negative numbers is used in financial
|
||
// statement reporting (see e.g. http://en.wikipedia.org/wiki/Income_statement)
|
||
// - align numbers on digits, not parentheses
|
||
property NegsToParenthesesInCurrCols: boolean
|
||
read fNegsToParenthesesInCurrCols write fNegsToParenthesesInCurrCols;
|
||
/// word wrap (caLeft) left-aligned columns into multiple lines
|
||
// - if the text is wider than the column width, its content
|
||
// is wrapped to the next line
|
||
// - if the text contains some #13/#10 characters, it will be splitted into
|
||
// individual lines
|
||
// - this is disabled by default
|
||
property WordWrapLeftCols: boolean read fWordWrapLeftCols write fWordWrapLeftCols;
|
||
/// if set, any DrawTitle() call will create an Outline entry
|
||
// - used e.g. for PDF generation
|
||
// - this is enabled by default
|
||
property UseOutlines: boolean read fUseOutlines write fUseOutlines;
|
||
/// left justification hang indentation
|
||
property HangIndent: integer read fHangIndent write fHangIndent;
|
||
/// Line spacing: can be lsSingle, lsOneAndHalf or lsDouble
|
||
property LineSpacing: TLineSpacing read fLineSpacing write fLineSpacing;
|
||
/// the paper orientation
|
||
property Orientation: TPrinterOrientation read GetOrientation write SetOrientation;
|
||
/// the current Zoom value, according to the zoom status
|
||
// - you can use PAGE_WIDTH and PAGE_FIT constants to force the corresponding
|
||
// zooming mode (similar to ZoomStatus property setter)
|
||
// - set this property will work only when the report is already shown
|
||
// in preview mode, not before ShowPreviewForm method call
|
||
property Zoom: integer read fZoom write SetZoom;
|
||
/// the current Zoom procedure, i.e. zsPercent, zsPageFit or zsPageWidth
|
||
// - set this property will define the Zoom at PAGE_WIDTH or PAGE_FIT
|
||
// special constant, if needed
|
||
// - set this property will work only when the report is already shown
|
||
// in preview mode, not before ShowPreviewForm method call
|
||
property ZoomStatus: TZoomStatus read fZoomStatus write SetZoomStatus;
|
||
/// if set to true, we reduce the precision for better screen display
|
||
property ForceScreenResolution: boolean
|
||
read fForceScreenResolution write fForceScreenResolution;
|
||
|
||
/// Event triggered when each new page is created
|
||
property OnNewPage: TNewPageEvent
|
||
read fStartNewPage write fStartNewPage;
|
||
/// Event triggered when each new header is about to be drawn
|
||
property OnStartPageHeader: TNotifyEvent
|
||
read fStartPageHeader write fStartPageHeader;
|
||
/// Event triggered when each header was drawn
|
||
property OnEndPageHeader: TNotifyEvent
|
||
read fEndPageHeader write fEndPageHeader;
|
||
/// Event triggered when each new footer is about to be drawn
|
||
property OnStartPageFooter: TNotifyEvent
|
||
read fStartPageFooter write fStartPageFooter;
|
||
/// Event triggered when each footer was drawn
|
||
property OnEndPageFooter: TNotifyEvent
|
||
read fEndPageFooter write fEndPageFooter;
|
||
/// Event triggered when each new column is about to be drawn
|
||
property OnStartColumnHeader: TNotifyEvent
|
||
read fStartColumnHeader write fStartColumnHeader;
|
||
/// Event triggered when each column was drawn
|
||
property OnEndColumnHeader: TNotifyEvent
|
||
read fEndColumnHeader write fEndColumnHeader;
|
||
|
||
/// Event triggered whenever the report document generation is done
|
||
// - i.e. when the EndDoc method has just been called
|
||
property OnDocumentProduced: TNotifyEvent
|
||
read fOnDocumentProducedEvent write fOnDocumentProducedEvent;
|
||
/// Event triggered whenever the current preview page is changed
|
||
property OnPreviewPageChanged: TNotifyEvent
|
||
read fPreviewPageChangedEvent write fPreviewPageChangedEvent;
|
||
/// Event triggered whenever the preview page is zoomed in or out
|
||
property OnZoomChanged: TZoomChangedEvent
|
||
read fZoomChangedEvent write fZoomChangedEvent;
|
||
end;
|
||
|
||
{$ifdef RENDERPAGES}
|
||
TRenderPages = class;
|
||
|
||
/// a TRenderPages additional layout state
|
||
// - used by the overridden SaveLayout/RestoreSavedLayout methods
|
||
TSavedStateRender = record
|
||
FirstLineIndent: Integer;
|
||
Before: Integer;
|
||
After: Integer;
|
||
RightIndent: Integer;
|
||
LeftIndent: Integer;
|
||
end;
|
||
|
||
PRenderBoxWord = ^TRenderBoxWord;
|
||
|
||
/// the internal "Word" box structure used by TRenderBox
|
||
TRenderBoxWord = packed record
|
||
/// offset in the fText[] array
|
||
TextOffset: integer;
|
||
/// PWideChar count starting from fText[TextOffset]
|
||
TextLength: integer;
|
||
/// size on the canvas
|
||
Size: TSize;
|
||
/// used to retrieve associated font attributes
|
||
FontIndex: integer;
|
||
/// space width from current font attribute
|
||
FontSpaceWidth: integer;
|
||
/// number of spaces at the right side of this "Word" box
|
||
SpaceAfterCount: integer;
|
||
/// associated link bookmark name
|
||
// - from fLinksBookMarkName[LinkNumber-1], no link set for 0
|
||
LinkNumber: integer;
|
||
end;
|
||
|
||
PRenderBoxLayout = ^TRenderBoxLayout;
|
||
|
||
/// the internal "drawing" box structure used by TRenderBox
|
||
// - TRenderBox.InternalRender populate fLayout[] with this structures,
|
||
// ready to be drawn to the document Canvas
|
||
TRenderBoxLayout = packed record
|
||
/// pointer of the words in the fText[] array
|
||
Text: PWideChar;
|
||
/// number of PWideChar starting at Text^
|
||
Length: integer;
|
||
/// layout box X coordinate
|
||
Left: integer;
|
||
/// layout box Y coordinate
|
||
Top: integer;
|
||
/// layout box width (in pixels)
|
||
Width: integer;
|
||
/// layout box height (in pixels) - that is, the line height
|
||
Height: integer;
|
||
/// corresponding rendered line index (starting at 0)
|
||
LineIndex: integer;
|
||
/// used to retrieve associated font attributes and links e.g.
|
||
LastBox: PRenderBoxWord;
|
||
/// length of extra space, in pixels - as used by SetTextJustification()
|
||
BreakExtra: integer;
|
||
/// count of space characters in line of text - as used by SetTextJustification()
|
||
BreakCount: integer;
|
||
end;
|
||
|
||
/// used to render a "box" of text
|
||
// - will handle word adding, and formatting for a given width
|
||
// - is used by TRenderPage for a whole paragraph, or a column inside a table
|
||
TRenderBox = class
|
||
protected
|
||
fBiDiMode: TBiDiMode;
|
||
fWidth: integer;
|
||
fHeight: integer;
|
||
/// an internal buffer containing the Unicode text of this box
|
||
fText: array of WideChar;
|
||
fTextLen: integer;
|
||
/// word markers of the current text
|
||
fBox: array of TRenderBoxWord;
|
||
fBoxCount: integer;
|
||
/// InternalRender will fill this ready to be rendered layout array
|
||
fLayout: array of TRenderBoxLayout;
|
||
fLayoutCount: integer;
|
||
fOwner: TRenderPages;
|
||
fOwnerFont: TFont;
|
||
/// associated links: none set for 0, otherwise fLinksBookMarkName[number-1]
|
||
fLinksBookMarkNameCurrent: integer;
|
||
fLinksBookMarkName: array of string;
|
||
/// populate fLayout[] from fBox[] and calculate fHeight
|
||
procedure InternalRender;
|
||
function GetHeight: integer;
|
||
procedure Clear;
|
||
public
|
||
/// initialize the rendering "box"
|
||
constructor Create(Owner: TRenderPages);
|
||
/// add some text at the current position
|
||
// - the text is converted to Unicode before adding (calling
|
||
// Owner.OnStringToUnicode if was defined)
|
||
// - the current Owner Font settings are used for the rendering
|
||
// - warning: this method won't handle control chars (like #13 or #10), but
|
||
// will replace them with a space: it's about the caller to
|
||
procedure AddText(const s: string); overload;
|
||
/// add some text at the current position
|
||
// - the current Owner Font settings are used for the rendering
|
||
// - warning: this method won't handle control chars (like #13 or #10), but
|
||
// will replace them with a space: it's about the caller to
|
||
procedure AddText(PW: PWideChar; PWLen: integer); overload;
|
||
/// format the already inserted text into the TRenderPages owner
|
||
// - this TRenderBox text content will be cleared at the end of this method
|
||
// - you don't have to call it usualy: use Owner.RdrParagraph instead
|
||
// - by default, will render top aligned to the X=Left/Y=Top pixels position
|
||
// - for vertical alignment, specify an height in ForcedHeightBottomCentered
|
||
// then will be centered if ForcedAtBottom=false, or bottom aligned if true
|
||
// - if CurrentPageOnly is true, will only flush the content which will fit on
|
||
// the current page - the fLayout[] array will contain remaining boxes;
|
||
// - if CurrentPageOnly is false, this will flush all content to multiple pages
|
||
procedure Flush(Left, Top: Integer; CurrentPageOnly: boolean;
|
||
ForcedHeightBottomCentered: Integer; ForcedAtBottom: boolean);
|
||
/// render the text paragraph, but go to the next line
|
||
// - similar to the <br /> HTML tag or the \line RTF command
|
||
procedure NewLine;
|
||
/// mark that an hyperlink must begin at the current position
|
||
// - use e.g. RdrAddText method to add some text for the link
|
||
// - will cancel any previous LinkBegin with no LinkEnd: i.e. no nested
|
||
// links are handled yet (how would want it anyway, in the HTML world?)
|
||
procedure LinkBegin(const aBookmarkName: string);
|
||
/// mark that an hyperlink must begin at the current position
|
||
// - use e.g. RdrAddText method to add some text for the link
|
||
// - return false on error (e.g. no hyperlink previously opened via LinkBegin)
|
||
function LinkEnd: boolean;
|
||
/// reset font (character) formatting properties to a default value
|
||
// - default value have been set by RdrSetCurrentStateAsDefault
|
||
// - if no previous call to RdrSetCurrentStateAsDefault has been made,
|
||
// the font is reset to a 12 point, with no bold/italic/underline attributes
|
||
// - similar to the \plain RTF command
|
||
procedure Plain; {$ifdef HASINLINE}inline;{$endif}
|
||
/// reset paragraph formatting properties to a default value
|
||
// - similar to the \pard RTF command
|
||
procedure Pard; {$ifdef HASINLINE}inline;{$endif}
|
||
/// reset both paragraph and font formatting properties to a default value
|
||
// - similar to the \pard\plain RTF command
|
||
procedure PardPlain; {$ifdef HASINLINE}inline;{$endif}
|
||
/// shortcut to the owner TRenderPages
|
||
property Owner: TRenderPages read fOwner;
|
||
/// shortcut to the owner TRenderPages.Font
|
||
property Font: TFont read fOwnerFont;
|
||
/// specifies the reading order (bidirectional mode) of the box
|
||
// - only bdLeftToRight and bdRightToLeft are handled
|
||
property BiDiMode: TBiDiMode read FBiDiMode write FBiDiMode;
|
||
/// current width of the "box", in pixels
|
||
// - must be set before any call to InternalRender
|
||
property Width: integer read fWidth write fWidth;
|
||
/// current resulting height of the "box", in pixels
|
||
// - will be calculated from current text if necessary
|
||
property Height: integer read GetHeight;
|
||
end;
|
||
|
||
/// Report class specified in high-quality document rendering
|
||
// - this class add some methods for creating a document at the character
|
||
// level (whereas standard TGDIPages allows reporting at paragraph level)
|
||
// - can be used e.g. to render some RTF-like content
|
||
// - column handling is much more sophisticated than AddColumn*() methods
|
||
// - uses the Windows Uniscribe API to handle right-to-left scripting and
|
||
// process complex scripts (like Arabic)
|
||
// - uses internaly some TeX-like algorithms like widows and orphans, and
|
||
// an optional external hyphenation engine (like our hyphen unit)
|
||
TRenderPages = class(TGDIPages)
|
||
protected
|
||
fParagraphFirstLineIndent: Integer;
|
||
fParagraphBefore: Integer;
|
||
fParagraphAfter: Integer;
|
||
fParagraphRightIndent: Integer;
|
||
fParagraphLeftIndent: Integer;
|
||
fSavedRender: array of TSavedStateRender;
|
||
fDefaultState: TSavedState;
|
||
fDefaultStateRender: TSavedStateRender;
|
||
fRdr: TRenderBox;
|
||
fRdrCol: TObjectList;
|
||
/// an array of TFont, used as cache
|
||
fFontCache: TObjectList;
|
||
fFontCacheSpace: array of TSize;
|
||
procedure RdrPard;
|
||
procedure RdrPardPlain;
|
||
procedure RdrPlain;
|
||
function GetCurrentFontCacheIndex: integer;
|
||
function GetCurrentFontCacheIndexAndSelect: integer;
|
||
function GetSavedRender: TSavedStateRender;
|
||
procedure SetSavedRender(const State: TSavedStateRender);
|
||
/// will close any pending paragraph (\page makes an implicit \par)
|
||
procedure NewPageInternal; override;
|
||
public
|
||
/// will set the current Font and Paragraph properties to be used as default
|
||
// - will be used by RdrPlain and RdrPard methods
|
||
procedure RdrSetCurrentStateAsDefault;
|
||
/// render the text paragraph, and begin a new one
|
||
// - write the paragraph text as specified by all previous calls to the
|
||
// Rdr TRenderBox methods, and begin a new paragraph, using a cleaned
|
||
// TRenderBox instance
|
||
// - will use the current TextAlign property value, and the current value
|
||
// of all Paragraph* properties of this class
|
||
// - similar to the </p> HTML tag or the \par RTF command
|
||
procedure RdrParagraph;
|
||
/// create a new table at the current position
|
||
// - return false on error (e.g. a table was opened but not yet ended)
|
||
function RdrTableBegin(const PercentWidth: array of integer): Boolean;
|
||
/// get a particular column
|
||
// - return the 'box' handling the layout of the column: use its
|
||
// AddText/NewLine/Link*/Plain/Pard methods methods to add some formatted text
|
||
function RdrTableColumn(aColumnIndex: Integer): TRenderBox; {$ifdef HASINLINE}inline;{$endif}
|
||
/// end a previously opened table
|
||
// - will draw all columns to the documents
|
||
// - return false on error (e.g. a table was not opened)
|
||
function RdrTableEnd: Boolean;
|
||
/// the main paragraph 'box' of the document
|
||
// - its AddText/NewLine/Link*/Plain/Pard methods methods to add some
|
||
// formatted text
|
||
// - the paragraph will be flushed to the main document with the RdrParagraph
|
||
// method will be called
|
||
property Rdr: TRenderBox read fRdr;
|
||
public { some overridden methods }
|
||
/// creates the reporting component
|
||
constructor Create(AOwner: TComponent); override;
|
||
/// finalize the component, releasing all used memory and associated TRenderBox
|
||
destructor Destroy; override;
|
||
/// Clear the current Report document
|
||
procedure Clear; override;
|
||
/// save the current font and alignment
|
||
// - similar to a { character in some RTF content
|
||
// - this version will save also Paragraph* properties values
|
||
procedure SaveLayout; override;
|
||
/// restore last saved font and alignment
|
||
// - similar to a } character in some RTF content
|
||
// - this version will restore also Paragraph* properties values
|
||
procedure RestoreSavedLayout; override;
|
||
public
|
||
/// current paragraph "space before" spacing (in mm, the default is 0)
|
||
property ParagraphBefore: Integer read fParagraphBefore write fParagraphBefore;
|
||
/// current paragraph "space after" spacing (in mm, the default is 0)
|
||
property ParagraphAfter: Integer read fParagraphAfter write fParagraphAfter;
|
||
/// current paragraph first-line indent (in mm, the default is 0)
|
||
property ParagraphFirstLineIndent: Integer
|
||
read fParagraphFirstLineIndent write fParagraphFirstLineIndent;
|
||
/// current paragraph left indent (in mm, the default is 0)
|
||
property ParagraphLeftIndent: Integer
|
||
read fParagraphLeftIndent write fParagraphLeftIndent;
|
||
/// current paragraph right indent (in mm, the default is 0)
|
||
property ParagraphRightIndent: Integer
|
||
read fParagraphRightIndent write fParagraphRightIndent;
|
||
end;
|
||
{$endif RENDERPAGES}
|
||
|
||
resourcestring
|
||
sPDFFile = 'Acrobat File';
|
||
sPageN = 'Page %d / %d';
|
||
/// used to create the popup menu of the report
|
||
// - should match TGdiPagePreviewButton order
|
||
sReportPopupMenu1 = '&Next page,&Previous page,&Go to Page...,&Zoom...,'+
|
||
'&Bookmarks,Copy Page as &Text,P&rint,PDF &Export,&Close,Page fit,Page width';
|
||
/// used to create the pages browsing menu of the report
|
||
sReportPopupMenu2 = 'Pages %d to %d,Page %d';
|
||
|
||
const
|
||
/// minimum gray border with around preview page
|
||
GRAY_MARGIN = 10;
|
||
|
||
/// TGdiPages.Zoom property value for "Page width" layout during preview
|
||
PAGE_WIDTH = -1;
|
||
/// TGdiPages.Zoom property value for "Page fit" layout during preview
|
||
PAGE_FIT = -2;
|
||
|
||
//TEXT FORMAT FLAGS...
|
||
FORMAT_DEFAULT = $0;
|
||
//fontsize bits 0-7 .'. max = 255
|
||
FORMAT_SIZE_MASK = $FF;
|
||
//alignment bits 8-9
|
||
FORMAT_ALIGN_MASK = $300;
|
||
FORMAT_LEFT = $0;
|
||
FORMAT_RIGHT = $100;
|
||
FORMAT_CENTER = $200;
|
||
FORMAT_JUSTIFIED = $300;
|
||
//fontstyle bits 10-12
|
||
FORMAT_BOLD = $400;
|
||
FORMAT_UNDERLINE = $800;
|
||
FORMAT_ITALIC = $1000;
|
||
//undefined bit 13
|
||
FORMAT_UNDEFINED = $2000;
|
||
//line flags bits 14-15
|
||
FORMAT_SINGLELINE = $8000;
|
||
FORMAT_DOUBLELINE = $4000;
|
||
FORMAT_LINES = $C000;
|
||
//DrawTextAt XPos 16-30 bits (max value = ~64000)
|
||
FORMAT_XPOS_MASK = $FFFF0000;
|
||
|
||
PAPERSIZE_A4_WIDTH = 210;
|
||
PAPERSIZE_A4_HEIGHT = 297;
|
||
|
||
|
||
procedure SetCurrentPrinterAsDefault;
|
||
function CurrentPrinterName: string;
|
||
function CurrentPrinterPaperSize: string;
|
||
procedure UseDefaultPrinter;
|
||
|
||
procedure Register;
|
||
|
||
|
||
implementation
|
||
|
||
uses
|
||
{$ifdef ISDELPHIXE3}System.UITypes,{$endif}
|
||
Types, Clipbrd, Consts;
|
||
|
||
// Miscellaneous functions ...
|
||
|
||
function TextExtent(Canvas: TCanvas; const Text: SynUnicode; Len: integer=0): TSize;
|
||
begin
|
||
Result.cX := 0;
|
||
Result.cY := 0;
|
||
if Len=0 then
|
||
Len := length(Text);
|
||
GetTextExtentPoint32W(Canvas.Handle, pointer(Text), Len, Result);
|
||
end;
|
||
|
||
function TextWidthC(Canvas: TCanvas; const Text: SynUnicode): Integer;
|
||
begin
|
||
Result := TextExtent(Canvas,Text).cX;
|
||
end;
|
||
|
||
procedure TextOut(Canvas: TCanvas; X,Y: integer; Text: PWideChar; Len: integer); overload;
|
||
begin
|
||
ExtTextOutW(Canvas.Handle,X,Y,Canvas.TextFlags,nil,Text,Len,nil);
|
||
end;
|
||
|
||
procedure TextOut(Canvas: TCanvas; X,Y: integer; const Text: SynUnicode); overload;
|
||
begin
|
||
ExtTextOutW(Canvas.Handle,X,Y,Canvas.TextFlags,nil,pointer(Text),Length(Text),nil);
|
||
end;
|
||
|
||
procedure Register;
|
||
begin
|
||
RegisterComponents('Samples', [TGDIPages]);
|
||
end;
|
||
|
||
function ConvertNegsToParentheses(const ValStr: SynUnicode): SynUnicode;
|
||
begin
|
||
result := ValStr;
|
||
if (result = '') or (result[1] <> '-') then
|
||
exit;
|
||
result[1] := '(';
|
||
result := result+')';
|
||
end;
|
||
|
||
function PrinterDriverExists: boolean;
|
||
var Flags, Count, NumInfo: dword;
|
||
Level: Byte;
|
||
begin
|
||
// avoid using fPrinter.printers.Count as this will raise an
|
||
// exception if no printer driver is installed...
|
||
Count := 0;
|
||
try
|
||
if Win32Platform = VER_PLATFORM_WIN32_NT then begin
|
||
Flags := PRINTER_ENUM_CONNECTIONS or PRINTER_ENUM_LOCAL;
|
||
Level := 4;
|
||
end else begin
|
||
Flags := PRINTER_ENUM_LOCAL;
|
||
Level := 5;
|
||
end;
|
||
EnumPrinters(Flags, nil, Level, nil, 0, Count, NumInfo);
|
||
except
|
||
end;
|
||
result := (count > 0);
|
||
end;
|
||
|
||
function RightTrim(const S: SynUnicode): SynUnicode;
|
||
var i: integer;
|
||
begin
|
||
i := Length(s);
|
||
while (i > 0) and (ord(S[i])<=32) do dec(i);
|
||
SetString(result,PWideChar(pointer(S)),i);
|
||
end;
|
||
|
||
function LowerCaseU(const S: SynUnicode): SynUnicode;
|
||
var i: integer;
|
||
begin
|
||
SetString(result,PWideChar(pointer(S)),length(S));
|
||
for i := 0 to length(S)-1 do
|
||
if PWordArray(result)[i] in [ord('A')..ord('Z')] then
|
||
dec(PWordArray(result)[i],32);
|
||
end;
|
||
|
||
function Max(a,b: integer): integer;
|
||
begin
|
||
if a > b then
|
||
result := a else
|
||
result := b;
|
||
end;
|
||
|
||
function Min(a,b: integer): integer;
|
||
begin
|
||
if a < b then
|
||
result := a else
|
||
result := b;
|
||
end;
|
||
|
||
procedure UseDefaultPrinter;
|
||
begin
|
||
Printers.Printer.PrinterIndex := -1;
|
||
end;
|
||
|
||
function GetDefaultPrinterName: string;
|
||
var Device : array[byte] of char;
|
||
p,p2: PChar;
|
||
begin
|
||
GetProfileString('windows', 'device', '', Device, 255);
|
||
p2 := Device;
|
||
while p2^ = ' ' do inc(p2);
|
||
p := p2;
|
||
while not (ord(p2^) in [0,ord(',')]) do inc(p2);
|
||
SetLength(result, p2 - p);
|
||
if p2 > p then
|
||
move(p^, pointer(result)^, p2 - p);
|
||
end;
|
||
|
||
function GetDriverForPrinter(Device: PChar; Driver: PChar): boolean;
|
||
var
|
||
PrintHandle: THandle;
|
||
DriverInfo2: PDriverInfo2;
|
||
cnt: dword;
|
||
DriverPath: string;
|
||
begin
|
||
result := false;
|
||
if not OpenPrinter(Device,PrintHandle, nil) then exit;
|
||
try
|
||
getmem(DriverInfo2,1024);
|
||
try
|
||
if GetPrinterDriver(PrintHandle, nil, 2, DriverInfo2, 1024, cnt) then
|
||
begin
|
||
DriverPath :=
|
||
changefileext(extractfilename(DriverInfo2.pDriverPath),'');
|
||
strpcopy(Driver, DriverPath);
|
||
result := true;
|
||
end;
|
||
finally
|
||
freemem(DriverInfo2);
|
||
end;
|
||
finally
|
||
ClosePrinter(PrintHandle);
|
||
end;
|
||
end;
|
||
|
||
procedure SetCurrentPrinterAsDefault;
|
||
var Device, Driver, Port: array[byte] of char;
|
||
DefaultPrinter: string;
|
||
hDeviceMode: THandle;
|
||
begin
|
||
DefaultPrinter := GetDefaultPrinterName;
|
||
Printer.GetPrinter(Device, Driver, Port, hDeviceMode);
|
||
if DefaultPrinter = Device then
|
||
exit;
|
||
if Driver[0] = #0 then
|
||
if not GetDriverForPrinter(Device, Driver) then
|
||
exit; // oops !
|
||
DefaultPrinter := FormatString('%,%,%',[Device, Driver, Port]);
|
||
WriteProfileString( 'windows', 'device', pointer(DefaultPrinter) );
|
||
Device := 'windows';
|
||
SendMessage(HWND_BROADCAST, WM_WININICHANGE, 0, PtrInt(@Device));
|
||
end;
|
||
|
||
function CurrentPrinterName: string;
|
||
var Device, Driver, Port: array[byte] of char;
|
||
hDeviceMode: THandle;
|
||
begin
|
||
Printer.GetPrinter(Device, Driver, Port, hDeviceMode);
|
||
result := trim(Device);
|
||
end;
|
||
|
||
function CurrentPrinterPaperSize: string;
|
||
var PtrHdl: THandle;
|
||
PtrPPI: TPoint;
|
||
size: TSize;
|
||
begin
|
||
try
|
||
PtrHdl := Printer.Handle;
|
||
PtrPPI.x := GetDeviceCaps(PtrHdl, LOGPIXELSX);
|
||
PtrPPI.y := GetDeviceCaps(PtrHdl, LOGPIXELSY);
|
||
size.cx := MulDiv(GetDeviceCaps(PtrHdl, PHYSICALWIDTH), 254, PtrPPI.x * 10);
|
||
size.cy := MulDiv(GetDeviceCaps(PtrHdl, PHYSICALHEIGHT), 254, PtrPPI.y * 10);
|
||
except
|
||
end;
|
||
with size do
|
||
begin
|
||
if cx > cy then
|
||
begin
|
||
//landscape ...
|
||
case cy of
|
||
148: if cx = 210 then result := 'A5 (210 x 148mm)';
|
||
210: if cx = 297 then result := 'A4 (297 x 210mm)';
|
||
216: if cx = 279 then result := 'Letter (11 x 8.5")'
|
||
else if cx = 356 then result := 'Legal (14 x 8.5")';
|
||
297: if cx = 420 then result := 'A3 (420 x 297mm)';
|
||
end;
|
||
end else
|
||
begin
|
||
//portrait ...
|
||
case cx of
|
||
148: if cy = 210 then result := 'A5 (148 x 210mm)';
|
||
210: if cy = 297 then result := 'A4 (210 x 297mm)';
|
||
216: if cy = 279 then result := 'Letter (8.5 x 11")'
|
||
else if cy = 356 then result := 'Legal (8.5 x 14")';
|
||
297: if cy = 420 then result := 'A3 (297 x 420mm)';
|
||
end;
|
||
end;
|
||
if result = '' then
|
||
result := FormatString('Custom (% x %mm)',[cx, cy]);
|
||
end;
|
||
end;
|
||
|
||
|
||
// This declaration modifies Delphi's declaration of GetTextExtentExPoint
|
||
// so that the variable to receive partial string extents (p6) is ignored ...
|
||
function GetTextExtentExPointNoPartialsW(DC: HDC; p2: PWideChar; p3, p4: Integer;
|
||
var p5: Integer; p6: pointer; var p7: TSize): BOOL; stdcall;
|
||
external gdi32 name 'GetTextExtentExPointW';
|
||
|
||
// TrimLine: Splits off from LS any characters beyond the allowed width
|
||
// breaking at the end of a word if possible. Leftover chars -> RS.
|
||
procedure TrimLine(Canvas: TCanvas; var ls: SynUnicode; out rs: SynUnicode;
|
||
LineWidthInPxls: integer);
|
||
var i,len,NumCharWhichFit: integer;
|
||
dummy: TSize;
|
||
function Fits: boolean;
|
||
begin
|
||
result := GetTextExtentExPointNoPartialsW(Canvas.Handle,
|
||
pointer(ls),len,LineWidthInPxls,NumCharWhichFit,nil,dummy);
|
||
end;
|
||
begin
|
||
len := length(ls);
|
||
if len = 0 then
|
||
exit;
|
||
|
||
// get the number of characters which will fit within LineWidth...
|
||
if len>1024 then
|
||
len := 1024; // speed up the API call: we expect only one line of text
|
||
if not Fits then // fix API error (too big text) by rough binary approximation
|
||
repeat
|
||
len := len shr 1;
|
||
until (len=0) or Fits;
|
||
|
||
if NumCharWhichFit = length(ls) then
|
||
exit; // if everything fits then stop here
|
||
|
||
// find the end of the last whole word which will fit...
|
||
i := NumCharWhichFit;
|
||
while (NumCharWhichFit > 0) and (ls[NumCharWhichFit] > ' ') do
|
||
dec(NumCharWhichFit);
|
||
if (NumCharWhichFit = 0) then NumCharWhichFit := i;
|
||
|
||
i := NumCharWhichFit+1;
|
||
// ignore trailing blanks in LS...
|
||
while (ls[NumCharWhichFit] <= ' ') do dec(NumCharWhichFit);
|
||
// ignore beginning blanks in RS...
|
||
len := length(ls); // may have been reduced if len>1024 or on API error
|
||
while (i < len) and (ls[i] <= ' ') do inc(i);
|
||
rs := copy(ls,i,len);
|
||
ls := copy(ls,1,NumCharWhichFit); //nb: assign ls AFTER rs here
|
||
end;
|
||
|
||
|
||
procedure PrintBitmap(Canvas: TCanvas; DestRect: TRect; Bitmap: TBitmap);
|
||
var BitmapHeader: pBitmapInfo;
|
||
BitmapImage : POINTER;
|
||
HeaderSize : dword;
|
||
ImageSize : dword;
|
||
begin
|
||
// we expect the bitmap to be stored as DIB in the TMetaFile content
|
||
GetDIBSizes(Bitmap.Handle,HeaderSize,ImageSize);
|
||
GetMem(BitmapHeader,HeaderSize);
|
||
GetMem(BitmapImage,ImageSize);
|
||
try
|
||
GetDIB(Bitmap.Handle, Bitmap.Palette, BitmapHeader^, BitmapImage^);
|
||
// will create a EMR_STRETCHDIBITS record, ready for SynPdf and SynGdiPlus
|
||
StretchDIBits(Canvas.Handle,
|
||
DestRect.Left, DestRect.Top, // Destination Origin
|
||
DestRect.Right - DestRect.Left, // Destination Width
|
||
DestRect.Bottom - DestRect.Top, // Destination Height
|
||
0,0, // Source Origin
|
||
Bitmap.Width, Bitmap.Height, // Source Width & Height
|
||
BitmapImage,
|
||
TBitmapInfo(BitmapHeader^),
|
||
DIB_RGB_COLORS,
|
||
SRCCOPY);
|
||
finally
|
||
FreeMem(BitmapHeader);
|
||
FreeMem(BitmapImage)
|
||
end;
|
||
end;
|
||
|
||
|
||
// This DrawArrow() function is based on code downloaded from
|
||
// http://www.efg2.com/Lab/Library/Delphi/Graphics/Algorithms.htm
|
||
// (The original author is unknown)
|
||
procedure DrawArrowInternal(Canvas: TCanvas;
|
||
FromPoint, ToPoint: TPoint; HeadSize: integer; SolidArrowHead: boolean);
|
||
var
|
||
xbase : integer;
|
||
xLineDelta : integer;
|
||
xLineUnitDelta : Double;
|
||
xNormalDelta : integer;
|
||
xNormalUnitDelta: Double;
|
||
ybase : integer;
|
||
yLineDelta : integer;
|
||
yLineUnitDelta : Double;
|
||
yNormalDelta : integer;
|
||
yNormalUnitDelta: Double;
|
||
SavedBrushColor : TColor;
|
||
begin
|
||
with FromPoint do Canvas.MoveTo(x,y);
|
||
with ToPoint do Canvas.LineTo(x,y);
|
||
|
||
xLineDelta := ToPoint.X - FromPoint.X;
|
||
yLineDelta := ToPoint.Y - FromPoint.Y;
|
||
|
||
xLineUnitDelta := xLineDelta / SQRT( SQR(xLineDelta) + SQR(yLineDelta) );
|
||
yLineUnitDelta := yLineDelta / SQRT( SQR(xLineDelta) + SQR(yLineDelta) );
|
||
|
||
// (xBase,yBase) is where arrow line is perpendicular to base of triangle
|
||
xBase := ToPoint.X - ROUND(HeadSize * xLineUnitDelta);
|
||
yBase := ToPoint.Y - ROUND(HeadSize * yLineUnitDelta);
|
||
|
||
xNormalDelta := yLineDelta;
|
||
yNormalDelta := -xLineDelta;
|
||
xNormalUnitDelta := xNormalDelta / SQRT( SQR(xNormalDelta) + SQR(yNormalDelta) );
|
||
yNormalUnitDelta := yNormalDelta / SQRT( SQR(xNormalDelta) + SQR(yNormalDelta) );
|
||
|
||
SavedBrushColor := Canvas.Brush.Color;
|
||
if SolidArrowHead then
|
||
Canvas.Brush.Color := Canvas.Pen.Color;
|
||
Canvas.Polygon([ToPoint,
|
||
Point(xBase + ROUND(HeadSize*xNormalUnitDelta),
|
||
yBase + ROUND(HeadSize*yNormalUnitDelta)),
|
||
Point(xBase - ROUND(HeadSize*xNormalUnitDelta),
|
||
yBase - ROUND(HeadSize*yNormalUnitDelta)) ]);
|
||
Canvas.Brush.Color := SavedBrushColor;
|
||
end;
|
||
|
||
|
||
|
||
{ TPagePaintBox }
|
||
|
||
procedure TPagePaintBox.WMEraseBkgnd(var Message: TWmEraseBkgnd);
|
||
begin
|
||
Message.Result := 1; // no erasing is necessary after this method call
|
||
end;
|
||
|
||
|
||
{ TGDIPages }
|
||
|
||
procedure TGDIPages.SetAnyCustomPagePx;
|
||
begin
|
||
if Int64(fCustomPageSize)<>-1 then
|
||
fPhysicalSizePx := fCustomPageSize;
|
||
if Int64(fCustomNonPrintableOffset)<>-1 then
|
||
fPhysicalOffsetPx := fCustomNonPrintableOffset;
|
||
if Int64(fCustomPageMargins.TopLeft)<>-1 then
|
||
fPageMarginsPx := fCustomPageMargins;
|
||
if Int64(fCustomPxPerInch)<>-1 then
|
||
fPrinterPxPerInch := fCustomPxPerInch;
|
||
fDefaultLineWidth := (fPrinterPxPerInch.y*25) div 2540;
|
||
end;
|
||
|
||
procedure TGDIPages.GetPrinterParams;
|
||
var i: integer;
|
||
begin
|
||
if Self=nil then exit;
|
||
if not fForceScreenResolution and fHasPrinterInstalled then
|
||
try
|
||
fCurrentPrinter := CurrentPrinterName;
|
||
if (Printer.orientation <> fOrientation) then
|
||
Printer.orientation := fOrientation;
|
||
fPtrHdl := Printer.Handle;
|
||
fPrinterPxPerInch.x := GetDeviceCaps(fPtrHdl, LOGPIXELSX);
|
||
fPrinterPxPerInch.y := GetDeviceCaps(fPtrHdl, LOGPIXELSY);
|
||
fPhysicalSizePx.x := GetDeviceCaps(fPtrHdl, PHYSICALWIDTH);
|
||
fPhysicalOffsetPx.x := GetDeviceCaps(fPtrHdl,PHYSICALOFFSETX);
|
||
fPhysicalSizePx.y := GetDeviceCaps(fPtrHdl, PHYSICALHEIGHT);
|
||
fPhysicalOffsetPx.y := GetDeviceCaps(fPtrHdl,PHYSICALOFFSETY);
|
||
fDefaultLineWidth := (fPrinterPxPerInch.y*25) div 2540; // 0.25 mm
|
||
exit; // if a printer was found then that's all that's needed
|
||
except
|
||
fHasPrinterInstalled := false;
|
||
end;
|
||
|
||
// ForceScreenResolution or no Printer: use screen resolution
|
||
if fHasPrinterInstalled then begin
|
||
if (Printer.orientation <> fOrientation) then
|
||
Printer.orientation := fOrientation;
|
||
fPtrHdl := printer.Handle;
|
||
fPhysicalSizePx.X := round(GetDeviceCaps(fPtrHdl, PHYSICALWIDTH) *
|
||
screen.pixelsperinch / GetDeviceCaps(fPtrHdl, LOGPIXELSX));
|
||
fPhysicalSizePx.Y := round(GetDeviceCaps(fPtrHdl, PHYSICALHEIGHT) *
|
||
screen.pixelsperinch / GetDeviceCaps(fPtrHdl, LOGPIXELSY));
|
||
end else begin
|
||
// if no printer drivers installed use the screen as device context and
|
||
// assume A4 page size...
|
||
fPtrHdl := 0; //GetDC(0);
|
||
fPhysicalSizePx.X := MulDiv(PAPERSIZE_A4_WIDTH*10,screen.pixelsperinch,254);
|
||
fPhysicalSizePx.Y := MulDiv(PAPERSIZE_A4_HEIGHT*10,screen.pixelsperinch,254);
|
||
end;
|
||
//assume 6mm non-printing offsets...
|
||
fPhysicalOffsetPx.X := MulDiv(60,screen.pixelsperinch,254);
|
||
fPhysicalOffsetPx.Y := MulDiv(60,screen.pixelsperinch,254);
|
||
fPrinterPxPerInch.X := screen.pixelsperinch;
|
||
fPrinterPxPerInch.Y := screen.pixelsperinch;
|
||
//fDefaultLineWidth ==> 0.3 mm
|
||
fDefaultLineWidth := (fPrinterPxPerInch.y*3) div 254;
|
||
if not fHasPrinterInstalled and (fOrientation = poLandscape) then begin
|
||
// no Printer.Orientation -> swap width & height if Landscape page layout
|
||
i := fPhysicalSizePx.x;
|
||
fPhysicalSizePx.x := fPhysicalSizePx.y;
|
||
fPhysicalSizePx.y := i;
|
||
end;
|
||
end;
|
||
|
||
procedure TGDIPages.SetMetaFileForPage(PageIndex: integer; MetaFile: TMetaFile);
|
||
var stream: TRawByteStringStream;
|
||
begin
|
||
if cardinal(PageIndex)>=cardinal(length(fPages)) then
|
||
exit;
|
||
stream := TRawByteStringStream.Create;
|
||
try
|
||
MetaFile.SaveToStream(stream);
|
||
fPages[PageIndex].MetaFileCompressed := stream.DataString;
|
||
CompressSynLZ(fPages[PageIndex].MetaFileCompressed,true);
|
||
finally
|
||
stream.Free;
|
||
end;
|
||
end;
|
||
|
||
function TGDIPages.GetMetaFileForPage(PageIndex: integer): TMetaFile;
|
||
var tmp: RawByteString;
|
||
stream: TStream;
|
||
begin
|
||
if fMetaFileForPage=nil then
|
||
fMetaFileForPage := TMetafile.Create else
|
||
fMetaFileForPage.Clear;
|
||
result := fMetaFileForPage;
|
||
if cardinal(PageIndex)>=cardinal(length(fPages)) then
|
||
exit;
|
||
tmp := fPages[PageIndex].MetaFileCompressed;
|
||
CompressSynLZ(tmp,false);
|
||
stream := TRawByteStringStream.Create(tmp);
|
||
try
|
||
fMetaFileForPage.LoadFromStream(stream);
|
||
finally
|
||
stream.Free;
|
||
end;
|
||
end;
|
||
|
||
function TGDIPages.PrinterPxToScreenPxX(PrinterPx: integer): integer;
|
||
begin
|
||
if (Self=nil) or (fPrinterPxPerInch.x=0) then
|
||
result := 0 else
|
||
result := (PrinterPx*screen.pixelsperinch*fZoom) div (fPrinterPxPerInch.x*100);
|
||
end;
|
||
|
||
function TGDIPages.PrinterPxToScreenPxY(PrinterPx: integer): integer;
|
||
begin
|
||
if (Self=nil) or (fPrinterPxPerInch.y=0) then
|
||
result := 0 else
|
||
result := (PrinterPx*screen.pixelsperinch*fZoom) div (fPrinterPxPerInch.y*100);
|
||
end;
|
||
|
||
function TGDIPages.MmToPrinterPxX(mm: integer): integer;
|
||
begin
|
||
if Self=nil then
|
||
result := 0 else
|
||
result := ((mm*10) * fPrinterPxPerInch.x) div 254;
|
||
end;
|
||
|
||
function TGDIPages.MmToPrinterPxY(mm: integer): integer;
|
||
begin
|
||
if Self=nil then
|
||
result := 0 else
|
||
result := ((mm*10) * fPrinterPxPerInch.y) div 254;
|
||
end;
|
||
|
||
function TGDIPages.PrinterPxToMmX(px: integer): integer;
|
||
begin
|
||
if (Self=nil) or (fPrinterPxPerInch.x=0) then
|
||
result := 0 else
|
||
result := (px*254) div (fPrinterPxPerInch.x*10);
|
||
end;
|
||
|
||
function TGDIPages.PrinterPxToMmY(px: integer): integer;
|
||
begin
|
||
if (Self=nil) or (fPrinterPxPerInch.y=0) then
|
||
result := 0 else
|
||
result := (px*254) div (fPrinterPxPerInch.y*10);
|
||
end;
|
||
|
||
procedure TGDIPages.ResizeAndCenterPaintbox;
|
||
var l,t, i: integer;
|
||
siz: TPoint;
|
||
begin
|
||
if cardinal(page-1)<cardinal(length(fPages)) then
|
||
siz := fPages[page-1].SizePx else
|
||
siz := fPhysicalSizePx;
|
||
// center the paintbox according to the new size
|
||
with fPreviewSurface do begin
|
||
siz.X := PrinterPxToScreenPxX(siz.X)+GRAY_MARGIN*2;
|
||
siz.Y := PrinterPxToScreenPxY(siz.Y)+GRAY_MARGIN*2;
|
||
l := Max((Self.ClientWidth - siz.X) div 2,0) - HorzScrollbar.Position;
|
||
t := Max((Self.ClientHeight - siz.Y) div 2,0) - VertScrollbar.Position;
|
||
SetBounds(l,t,siz.X,siz.Y);
|
||
end;
|
||
// resize any hot link
|
||
for i := 0 to fLinks.Count-1 do
|
||
TGDIPagereference(fLinks.Objects[i]).ToPreview(Self);
|
||
end;
|
||
|
||
function TGDIPages.GetOrientation: TPrinterOrientation;
|
||
begin
|
||
if (Self=nil) or (fPhysicalSizePx.x > fPhysicalSizePx.y) then
|
||
result := poLandscape else
|
||
result := poPortrait;
|
||
end;
|
||
|
||
procedure TGDIPages.SetTextAlign(Value: TTextAlign);
|
||
begin
|
||
if Self<>nil then
|
||
fAlign := Value;
|
||
end;
|
||
|
||
procedure TGDIPages.SetOrientation(orientation: TPrinterOrientation);
|
||
begin
|
||
if (Self<>nil) and (fOrientation<>orientation) then begin
|
||
fOrientation := orientation;
|
||
if fPages<>nil then begin
|
||
// changed orientation after start writing -> customize with inversed size
|
||
fCustomPageSize.X := fPhysicalSizePx.Y;
|
||
fCustomPageSize.Y := fPhysicalSizePx.X;
|
||
fCustomPxPerInch.X := fPrinterPxPerInch.Y;
|
||
fCustomPxPerInch.Y := fPrinterPxPerInch.X;
|
||
fCustomNonPrintableOffset.X := fPhysicalOffsetPx.Y;
|
||
fCustomNonPrintableOffset.Y := fPhysicalOffsetPx.X;
|
||
end;
|
||
end;
|
||
end;
|
||
|
||
procedure TGDIPages.NewPageLayout(sizeWidthMM, sizeHeightMM: integer;
|
||
nonPrintableWidthMM: integer=-1; nonPrintableHeightMM: integer=-1);
|
||
begin
|
||
if Self=nil then
|
||
exit;
|
||
fCustomPageSize.X := MmToPrinterPxX(sizeWidthMM);
|
||
fCustomPageSize.Y := MmToPrinterPxY(sizeHeightMM);
|
||
if (nonPrintableWidthMM>=0) and (nonPrintableHeightMM>=0) then begin
|
||
fCustomNonPrintableOffset.X := MmToPrinterPxX(nonPrintableWidthMM);
|
||
fCustomNonPrintableOffset.Y := MmToPrinterPxY(nonPrintableHeightMM);
|
||
end;
|
||
if fPages<>nil then // force new page if already some content
|
||
NewPage(true);
|
||
end;
|
||
|
||
procedure TGDIPages.NewPageLayout(paperSize: TGdiPagePaperSize;
|
||
orientation: TPrinterOrientation=poPortrait;
|
||
nonPrintableWidthMM: integer=-1; nonPrintableHeightMM: integer=-1);
|
||
var Siz,NonPrint: TPoint;
|
||
const // psA4, psA5, psA3, psLetter, psLegal
|
||
SIZES: array[TGdiPagePaperSize] of TPoint = (
|
||
(x:210;y:297),(x:148;y:210),(x:297;y:420),(x:216;y:279),(x:216;y:356));
|
||
begin
|
||
if orientation=poPortrait then begin
|
||
Siz := SIZES[paperSize];
|
||
NonPrint.X := nonPrintableWidthMM;
|
||
NonPrint.Y := nonPrintableHeightMM;
|
||
end else begin
|
||
Siz.X := SIZES[paperSize].Y;
|
||
Siz.Y := SIZES[paperSize].X;
|
||
NonPrint.X := nonPrintableHeightMM;
|
||
NonPrint.Y := nonPrintableWidthMM;
|
||
end;
|
||
NewPageLayout(Siz.X,Siz.Y,NonPrint.X,NonPrint.Y);
|
||
end;
|
||
|
||
procedure TGDIPages.SetPage(NewPreviewPage: integer);
|
||
begin
|
||
if Self=nil then exit;
|
||
if NewPreviewPage > length(fPages) then
|
||
NewPreviewPage := length(fPages) else
|
||
if NewPreviewPage < 1 then
|
||
NewPreviewPage := 1;
|
||
if (Pages = nil) or (fCurrPreviewPage = NewPreviewPage) then
|
||
exit;
|
||
fCurrPreviewPage := NewPreviewPage;
|
||
fLinksCurrent := -1;
|
||
FreeAndNil(PreviewSurfaceBitmap); // force double buffering Bitmap recreate
|
||
ResizeAndCenterPaintbox; // if page size changed
|
||
PreviewPaint(Self);
|
||
if Assigned(fPreviewPageChangedEvent) then
|
||
fPreviewPageChangedEvent(Self);
|
||
if PreviewForm<>nil then begin
|
||
PreviewPageCountLabel.Caption := format(sPageN,[Page,PageCount]);
|
||
PreviewButtons[ord(rNextPage)-1].Enabled := Page<PageCount;
|
||
PreviewButtons[ord(rPreviousPage)-1].Enabled := Page>1;
|
||
end;
|
||
end;
|
||
|
||
function TGDIPages.GetPageCount: integer;
|
||
begin
|
||
if Self=nil then
|
||
result := 0 else
|
||
result := length(fPages);
|
||
end;
|
||
|
||
function TGDIPages.GetLineHeight: integer;
|
||
var tm: TTextMetric;
|
||
DC: HDC;
|
||
begin
|
||
if Self=nil then begin
|
||
result := 0;
|
||
exit;
|
||
end;
|
||
if fLineHeight = 0 then begin
|
||
if not Assigned(fCanvas) then begin
|
||
// if no current fCanvas: use the Screen resolution (very fast)
|
||
DC := GetDC(0);
|
||
GetTextMetrics(DC,tm);
|
||
ReleaseDC(0,DC);
|
||
end else
|
||
GetTextMetrics(fCanvas.Handle,tm);
|
||
fLineHeight := ((tm.tmHeight+tm.tmExternalLeading)*9)shr 3;
|
||
end;
|
||
if fInHeaderOrFooter then
|
||
result := fLineHeight else
|
||
case fLineSpacing of
|
||
lsSingle: result := fLineHeight;
|
||
lsOneAndHalf: result := (fLineHeight*3) shr 1;
|
||
else result := fLineHeight*2;
|
||
end;
|
||
end;
|
||
|
||
function TGDIPages.GetLineHeightMm: integer;
|
||
begin
|
||
if Self=nil then
|
||
result := 0 else
|
||
result := PrinterPxToMmY(GetLineHeight);
|
||
end;
|
||
|
||
procedure TGDIPages.CheckHeaderDone;
|
||
begin
|
||
if not fHeaderDone then
|
||
DoHeader;
|
||
end;
|
||
|
||
procedure TGDIPages.CheckYPos;
|
||
begin
|
||
if Self=nil then exit;
|
||
if fInHeaderOrFooter then exit;
|
||
CheckHeaderDone;
|
||
if not HasSpaceForLines(1) then begin
|
||
NewPageInternal;
|
||
// nb: header is done inside a group, so we must check for it
|
||
CheckHeaderDone;
|
||
end;
|
||
end;
|
||
|
||
function TGDIPages.GetYPos: integer;
|
||
begin
|
||
if (Self=nil) or (fPrinterPxPerInch.y=0) then
|
||
result := 0 else
|
||
result := (fCurrentYPos*254) div (fPrinterPxPerInch.y*10);
|
||
end;
|
||
|
||
procedure TGDIPages.SetYPos(YPos: integer);
|
||
begin
|
||
if Self=nil then exit;
|
||
if fCurrentYPos >= fPhysicalSizePx.y then
|
||
NewPageInternal;
|
||
fCurrentYPos := MmToPrinterPxY(YPos);
|
||
end;
|
||
|
||
function TGDIPages.GetSavedState: TSavedState;
|
||
begin
|
||
with result do begin
|
||
Flags := TextFormatsToFlags;
|
||
FontName := Font.Name;
|
||
FontColor := Font.Color;
|
||
LeftMargin := fPageMarginsPx.Left;
|
||
RightMargin := fPageMarginsPx.Right;
|
||
BiDiMode := fBiDiMode;
|
||
end;
|
||
end;
|
||
|
||
procedure TGDIPages.SetSavedState(const SavedState: TSavedState);
|
||
begin
|
||
with SavedState do begin
|
||
SetFontWithFlags(Flags);
|
||
Font.Name := FontName;
|
||
Font.Color := FontColor;
|
||
fPageMarginsPx.Left := LeftMargin;
|
||
fPageMarginsPx.Right := RightMargin;
|
||
fBiDiMode := BiDiMode;
|
||
end;
|
||
end;
|
||
|
||
procedure TGDIPages.SaveLayout;
|
||
begin
|
||
if Self=nil then exit; // avoid GPF
|
||
if fSavedCount>=length(fSaved) then
|
||
SetLength(fSaved,fSavedCount+20);
|
||
fSaved[fSavedCount] := SavedState;
|
||
inc(fSavedCount);
|
||
end;
|
||
|
||
procedure TGDIPages.RestoreSavedLayout;
|
||
begin
|
||
if Self=nil then exit; // avoid GPF
|
||
if fSavedCount<=0 then
|
||
exit;
|
||
dec(fSavedCount);
|
||
SavedState := fSaved[fSavedCount];
|
||
end;
|
||
|
||
function TGDIPages.CreateMetaFile(aWidth, aHeight: integer): TMetaFile;
|
||
begin
|
||
result := TMetafile.Create;
|
||
if Self=nil then exit;
|
||
result.Enhanced := true;
|
||
result.Width := aWidth;
|
||
result.Height := aHeight;
|
||
end;
|
||
|
||
procedure TGDIPages.FlushPageContent;
|
||
var n: integer;
|
||
begin
|
||
n := length(fPages);
|
||
if n>0 then begin
|
||
with fPages[n-1] do begin
|
||
Text := fCanvasText;
|
||
SizePx := fPhysicalSizePx;
|
||
MarginPx := fPageMarginsPx;
|
||
OffsetPx := fPhysicalOffsetPx;
|
||
end;
|
||
if fCurrentMetaFile<>nil then begin
|
||
SetMetaFileForPage(n-1,fCurrentMetaFile);
|
||
FreeAndNil(fCurrentMetaFile);
|
||
end;
|
||
end;
|
||
end;
|
||
|
||
procedure TGDIPages.NewPageInternal;
|
||
var n: integer;
|
||
UsedGroupSpace: integer;
|
||
InGroup: boolean;
|
||
GroupText: string;
|
||
begin
|
||
if Self=nil then exit;
|
||
UsedGroupSpace := 0; //stops a warning
|
||
InGroup := Assigned(fGroupPage);
|
||
if InGroup then begin // close the Group Canvas
|
||
UsedGroupSpace := fCurrentYPos;
|
||
FreeAndNil(fCanvas); // now recreate/redraw a fresh fCanvas for DoFooter
|
||
fCanvas := CreateMetafileCanvas(fCurrentMetaFile);
|
||
fCanvas.Draw(0,0,fCurrentMetaFile); // re-draw last page
|
||
GroupText := fCanvasText;
|
||
fCanvasText := fBeforeGroupText;
|
||
end;
|
||
DoFooter;
|
||
//create a new metafile and its canvas ...
|
||
if Assigned(fCanvas) then
|
||
FreeAndNil(fCanvas);
|
||
FlushPageContent;
|
||
SetAnyCustomPagePx;
|
||
//NewPage.MMWidth := (fPhysicalSizePx.x*2540) div fPrinterPxPerInch.x;
|
||
//NewPage.MMHeight := (fPhysicalSizePx.y*2540) div fPrinterPxPerInch.y;
|
||
n := Length(fPages)+1;
|
||
SetLength(fPages,n);
|
||
fCurrentMetaFile := CreateMetaFile(fPhysicalSizePx.x,fPhysicalSizePx.y);
|
||
fCanvas := CreateMetafileCanvas(fCurrentMetaFile);
|
||
fCanvasText := '';
|
||
inc(fVirtualPageNum);
|
||
fCurrentYPos := fPageMarginsPx.top;
|
||
if Assigned(fStartNewPage) then
|
||
fStartNewPage(Self,n);
|
||
fHeaderDone := false;
|
||
fColumnHeaderPrinted := false; // when next col. started add header
|
||
if InGroup then begin // draw the group at the begining of new page + EndGroup
|
||
DoHeader;
|
||
if fColumnsUsedInGroup then begin
|
||
//The next line is a workaround to stop an endless loop. CheckYPos (called
|
||
//via PrintColumnHeaders) thinks we're still drawing on fGroupPage as it's
|
||
//still Assigned so can flag "out of room" and try to create another page.
|
||
fGroupVerticalSpace := fPhysicalSizePx.y;
|
||
if not fColumnHeaderInGroup then
|
||
PrintColumnHeaders else
|
||
fColumnHeaderPrinted := true;
|
||
end;
|
||
fCanvas.Draw(0,fCurrentYPos,fGroupPage);
|
||
FreeAndNil(fGroupPage); // idem as EndGroup
|
||
inc(fCurrentYPos,UsedGroupSpace);
|
||
fCanvasText := fCanvasText+GroupText;
|
||
end;
|
||
end;
|
||
|
||
function TGDIPages.CreateMetafileCanvas(Page: TMetafile): TMetafileCanvas;
|
||
begin
|
||
result := TMetafileCanvas.Create(Page,fPtrHdl);
|
||
if Self=nil then exit;
|
||
UpdateMetafileCanvasFont(result);
|
||
result.Pen.Width := fPrinterPxPerInch.y div screen.PixelsPerInch;
|
||
end;
|
||
|
||
procedure TGDIPages.UpdateMetafileCanvasFont(aCanvas: TMetafileCanvas);
|
||
begin
|
||
// next 2 lines are a printer bug workaround - 23Mar2000
|
||
aCanvas.Font.Size := Font.Size+1;
|
||
aCanvas.Font.PixelsPerInch := fPrinterPxPerInch.y;
|
||
aCanvas.Font := Font;
|
||
end;
|
||
|
||
function TGDIPages.TextFormatsToFlags: integer;
|
||
begin
|
||
result := min(max(font.size,4),FORMAT_SIZE_MASK); { size between 4 and 255 }
|
||
case fAlign of
|
||
taRight: result := result or FORMAT_RIGHT;
|
||
taCenter: result := result or FORMAT_CENTER;
|
||
taJustified: result := result or FORMAT_JUSTIFIED;
|
||
end;
|
||
if fsBold in font.style then
|
||
result := result or FORMAT_BOLD;
|
||
if fsUnderline in font.style then
|
||
result := result or FORMAT_UNDERLINE;
|
||
if fsItalic in font.style then
|
||
result := result or FORMAT_ITALIC;
|
||
end;
|
||
|
||
procedure TGDIPages.SetFontWithFlags(flags: integer);
|
||
var fontstyle: TFontStyles;
|
||
begin
|
||
if flags and FORMAT_SIZE_MASK<>Font.Size then
|
||
Font.size := flags and FORMAT_SIZE_MASK;
|
||
if (flags and FORMAT_BOLD) <> 0 then
|
||
fontstyle := [fsBold] else
|
||
fontstyle := [];
|
||
if (flags and FORMAT_UNDERLINE) <> 0 then
|
||
include(fontstyle,fsUnderline);
|
||
if (flags and FORMAT_ITALIC) <> 0 then
|
||
include(fontstyle,fsItalic);
|
||
if Font.Style<>fontstyle then
|
||
Font.Style := fontstyle;
|
||
case flags and FORMAT_ALIGN_MASK of
|
||
FORMAT_RIGHT: falign := taRight;
|
||
FORMAT_CENTER: falign := taCenter;
|
||
FORMAT_JUSTIFIED: falign := taJustified;
|
||
else falign := taLeft;
|
||
end;
|
||
end;
|
||
|
||
function TGDIPages.HasSpaceForLines(Count: integer): boolean;
|
||
begin
|
||
if Self=nil then
|
||
result := false else // avoid GPF
|
||
if Assigned(fGroupPage) then
|
||
result := fCurrentYPos + GetLineHeight*Count < fGroupVerticalSpace else
|
||
result := fCurrentYPos + GetLineHeight*Count <
|
||
fPhysicalSizePx.y - fPageMarginsPx.bottom - fFooterHeight;
|
||
end;
|
||
|
||
function TGDIPages.HasSpaceFor(mm: integer): boolean;
|
||
begin
|
||
if Self=nil then
|
||
result := false else begin // avoid GPF
|
||
mm := fCurrentYPos + MmToPrinterPxY(mm);
|
||
if Assigned(fGroupPage) then
|
||
result := mm < fGroupVerticalSpace else
|
||
result := mm < fPhysicalSizePx.y - fPageMarginsPx.bottom - fFooterHeight;
|
||
end;
|
||
end;
|
||
|
||
procedure TGDIPages.DoHeader;
|
||
begin
|
||
fHeaderDone := true;
|
||
if (fHeaderLines.Count = 0) then exit;
|
||
SaveLayout;
|
||
fInHeaderOrFooter := true;
|
||
try
|
||
if Assigned(fStartPageHeader) then
|
||
fStartPageHeader(Self);
|
||
Font.Color := clBlack;
|
||
DoHeaderFooterInternal(fHeaderLines);
|
||
if Assigned(fEndPageHeader) then
|
||
fEndPageHeader(Self);
|
||
GetLineHeight;
|
||
inc(fCurrentYPos,fLineHeight shr 2); // add a small header gap
|
||
fHeaderHeight := fCurrentYPos-fPageMarginsPx.Top;
|
||
finally
|
||
fInHeaderOrFooter := false;
|
||
RestoreSavedLayout;
|
||
end;
|
||
end;
|
||
|
||
procedure TGDIPages.DoFooter;
|
||
begin
|
||
if (fFooterLines.Count = 0) then exit;
|
||
SaveLayout;
|
||
fInHeaderOrFooter := true;
|
||
try
|
||
fCurrentYPos :=
|
||
fPhysicalSizePx.y - fPageMarginsPx.bottom - fFooterHeight + fFooterGap;
|
||
if Assigned(fStartPageFooter) then
|
||
fStartPageFooter(Self);
|
||
DoHeaderFooterInternal(fFooterLines);
|
||
if Assigned(fEndPageFooter) then
|
||
fEndPageFooter(Self);
|
||
finally
|
||
fInHeaderOrFooter := false;
|
||
RestoreSavedLayout;
|
||
end;
|
||
end;
|
||
|
||
procedure TGDIPages.DoHeaderFooterInternal(Lines: TObjectList);
|
||
var i: integer;
|
||
begin
|
||
SaveLayout;
|
||
try
|
||
for i := 0 to Lines.Count -1 do
|
||
with THeaderFooter(Lines[i]) do
|
||
begin
|
||
SavedState := State;
|
||
PrintFormattedLine(Text, State.Flags);
|
||
end;
|
||
finally
|
||
RestoreSavedLayout;
|
||
end;
|
||
end;
|
||
|
||
procedure TGDIPages.CalcFooterGap;
|
||
begin
|
||
GetLineHeight;
|
||
// make sure there's a gap of at least 1/4 of a lineheight
|
||
// between the page body and the footer ...
|
||
fFooterGap := fLineHeight shr 2;
|
||
fFooterHeight := fFooterGap;
|
||
end;
|
||
|
||
function TGDIPages.GetColumnRec(col: integer): TColRec;
|
||
begin
|
||
if Cardinal(col)<Cardinal(length(fColumns)) then
|
||
result := fColumns[col] else begin
|
||
result.ColLeft := 0;
|
||
result.ColRight := 0;
|
||
end;
|
||
end;
|
||
|
||
procedure TGDIPages.PrintColumnHeaders;
|
||
var
|
||
i,SavedFontSize,FontCol: integer;
|
||
SavedFontStyle: TFontStyles;
|
||
SavedAlign: TTextAlign;
|
||
SavedWordWrapLeftCols: boolean;
|
||
|
||
begin
|
||
if (fColumnHeaderList = nil) or (fColumns=nil) then exit;
|
||
CheckYPos;
|
||
|
||
fColumnHeaderPrinted := true; //stops an endless loop
|
||
SavedFontSize := Font.size;
|
||
SavedFontStyle := font.style;
|
||
SavedAlign := fAlign;
|
||
SavedWordWrapLeftCols := WordWrapLeftCols;
|
||
WordWrapLeftCols := false;
|
||
|
||
if Assigned(fStartColumnHeader) then
|
||
fStartColumnHeader(Self);
|
||
FontCol := fCanvas.Font.Color;
|
||
for i := 0 to High(fColumnHeaderList) do begin
|
||
SetFontWithFlags(fColumnHeaderList[i].flags);
|
||
fCanvas.Font.Color := clBlack;
|
||
fDrawTextAcrossColsDrawingHeader := true;
|
||
DrawTextAcrossCols(fColumnHeaderList[i].headers,[],clNone);
|
||
fDrawTextAcrossColsDrawingHeader := false;
|
||
end;
|
||
fCanvas.Font.Color := FontCol;
|
||
if Assigned(fEndColumnHeader) then
|
||
fEndColumnHeader(Self);
|
||
// add a small space below the column headers
|
||
// inc(fCurrentYPos,fLineHeight shr 2);
|
||
|
||
Font.Size := SavedFontSize;
|
||
Font.Style := SavedFontStyle;
|
||
fAlign := SavedAlign;
|
||
WordWrapLeftCols := SavedWordWrapLeftCols;
|
||
if Assigned(fGroupPage) then
|
||
fColumnHeaderInGroup := true;
|
||
fColumnHeaderPrintedAtLeastOnce :=
|
||
ForceCopyTextAsWholeContent; // don't reproduce headers every page
|
||
end;
|
||
|
||
procedure TGDIPages.SetZoomStatus(aZoomStatus: TZoomStatus);
|
||
var zoom: integer;
|
||
begin
|
||
if (self=nil) or (aZoomStatus=fZoomStatus) then
|
||
exit;
|
||
case aZoomStatus of
|
||
zsPageFit: zoom := PAGE_FIT;
|
||
zsPageWidth: zoom := PAGE_WIDTH;
|
||
else zoom := fZoom;
|
||
end;
|
||
SetZoom(zoom);
|
||
end;
|
||
|
||
procedure TGDIPages.SetZoom(Zoom: integer);
|
||
var scrollIncrement, zoomW, zoomH: integer;
|
||
siz: TPoint;
|
||
begin
|
||
if (Self=nil) or (zoom < PAGE_FIT) or (zoom in [0..9]) or (zoom > 200) then
|
||
exit;
|
||
fLinksCurrent := -1;
|
||
FreeAndNil(PreviewSurfaceBitmap);
|
||
|
||
if (not handleallocated) or (fZoom=Zoom) or
|
||
(cardinal(page-1)>=cardinal(length(fPages))) then
|
||
exit;
|
||
|
||
// calculate the new fZoom ...
|
||
siz := fPages[page-1].SizePx;
|
||
if (siz.x=0) or (siz.y=0) then // in case of potential div per 0 -> do it later
|
||
exit else
|
||
if zoom = PAGE_FIT then begin
|
||
ZoomW := trunc((clientWidth-GRAY_MARGIN*2)*fPrinterPxPerInch.x*
|
||
100/siz.x/screen.pixelsperinch);
|
||
ZoomH := trunc((clientHeight-GRAY_MARGIN*2)*fPrinterPxPerInch.y*
|
||
100/siz.y/screen.pixelsperinch);
|
||
//choose the smallest of width% and height% to fit on page (but min 10%)
|
||
fZoom := Max(Min(ZoomW,ZoomH),10);
|
||
end else
|
||
if zoom = PAGE_WIDTH then
|
||
fZoom := trunc((clientWidth-GRAY_MARGIN*2)*fPrinterPxPerInch.x*
|
||
100/siz.x/screen.pixelsperinch) else
|
||
fZoom := Zoom;
|
||
|
||
// ZoomStatus required when resizing...
|
||
if zoom = PAGE_FIT then
|
||
fZoomStatus := zsPageFit else
|
||
if zoom = PAGE_WIDTH then
|
||
fZoomStatus := zsPageWidth else
|
||
fZoomStatus := zsPercent;
|
||
|
||
scrollIncrement := PrinterPxToScreenPxY(GetLineHeight);
|
||
HorzScrollbar.Increment := scrollIncrement;
|
||
VertScrollbar.Increment := scrollIncrement;
|
||
|
||
// resize and center preview surface...
|
||
ResizeAndCenterPaintbox;
|
||
|
||
if Assigned(fZoomChangedEvent) then
|
||
fZoomChangedEvent(Self, fZoom, fZoomStatus);
|
||
end;
|
||
|
||
const
|
||
ZOOMSTEP = 20;
|
||
|
||
procedure TGDIPages.ZoomTimerInternal(X,Y: integer; ZoomIn: boolean);
|
||
var
|
||
OldZoom: integer;
|
||
pt, siz: TPoint;
|
||
begin
|
||
if (Self=nil) or (fPhysicalSizePx.x=0) or (fPhysicalSizePx.y=0) then
|
||
Exit;
|
||
if page>0 then
|
||
siz := fPages[page-1].SizePx else
|
||
siz := fPhysicalSizePx;
|
||
OldZoom := fZoom;
|
||
sendmessage(handle,WM_SETREDRAW,0,0);
|
||
try
|
||
if ZoomIn then begin
|
||
{$ifdef MOUSE_CLICK_PERFORM_ZOOM}
|
||
if fZoom >= 200 then
|
||
fZoomTimer.enabled := false else //(maximum 200%)
|
||
{$else}if fZoom < 200 then {$endif}
|
||
Zoom := ((fZoom + ZOOMSTEP) div ZOOMSTEP)*ZOOMSTEP; //to nearest ZOOMSTEP%
|
||
end else begin
|
||
if (fZoom > 20) then
|
||
Zoom := ((fZoom - ZOOMSTEP) div ZOOMSTEP)*ZOOMSTEP else //(minimum 20%)
|
||
{$ifdef MOUSE_CLICK_PERFORM_ZOOM}
|
||
fZoomTimer.enabled := false;
|
||
{$endif}
|
||
end;
|
||
if fZoom = OldZoom then
|
||
exit;
|
||
// work out click pos relative to page (as x & y percentages)
|
||
pt.x := ((X-fPreviewSurface.left-GRAY_MARGIN)*100) div PrinterPxToScreenPxX(siz.x);
|
||
pt.x := min(max(pt.x,0),100);
|
||
pt.y := ((Y-fPreviewSurface.top-GRAY_MARGIN)*100) div PrinterPxToScreenPxY(siz.y);
|
||
pt.y := min(max(pt.y,0),100);
|
||
// finally, adjust scrollbar positions based on click pos ...
|
||
with HorzScrollbar do position := (pt.x*(range-clientwidth)) div 100;
|
||
with VertScrollbar do position := (pt.y*(range-clientheight)) div 100;
|
||
finally
|
||
SendMessage(handle,WM_SETREDRAW,1,0);
|
||
end;
|
||
Invalidate;
|
||
end;
|
||
|
||
procedure TGDIPages.ZoomTimer(Sender: TObject);
|
||
var
|
||
CursorPos: TPoint;
|
||
begin
|
||
GetCursorPos(CursorPos);
|
||
CursorPos := ScreenToClient(CursorPos);
|
||
ZoomTimerInternal(CursorPos.x,CursorPos.y, fZoomIn);
|
||
end;
|
||
|
||
procedure TGDIPages.LineInternal(start, finish : integer; doubleline : boolean);
|
||
begin
|
||
LineInternal(fCurrentYPos + (GetLineHeight shr 1), start, finish, doubleline);
|
||
end;
|
||
|
||
procedure TGDIPages.LineInternal(aty, start, finish : integer; doubleline : boolean);
|
||
var Y: integer;
|
||
begin
|
||
if (Self <> nil) and (fCanvas <> nil) then
|
||
with fCanvas do begin
|
||
Pen.Width := MulDiv(fDefaultLineWidth, Self.Font.size, 8);
|
||
if fsBold in Self.Font.style then Pen.Width := Pen.Width + 1;
|
||
if doubleline then begin
|
||
Y := aty - (Pen.Width);
|
||
MoveTo(start, Y);
|
||
LineTo(finish, Y);
|
||
MoveTo(start, Y + (Pen.Width * 2));
|
||
LineTo(finish, Y + (Pen.Width * 2));
|
||
end else begin
|
||
Y := aty - (Pen.Width shr 1);
|
||
MoveTo(start, Y);
|
||
LineTo(finish, Y);
|
||
end;
|
||
end;
|
||
end;
|
||
|
||
procedure TGDIPages.PrintFormattedLine(s: SynUnicode; flags: integer;
|
||
const aBookmark: string; const aLink: string; withNewLine,aLinkNoBorder: boolean);
|
||
var i, xpos: integer;
|
||
leftOffset, rightOffset: integer;
|
||
begin
|
||
s := RightTrim(s);
|
||
i := pos(PAGENUMBER,LowerCaseU(s));
|
||
if i > 0 then begin
|
||
delete(s,i,14);
|
||
insert(UTF8ToSynUnicode(Int32ToUtf8(fVirtualPageNum)),s,i);
|
||
end;
|
||
if flags <> FORMAT_DEFAULT then
|
||
SetFontWithFlags(flags);
|
||
CheckYPos;
|
||
fCurrentTextTop := fCurrentYPos;
|
||
fCurrentTextPage := PageCount;
|
||
GetTextLimitsPx(leftOffset,rightOffset);
|
||
if flags and (FORMAT_SINGLELINE or FORMAT_DOUBLELINE)<>0 then begin
|
||
LineInternal(leftOffset,rightOffset,flags and FORMAT_DOUBLELINE=FORMAT_DOUBLELINE);
|
||
NewLine;
|
||
end else
|
||
if s = '' then begin
|
||
if withNewLine then
|
||
NewLine;
|
||
end else
|
||
if (flags and FORMAT_XPOS_MASK <> 0) then begin
|
||
xpos := ((flags and FORMAT_XPOS_MASK) shr 16)-2;
|
||
if xpos<0 then
|
||
xpos := RightMarginPos else
|
||
inc(xpos);
|
||
DrawTextAt(s,xpos);
|
||
end else
|
||
if (falign in [taLeft,taJustified]) then
|
||
LeftOrJustifiedWrap(s,withNewLine) else
|
||
RightOrCenterWrap(s);
|
||
if aBookmark<>'' then
|
||
AddBookMark(aBookmark,fCurrentTextTop);
|
||
if aLink<>'' then
|
||
AddLink(aLink,Rect(PrinterPxToMmX(leftOffset),PrinterPxToMmY(fCurrentTextTop),
|
||
PrinterPxToMmX(rightOffset),PrinterPxToMmY(fCurrentTextTop+fLineHeight)),
|
||
fCurrentTextPage,aLinkNoBorder);
|
||
// first line of written text is added
|
||
end;
|
||
|
||
procedure TGDIPages.LeftOrJustifiedWrap(const s: SynUnicode; withNewLine: boolean);
|
||
var indent, leftOffset, rightOffset, LineWidth: integer;
|
||
leftstring, rightstring: SynUnicode;
|
||
firstLoop: boolean;
|
||
begin
|
||
leftstring := s;
|
||
Indent := MmToPrinterPxX(fHangIndent);
|
||
firstLoop := true;
|
||
repeat
|
||
CheckYPos;
|
||
GetTextLimitsPx(leftOffset,rightOffset);
|
||
LineWidth := rightOffset-leftOffset;
|
||
|
||
// offset leftOffset if hang-indenting...
|
||
if Indent<>0 then
|
||
if firstLoop then begin
|
||
firstLoop := false;
|
||
if (Indent < 0) then begin
|
||
inc(leftOffset,-Indent);
|
||
dec(LineWidth,-Indent);
|
||
end;
|
||
end else
|
||
if (Indent > 0) and (Indent < LineWidth) then begin
|
||
inc(leftOffset,Indent);
|
||
dec(LineWidth,Indent);
|
||
end;
|
||
|
||
// dump overrun into rightstring...
|
||
TrimLine(fCanvas,leftstring,rightstring,LineWidth);
|
||
|
||
// HandleTabsAndPrint: prints leftstring after adjusting for tabs and
|
||
// prepending any further text overrun into rightstring ...
|
||
HandleTabsAndPrint(leftstring, rightstring, leftOffset, rightOffset);
|
||
if length(rightstring)=0 then
|
||
break;
|
||
leftstring := rightstring;
|
||
NewLine;
|
||
until false;
|
||
if withNewLine then
|
||
NewLine;
|
||
end;
|
||
|
||
procedure TGDIPages.RightOrCenterWrap(const s: SynUnicode);
|
||
var i,leftOffset,rightOffset, LineWidth: integer;
|
||
leftstring,rightstring: SynUnicode;
|
||
offset: integer;
|
||
begin
|
||
leftstring := s;
|
||
// remove tabs and replace by spaces
|
||
i := pos(#9,leftstring);
|
||
while i > 0 do begin
|
||
delete(leftstring,i,1);
|
||
insert(' ',leftstring,i);
|
||
i := pos(#9,leftstring);
|
||
end;
|
||
// write text
|
||
SetBkMode(fCanvas.Handle,TRANSPARENT);
|
||
repeat
|
||
GetTextLimitsPx(leftOffset,rightOffset);
|
||
LineWidth := rightOffset-leftOffset;
|
||
TrimLine(fCanvas,leftstring,rightstring,LineWidth);
|
||
case falign of
|
||
taRight: Offset := rightOffset-TextWidthC(fCanvas,leftstring)-1;
|
||
taCenter: Offset := leftOffset+
|
||
(rightOffset-leftOffset-TextWidthC(fCanvas,leftstring))div 2;
|
||
else Offset := 0; // should never happen - ?? add assert
|
||
end;
|
||
CheckYPos;
|
||
TextOut(fCanvas,Offset,fCurrentYPos,leftstring);
|
||
if length(rightstring) = 0 then break;
|
||
leftstring := rightstring;
|
||
NewLine;
|
||
until false;
|
||
NewLine;
|
||
end;
|
||
|
||
procedure TGDIPages.GetTextLimitsPx(var LeftOffset, RightOffset: integer);
|
||
begin
|
||
// Offsets (in Printer pixels) based on current page margins
|
||
LeftOffset := fPageMarginsPx.left;
|
||
if fForcedLeftOffset <> -1 then
|
||
leftOffset := fForcedLeftOffset;
|
||
RightOffset := fPhysicalSizePx.x-fPageMarginsPx.right;
|
||
if RightOffset < LeftOffset then
|
||
raise Exception.Create('GetTextLimitsPx: wrong margins');
|
||
end;
|
||
|
||
procedure TGDIPages.HandleTabsAndPrint(const leftstring: SynUnicode;
|
||
var rightstring: SynUnicode; leftOffset, rightOffset: integer);
|
||
const
|
||
// if a tabstop is very close to the right margin, it may spoil justifying...
|
||
MIN_CHAR_WIDTH_PX = 5;
|
||
var i, spacecount, linewidth, tabPos, tabIndex, PWLen: integer;
|
||
ls, rs: SynUnicode;
|
||
size: TSize;
|
||
PW: PWideChar;
|
||
begin
|
||
// handles tabs one at a time and prints text into the available space...
|
||
// (unfortunately there's no equivalent GetTextExtentExPoint() for tabbed text
|
||
// and using GetTabbedTextExtent() and TabbedDrawText() instead would appear
|
||
// to be undesirable as there's no efficient way to determine the number of
|
||
// chars that will fit within the specified space)
|
||
ls := leftstring;
|
||
linewidth := rightOffset - leftOffset;
|
||
tabPos := pos(#9,ls);
|
||
SetBkMode(fCanvas.Handle,TRANSPARENT);
|
||
while tabPos > 0 do begin // and still room to print
|
||
// split line at the tab ...
|
||
if rs <> '' then
|
||
rs := copy(ls,tabPos+1,length(ls)) + ' '+ rs else
|
||
rs := copy(ls,tabPos+1,length(ls));
|
||
// add a trailing space so next the tabstop is at least one space away ...
|
||
ls := copy(ls,1,tabPos-1)+' ';
|
||
// get offset of next tabstop ...
|
||
size := TextExtent(fCanvas,ls,tabPos);
|
||
i := leftOffset + size.cx; //minimum pos for next tabstop
|
||
tabIndex := 0;
|
||
while tabIndex < MAXTABS do
|
||
if fTab[tabIndex] > i then
|
||
break else
|
||
inc(tabIndex);
|
||
if (tabIndex = MAXTABS) or
|
||
(fTab[tabIndex] >= rightOffset - MIN_CHAR_WIDTH_PX) then begin
|
||
// no tabstop found to align 'rs' to, so ...
|
||
// rather than left aligning 'ls', remove its appended space and
|
||
// break out ready to print it ? align left&right justified.
|
||
SetLength(ls,length(ls)-1);
|
||
break;
|
||
end;
|
||
// tabstop found so DrawText 'ls' simply left aligned ...
|
||
TextOut(fCanvas,leftOffset,fCurrentYPos,ls);
|
||
leftOffset := fTab[tabIndex];
|
||
linewidth := rightOffset - leftOffset;
|
||
ls := rs;
|
||
TrimLine(fCanvas,ls,rs,linewidth);
|
||
tabPos := pos(#9,ls);
|
||
end;
|
||
if rs <> '' then
|
||
rightstring := rs + ' '+ rightstring;
|
||
|
||
// OK, no TABS now in ls...
|
||
InternalUnicodeString(ls,PW,PWLen,@size);
|
||
// print ls into (remaining) linewidth at (leftOffset, fCurrentYPos)
|
||
if (falign = taLeft) or (rightstring = '') then begin // left aligned
|
||
if BiDiMode=bdRightToLeft then
|
||
leftOffset := rightOffset-size.cx;
|
||
TextOut(fCanvas,leftOffset,fCurrentYPos,PW,PWLen);
|
||
fForcedLeftOffset := leftOffset+size.cx;
|
||
// don't care about line width: it should be always equal or smaller,
|
||
// and we are left aligned
|
||
end else begin // justified
|
||
spacecount := 0;
|
||
for i := 1 to length(ls) do
|
||
if ls[i] = ' ' then
|
||
inc(spacecount);
|
||
if spacecount>0 then
|
||
SetTextJustification(fCanvas.Handle, linewidth - size.cx, spacecount);
|
||
TextOut(fCanvas,leftOffset,fCurrentYPos,PW,PWLen);
|
||
SetTextJustification(fCanvas.Handle,0,0);
|
||
end;
|
||
end;
|
||
|
||
procedure TGDIPages.PreviewPaint(Sender: TObject);
|
||
var R: TRect;
|
||
P1,P2: TPoint;
|
||
metapage: TMetaFile;
|
||
begin
|
||
if csDesigning in ComponentState then begin // no preview at design time
|
||
R := fPreviewSurface.ClientRect;
|
||
fPreviewSurface.Canvas.Brush.Color := Color;
|
||
fPreviewSurface.Canvas.FillRect(R);
|
||
exit;
|
||
end;
|
||
if not Visible then begin
|
||
FreeAndNil(PreviewSurfaceBitmap);
|
||
exit;
|
||
end;
|
||
if PreviewSurfaceBitmap<>nil then
|
||
fPreviewSurface.Canvas.Draw(0,0,PreviewSurfaceBitmap) else
|
||
with fPreviewSurface do begin
|
||
// paint the page white with a dark gray line around it
|
||
R := ClientRect;
|
||
PreviewSurfaceBitmap := TBitmap.Create;
|
||
PreviewSurfaceBitmap.Width := R.Right;
|
||
PreviewSurfaceBitmap.Height := R.Bottom;
|
||
with PreviewSurfaceBitmap.Canvas do begin
|
||
Brush.Color := Color; // background color
|
||
FillRect(R);
|
||
InflateRect(R,-GRAY_MARGIN,-GRAY_MARGIN);
|
||
Brush.Color := clWhite;
|
||
Pen.Width := 1;
|
||
Pen.Color := clGray;
|
||
Rectangle(R);
|
||
Refresh;
|
||
end;
|
||
// draw the metafile on the page
|
||
if (fPages<>nil) and (cardinal(Page-1)<=cardinal(High(fPages))) and
|
||
(fPages[Page-1].MetaFileCompressed<>'') then begin
|
||
// note: we must use a temporary TMetaFile, otherwise the Pages[] content
|
||
// is changed (screen dpi is changed but not reset in nested emf) and the
|
||
// resulting report is incorrect on most printers, due to a driver bug :(
|
||
metapage := GetMetaFileForPage(Page-1);
|
||
{$ifdef GDIPLUSDRAW} // anti aliased drawing:
|
||
if not ForceNoAntiAliased then
|
||
DrawEmfGdip(PreviewSurfaceBitmap.Canvas.Handle,metapage,R,
|
||
ForceInternalAntiAliased,ForceInternalAntiAliasedFontFallBack) else
|
||
{$endif} // fast direct GDI painting, with no antialiaising:
|
||
PreviewSurfaceBitmap.Canvas.StretchDraw(R,metapage);
|
||
PreviewSurfaceBitmap.Canvas.Refresh;
|
||
end;
|
||
// draw the change page grey "arrow" buttons
|
||
if Page>1 then begin
|
||
P1.X := R.Left+10;
|
||
P2.X := R.Left+1;
|
||
PageLeftButton.X := P2.X;
|
||
P1.Y := R.Top+11;
|
||
P2.Y := P1.Y;
|
||
PageLeftButton.Y := P1.Y-10;
|
||
DrawArrowInternal(PreviewSurfaceBitmap.Canvas,P1,P2,10,true);
|
||
end else
|
||
PageLeftButton.X := 0;
|
||
if Page<PageCount then begin
|
||
P1.X := R.Right-10;
|
||
PageRightButton.X := P1.X;
|
||
P2.X := R.Right-1;
|
||
P1.Y := R.Top+11;
|
||
P2.Y := P1.Y;
|
||
PageRightButton.Y := P1.Y-10;
|
||
DrawArrowInternal(PreviewSurfaceBitmap.Canvas,P1,P2,10,true);
|
||
end else
|
||
PageRightButton.X := 0;
|
||
//draw the page shadows
|
||
R.Top := GRAY_MARGIN+3;
|
||
R.Left := ClientWidth-GRAY_MARGIN;
|
||
R.Bottom := ClientHeight-GRAY_MARGIN+3;
|
||
R.Right := R.Left+3;
|
||
PreviewSurfaceBitmap.Canvas.brush.color := clGray;
|
||
PreviewSurfaceBitmap.Canvas.FillRect(R);
|
||
R.Top := ClientHeight-GRAY_MARGIN;
|
||
R.Left := GRAY_MARGIN+3;
|
||
R.Bottom := R.Top+3;
|
||
R.Right := ClientWidth-GRAY_MARGIN+3;
|
||
PreviewSurfaceBitmap.Canvas.brush.color := clGray;
|
||
PreviewSurfaceBitmap.Canvas.FillRect(R);
|
||
Canvas.Draw(0,0,PreviewSurfaceBitmap)
|
||
end;
|
||
if fLinksCurrent>=0 then
|
||
fPreviewSurface.Canvas.DrawFocusRect(
|
||
TGDIPagereference(fLinks.Objects[fLinksCurrent]).Preview);
|
||
end;
|
||
|
||
procedure TGDIPages.PreviewMouseDown(Sender: TObject; Button: TMouseButton;
|
||
Shift: TShiftState; X, Y: Integer);
|
||
var i: integer;
|
||
begin
|
||
if Button=mbRight then begin
|
||
if PopupMenu<>nil then begin
|
||
with fPreviewSurface.ClientToScreen(Point(X,Y)) do
|
||
PopupMenu.Popup(X,Y);
|
||
exit;
|
||
end;
|
||
end else
|
||
if Button=mbLeft then begin
|
||
if fLinksCurrent>=0 then begin
|
||
fPreviewSurface.Canvas.DrawFocusRect(
|
||
TGDIPagereference(fLinks.Objects[fLinksCurrent]).Preview);
|
||
i := fLinksCurrent;
|
||
fLinksCurrent := -1;
|
||
GotoBookmark(fLinks[i]);
|
||
end else
|
||
if (PageLeftButton.X<>0) and
|
||
(cardinal(X-PageLeftButton.X)<10) and
|
||
(cardinal(Y-PageLeftButton.Y)<20) then begin
|
||
Page := Page-1;
|
||
exit;
|
||
end else
|
||
if (PageRightButton.X<>0) and
|
||
(cardinal(X-PageRightButton.X)<10) and
|
||
(cardinal(Y-PageRightButton.Y)<20) then begin
|
||
Page := Page+1;
|
||
exit;
|
||
end;
|
||
end;
|
||
if (Button=mbLeft) and (ssDouble in Shift) then
|
||
// allows dblclick to alternate between PAGE_FIT and PAGE_WIDTH
|
||
if ZoomStatus = zsPageWidth then
|
||
Zoom := PAGE_FIT else
|
||
Zoom := PAGE_WIDTH else
|
||
{$ifndef MOUSE_CLICK_PERFORM_ZOOM}
|
||
if Button=mbLeft then begin
|
||
fButtonDown.X := (X shr 3)shl 3; // move 8 pixels by 8 pixels
|
||
fButtonDown.Y := (Y shr 3)shl 3;
|
||
fButtonDownScroll.X := HorzScrollBar.Position;
|
||
fButtonDownScroll.Y := VertScrollBar.Position;
|
||
Screen.Cursor := crHandPoint;
|
||
end;
|
||
{$endif}
|
||
//pass the TPaintbox mouse-down event messages to Self (TScrollBox) ...
|
||
MouseDown(Button,Shift,X+fPreviewSurface.left,Y+fPreviewSurface.Top);
|
||
end;
|
||
|
||
procedure TGDIPages.PreviewMouseUp(Sender: TObject; Button: TMouseButton;
|
||
Shift: TShiftState; X, Y: Integer);
|
||
begin
|
||
//pass the TPaintbox mouse-up event messages to Self (TScrollBox) ...
|
||
MouseUp(Button,Shift,X+fPreviewSurface.left,Y+fPreviewSurface.Top);
|
||
end;
|
||
|
||
procedure TGDIPages.PreviewMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
|
||
{$ifndef MOUSE_CLICK_PERFORM_ZOOM}
|
||
var BX, V: integer;
|
||
{$endif}
|
||
var i: integer;
|
||
begin
|
||
fMousePos.X := X+fPreviewSurface.left;
|
||
fMousePos.Y := Y+fPreviewSurface.Top;
|
||
if fLinksCurrent>=0 then begin
|
||
fPreviewSurface.Canvas.DrawFocusRect(
|
||
TGDIPagereference(fLinks.Objects[fLinksCurrent]).Preview);
|
||
fLinksCurrent := -1;
|
||
end;
|
||
{$ifndef MOUSE_CLICK_PERFORM_ZOOM}
|
||
if fButtonDown.X>=0 then begin
|
||
X := (X shr 3)shl 3; // move 8 pixels by 8 pixels
|
||
Y := (Y shr 3)shl 3;
|
||
{ OutputDebugString(pointer(format(
|
||
'X=%d Y=%d ScrlIni X=%d Y=%d ScrlCurr X=%d Y=%d ',
|
||
[X,Y,fButtonDownScroll.X,fButtonDownScroll.Y,
|
||
HorzScrollBar.Position,VertScrollBar.Position]))); }
|
||
BX := fButtonDown.X;
|
||
fButtonDown.X := -1; // avoid endless recursive call
|
||
V := fButtonDownScroll.X-X+BX;
|
||
if (V>=0) and (HorzScrollBar.Position<>V) and (V<HorzScrollBar.Range) then begin
|
||
HorzScrollBar.Position := V;
|
||
fButtonDownScroll.X := V;
|
||
end;
|
||
V := fButtonDownScroll.Y-Y+fButtonDown.Y;
|
||
if (V>=0) and (VertScrollBar.Position<>V) and (V<VertScrollBar.Range) then begin
|
||
VertScrollBar.Position := V;
|
||
fButtonDownScroll.Y := V;
|
||
end;
|
||
fButtonDown.X := BX;
|
||
exit;
|
||
end else
|
||
{$endif}
|
||
for i := 0 to fLinks.Count-1 do
|
||
with TGDIPagereference(fLinks.Objects[i]) do
|
||
if (Page=Self.Page) and (X>=Preview.Left) and (X<Preview.Right) and
|
||
(Y>=Preview.Top) and (Y<Preview.Bottom) then begin
|
||
fLinksCurrent := i;
|
||
fPreviewSurface.Canvas.DrawFocusRect(Preview);
|
||
break;
|
||
end;
|
||
end;
|
||
|
||
procedure TGDIPages.CMFontChanged(var Msg: TMessage);
|
||
begin
|
||
inherited;
|
||
if Assigned(fCanvas) then
|
||
UpdateMetafileCanvasFont(fCanvas);
|
||
fLineHeight := 0; // force recalculation of lineheight
|
||
end;
|
||
|
||
procedure TGDIPages.WMGetDlgCode(var Message: TWMGetDlgCode);
|
||
begin
|
||
Message.Result := DLGC_WANTARROWS;
|
||
end;
|
||
|
||
procedure TGDIPages.KeyDown(var Key: Word; Shift: TShiftState);
|
||
|
||
procedure SetPageAndPosition(newpage,newpos: integer);
|
||
begin
|
||
perform(WM_SETREDRAW,0,0);
|
||
Page := newpage;
|
||
VertScrollbar.position := newpos;
|
||
perform(WM_SETREDRAW,1,0);
|
||
refresh;
|
||
end;
|
||
|
||
var
|
||
OldPosition,lh: integer;
|
||
begin
|
||
lh := PrinterPxToScreenPxY(GetLineHeight);
|
||
case Key of
|
||
VK_DOWN:
|
||
with VertScrollbar do begin
|
||
OldPosition := Position;
|
||
position := position + lh;
|
||
if (Position = OldPosition) and (Page < PageCount) then
|
||
SetPageAndPosition(Page+1,0);
|
||
end;
|
||
VK_UP:
|
||
with VertScrollbar do begin
|
||
OldPosition := Position;
|
||
position := position - lh;
|
||
if (Position = OldPosition) and (Page > 1) then
|
||
SetPageAndPosition(Page-1,range);
|
||
end;
|
||
VK_RIGHT:
|
||
with HorzScrollbar do
|
||
position := position + max(lh,0);
|
||
VK_LEFT:
|
||
with HorzScrollbar do
|
||
position := position - min(lh,range);
|
||
VK_NEXT:
|
||
with VertScrollbar do
|
||
if (shift = [ssCtrl]) and (Page < PageCount) then
|
||
SetPageAndPosition(PageCount,0)
|
||
else begin
|
||
OldPosition := Position;
|
||
position := position + max(clientheight - lh,0);
|
||
if (Position = OldPosition) and (Page < PageCount) then
|
||
SetPageAndPosition(Page+1,0);
|
||
end;
|
||
VK_PRIOR:
|
||
with VertScrollbar do begin
|
||
if (shift = [ssCtrl]) and (Page > 1) then
|
||
SetPageAndPosition(1,0)
|
||
else begin
|
||
OldPosition := Position;
|
||
position := position - max(clientheight-lh,0);
|
||
if (Position = OldPosition) and (Page > 1) then
|
||
SetPageAndPosition(Page-1,range);
|
||
end;
|
||
end;
|
||
VK_ADD, VK_SUBTRACT, 187, 189:
|
||
if ssCtrl in Shift then begin
|
||
fZoomIn := Key in [VK_ADD,187]; // Ctrl+ Ctrl- are standard zoom IN/OUT
|
||
ZoomTimer(nil);
|
||
end;
|
||
VK_ESCAPE:
|
||
if PreviewForm<>nil then
|
||
PreviewForm.Close; // ESC will close preview form (if any)
|
||
end;
|
||
inherited;
|
||
end;
|
||
|
||
procedure TGDIPages.CreateWnd;
|
||
begin
|
||
inherited CreateWnd;
|
||
// force page repositioning +/-resizing
|
||
case ZoomStatus of
|
||
zsPercent: ResizeAndCenterPaintbox;
|
||
zsPageWidth: zoom := PAGE_WIDTH;
|
||
else zoom := PAGE_FIT;
|
||
end;
|
||
end;
|
||
|
||
procedure TGDIPages.Resize;
|
||
begin
|
||
// force page repositioning +/-resizing
|
||
case ZoomStatus of
|
||
zsPercent: ResizeAndCenterPaintbox;
|
||
zsPageWidth: zoom := PAGE_WIDTH;
|
||
else zoom := PAGE_FIT;
|
||
end;
|
||
inherited Resize;
|
||
end;
|
||
|
||
procedure TGDIPages.MouseDown(Button: TMouseButton;
|
||
Shift: TShiftState; X, Y: Integer);
|
||
begin
|
||
{$ifdef MOUSE_CLICK_PERFORM_ZOOM}
|
||
// allow overriding of default mouse handling...
|
||
if not Assigned(OnMouseDown) then begin
|
||
fZoomIn := (Button = mbLeft);
|
||
ZoomTimerInternal(X, Y, fZoomIn);
|
||
fZoomTimer.Enabled := true;
|
||
end;
|
||
{$endif}
|
||
if Button=mbLeft then begin
|
||
if PopupMenu<>nil then begin
|
||
with fPreviewSurface do
|
||
if (X<Left) or (X>Left+Width) then
|
||
with Self.ClientToScreen(Point(X,Y)) do
|
||
Self.PopupMenu.Popup(X,Y);
|
||
end;
|
||
end;
|
||
if canfocus and not focused then
|
||
Setfocus;
|
||
inherited;
|
||
end;
|
||
|
||
procedure TGDIPages.MouseUp(Button: TMouseButton;
|
||
Shift: TShiftState; X, Y: Integer);
|
||
begin
|
||
{$ifdef MOUSE_CLICK_PERFORM_ZOOM}
|
||
fZoomTimer.enabled := false;
|
||
{$else}
|
||
fButtonDown.X := -1; // so MouseMove() won't scroll paintbox
|
||
Screen.Cursor := crDefault;
|
||
{$endif}
|
||
inherited;
|
||
end;
|
||
|
||
{$IFNDEF VER100}
|
||
function TGDIPages.DoMouseWheel(Shift: TShiftState; WheelDelta: Integer;
|
||
MousePos: TPoint): Boolean;
|
||
var key: word;
|
||
begin
|
||
//treat mousewheel events as if a down-arrow or up-arrow event ...
|
||
if Shift=[] then begin
|
||
if WheelDelta < 0 then
|
||
key := VK_DOWN else
|
||
key := VK_UP;
|
||
KeyDown(Key,[]);
|
||
end else
|
||
if Shift=[ssCtrl] then
|
||
ZoomTimerInternal(fMousePos.X,fMousePos.Y,(WheelDelta>0));
|
||
Result := true;
|
||
end;
|
||
{$ENDIF}
|
||
|
||
constructor TGDIPages.Create(AOwner: TComponent);
|
||
{$ifdef USEPDFPRINTER}
|
||
var i: integer;
|
||
aName: string;
|
||
{$endif}
|
||
begin
|
||
inherited Create(AOwner);
|
||
SetLength(fTab,MAXTABS);
|
||
{$ifndef WIN64} // Win64 gdiplus.dll raises some unexpected errors
|
||
ForceInternalAntiAliased := true; // GDI+ 1.1 ConvertToEmfPlus is buggy
|
||
{$endif}
|
||
PopupMenuClass := TPopupMenu;
|
||
// DoubleBuffered := true; // avoiding flicker is done in Paint method
|
||
Height := 150;
|
||
width := 200;
|
||
ControlStyle := ControlStyle - [csAcceptsControls];
|
||
if (AOWner<>nil) and AOWner.InheritsFrom(TCustomForm) then
|
||
Color := TCustomForm(AOwner).Color else
|
||
Color := clLtGray;
|
||
HorzScrollBar.Tracking := True;
|
||
VertScrollBar.Tracking := True;
|
||
tabstop := true;
|
||
|
||
Font.Name := 'Tahoma';
|
||
Font.Size := 12;
|
||
fLineSpacing := lsSingle;
|
||
fOrientation := poPortrait;
|
||
fUseOutlines := true;
|
||
|
||
fHeaderLines := TObjectList.Create;
|
||
fFooterLines := TObjectList.Create;
|
||
|
||
{$ifdef MOUSE_CLICK_PERFORM_ZOOM}
|
||
fZoomTimer := TTimer.create(Self);
|
||
fZoomTimer.Interval := 200;
|
||
fZoomTimer.OnTimer := ZoomTimer;
|
||
fZoomTimer.enabled := false;
|
||
{$else}
|
||
fButtonDown.X := -1; // so MouseMove() won't scroll paintbox
|
||
{$endif}
|
||
Int64(fCustomPxPerInch) := -1;
|
||
Int64(fCustomPageSize) := -1;
|
||
Int64(fCustomNonPrintableOffset) := -1;
|
||
Int64(fCustomPageMargins.TopLeft) := -1;
|
||
|
||
fHasPrinterInstalled := not (csDesigning in componentState)
|
||
and PrinterDriverExists;
|
||
{$ifdef USEPDFPRINTER}
|
||
fPDFPrinterIndex := -1;
|
||
if fHasPrinterInstalled then
|
||
for i := 0 to Printer.Printers.Count-1 do begin
|
||
aName := Printer.Printers[i];
|
||
if pos('doPDF',aName)=1 then begin
|
||
fPDFPrinterIndex := i;
|
||
break;
|
||
end else
|
||
if pos('PDF',aName)>0 then
|
||
fPDFPrinterIndex := i;
|
||
end;
|
||
fHasPDFPrinterInstalled := (fPDFPrinterIndex<>-1);
|
||
{$else}
|
||
fExportPDFUseFontFallBack := true;
|
||
fExportPDFEncryptionPermissions := PDF_PERMISSION_ALL;
|
||
fExportPDFEncryptionOwnerPassword := 'SynopsePDFEngine'+SYNOPSE_FRAMEWORK_VERSION;
|
||
{$endif}
|
||
GetPrinterParams; // necessary, but will also be updated in BeginDoc()
|
||
fCanvas := nil;
|
||
fPreviewSurface := TPagePaintbox.Create(Self);
|
||
fPreviewSurface.parent := Self;
|
||
fPreviewSurface.OnPaint := PreviewPaint;
|
||
fPreviewSurface.OnMouseDown := PreviewMouseDown;
|
||
fPreviewSurface.OnMouseUp := PreviewMouseUp;
|
||
fPreviewSurface.OnMouseMove := PreviewMouseMove;
|
||
fZoomStatus := zsPercent;
|
||
fZoom := 100;
|
||
fBookmarks := TStringList.Create;
|
||
fLinks := TStringList.Create;
|
||
fOutline := TStringList.Create;
|
||
fForcedLeftOffset := -1;
|
||
end;
|
||
|
||
destructor TGDIPages.Destroy;
|
||
begin
|
||
Clear;
|
||
fHeaderLines.free;
|
||
fFooterLines.free;
|
||
fPreviewSurface.free;
|
||
PreviewSurfaceBitmap.Free;
|
||
{$ifdef MOUSE_CLICK_PERFORM_ZOOM}
|
||
fZoomTimer.free;
|
||
{$endif}
|
||
fOutline.Free;
|
||
fLinks.Free;
|
||
fBookmarks.Free;
|
||
fMetaFileForPage.Free;
|
||
fCurrentMetaFile.Free;
|
||
inherited Destroy;
|
||
end;
|
||
|
||
procedure TGDIPages.Invalidate;
|
||
begin
|
||
FreeAndNil(PreviewSurfaceBitmap); // invalidate custom double buffering
|
||
inherited;
|
||
end;
|
||
|
||
procedure TGDIPages.BeginDoc;
|
||
begin
|
||
if Self=nil then exit; // avoid GPF
|
||
Clear;
|
||
GetPrinterParams; // essential as Printers.printer object may have changed
|
||
fHangIndent := 0;
|
||
fAlign := taLeft;
|
||
SetPageMargins(Rect(10,10,10,10));
|
||
fVirtualPageNum := 0;
|
||
Application.ProcessMessages;
|
||
NewPageInternal; // create a blank page
|
||
// preview resize in case Printers.printer object has changed
|
||
case ZoomStatus of
|
||
zsPercent: zoom := fzoom;
|
||
zsPageWidth: zoom := PAGE_WIDTH;
|
||
else zoom := PAGE_FIT;
|
||
end;
|
||
fButtonDown.X := -1; // so MouseMove() won't scroll paintbox
|
||
end;
|
||
|
||
procedure TGDIPages.DrawText(const s: string; withNewLine : boolean);
|
||
begin
|
||
DrawTextW(StringToSynUnicode(s), withNewLine);
|
||
end;
|
||
|
||
procedure TGDIPages.DrawTextW(const s: SynUnicode; withNewLine: boolean);
|
||
var P, Start: PWideChar;
|
||
tmpStr: SynUnicode;
|
||
begin
|
||
if Self=nil then exit;
|
||
CheckYPos;
|
||
if s = '' then begin
|
||
if withNewLine then
|
||
NewLine;
|
||
end else begin
|
||
// split NewLine characters (#13 or #13#10) into multi lines
|
||
P := pointer(s);
|
||
while P^ <> #0 do begin
|
||
Start := P;
|
||
while not (ord(P^) in [0, 10, 13]) do Inc(P);
|
||
SetString(tmpStr, Start, P-Start);
|
||
if not fInHeaderOrFooter then
|
||
fCanvasText := fCanvasText+SynUnicodeToString(tmpStr)+#13#10;
|
||
PrintFormattedLine(tmpStr, FORMAT_DEFAULT, '', '', withNewLine);
|
||
if P^ = #13 then Inc(P);
|
||
if P^ = #10 then Inc(P);
|
||
end;
|
||
end;
|
||
end;
|
||
|
||
procedure TGDIPages.DrawTextU(const s: RawUTF8; withNewLine: boolean);
|
||
begin
|
||
DrawTextW(UTF8ToSynUnicode(s),withNewLine);
|
||
end;
|
||
|
||
procedure TGDIPages.DrawTitle(const s: SynUnicode; DrawBottomLine: boolean;
|
||
OutlineLevel: Integer; const aBookmark,aLink: string; aLinkNoBorder: boolean);
|
||
var H: integer;
|
||
str: string;
|
||
begin
|
||
if Self=nil then exit; // avoid GPF
|
||
CheckYPos;
|
||
SaveLayout;
|
||
try
|
||
str := SynUnicodeToString(s);
|
||
if not fInHeaderOrFooter then
|
||
fCanvasText := fCanvasText+str+#13#10; // copy as text
|
||
PrintFormattedLine(s,TitleFlags,aBookMark,aLink,true,aLinkNoBorder);
|
||
if UseOutlines then
|
||
AddOutline(str,OutlineLevel,fCurrentTextTop,fCurrentTextPage);
|
||
if DrawBottomLine then begin
|
||
H := (GetLineHeight*15) shr 5;
|
||
dec(fCurrentYPos, H);
|
||
LineInternal(fPageMarginsPx.left, fPhysicalSizePx.x-fPageMarginsPx.right, false);
|
||
inc(fCurrentYPos, H*2);
|
||
end;
|
||
finally
|
||
RestoreSavedLayout;
|
||
end;
|
||
end;
|
||
|
||
procedure TGDIPages.DrawTextAt(s: SynUnicode; XPos: integer; const aLink: string;
|
||
CheckPageNumber,aLinkNoBorder: boolean);
|
||
var i: integer;
|
||
R: TRect;
|
||
Size: TSize;
|
||
begin
|
||
if (Self=nil) or (s='') then exit;
|
||
CheckYPos;
|
||
if CheckPageNumber then begin
|
||
i := pos(PAGENUMBER,LowerCaseU(s));
|
||
if i > 0 then begin
|
||
Delete(s,i,14);
|
||
Insert(UTF8ToSynUnicode(Int32ToUtf8(fVirtualPageNum)),s,i);
|
||
end;
|
||
end;
|
||
SetBkMode(fCanvas.Handle,TRANSPARENT);
|
||
Size := TextExtent(fCanvas,s);
|
||
R.Left := MmToPrinterPxX(XPos);
|
||
case falign of
|
||
taRight: dec(R.Left,Size.cx+1);
|
||
taCenter: dec(R.Left,Size.cx shr 1+1);
|
||
end;
|
||
R.Top := fCurrentYPos;
|
||
TextOut(fCanvas,R.Left,R.Top,s);
|
||
if not fInHeaderOrFooter then // copy as text on a new line
|
||
fCanvasText := fCanvasText+SynUnicodeToString(s)+#13#10;
|
||
if aLink<>'' then begin
|
||
R.Right := R.Left+Size.cx;
|
||
R.Bottom := R.Top+Size.cy;
|
||
AddLink(aLink,PrinterToMM(R),0,aLinkNoBorder);
|
||
end;
|
||
end;
|
||
|
||
procedure TGDIPages.DrawAngledTextAt(const s: SynUnicode; XPos, Angle: integer);
|
||
var
|
||
lf: TLogFont;
|
||
OldFontHdl,NewFontHdl: HFont;
|
||
begin
|
||
if (s='') or (Self=nil) then exit; // avoid GPF
|
||
CheckYPos;
|
||
XPos := MmToPrinterPxX(XPos);
|
||
SetBkMode(fCanvas.Handle,TRANSPARENT);
|
||
with fCanvas do begin
|
||
if GetObject(Font.Handle, SizeOf(lf), @lf) = 0 then exit;
|
||
lf.lfEscapement := Angle * 10;
|
||
lf.lfOrientation := Angle * 10;
|
||
lf.lfOutPrecision := OUT_TT_ONLY_PRECIS;
|
||
NewFontHdl := CreateFontIndirect(lf);
|
||
OldFontHdl := selectObject(handle,NewFontHdl);
|
||
end;
|
||
TextOut(fCanvas,XPos,fCurrentYPos,s);
|
||
selectObject(fCanvas.handle,OldFontHdl);
|
||
DeleteObject(NewFontHdl);
|
||
if not fInHeaderOrFooter then
|
||
fCanvasText := fCanvasText+s+#13#10; // copy as text on a new line
|
||
end;
|
||
|
||
function TGDIPages.MmToPrinter(const R: TRect): TRect;
|
||
begin
|
||
if Self=nil then begin
|
||
FillChar(result,sizeof(result),0);
|
||
exit; // avoid GPF
|
||
end;
|
||
result.left := MmToPrinterPxX(R.left);
|
||
result.top := MmToPrinterPxY(R.top);
|
||
result.right := MmToPrinterPxX(R.right);
|
||
result.bottom := MmToPrinterPxY(R.bottom);
|
||
end;
|
||
|
||
function TGDIPages.PrinterToMM(const R: TRect): TRect;
|
||
begin
|
||
if Self=nil then begin
|
||
FillChar(result,sizeof(result),0);
|
||
exit; // avoid GPF
|
||
end;
|
||
result.left := PrinterPxToMmX(R.left);
|
||
result.top := PrinterPxToMmY(R.top);
|
||
result.right := PrinterPxToMmX(R.right);
|
||
result.bottom := PrinterPxToMmY(R.bottom);
|
||
end;
|
||
|
||
procedure TGDIPages.DrawBox(left,top,right,bottom: integer);
|
||
begin
|
||
if Self=nil then exit; // avoid GPF
|
||
CheckHeaderDone;
|
||
left := MmToPrinterPxX(left);
|
||
top := MmToPrinterPxY(top);
|
||
right := MmToPrinterPxX(right);
|
||
bottom := MmToPrinterPxY(bottom);
|
||
with fCanvas do begin
|
||
Pen.Width := MulDiv(fDefaultLineWidth,Self.Font.Size,8);
|
||
if fsBold in Self.Font.style then
|
||
Pen.Width := Pen.Width +1;
|
||
MoveTo(left,top);
|
||
LineTo(right,top);
|
||
LineTo(right,bottom);
|
||
LineTo(left,bottom);
|
||
LineTo(left,top);
|
||
end;
|
||
end;
|
||
|
||
procedure TGDIPages.DrawBoxFilled(left,top,right,bottom: integer; Color: TColor);
|
||
var SavedBrushColor: TColor;
|
||
begin
|
||
if Self=nil then exit; // avoid GPF
|
||
CheckHeaderDone;
|
||
left := MmToPrinterPxX(left);
|
||
top := MmToPrinterPxY(top);
|
||
right := MmToPrinterPxX(right);
|
||
bottom := MmToPrinterPxY(bottom);
|
||
with fCanvas do begin
|
||
Pen.Width := MulDiv(fDefaultLineWidth,Self.Font.Size,8);
|
||
if fsBold in Self.Font.style then
|
||
Pen.Width := Pen.Width +1;
|
||
SavedBrushColor := Brush.Color;
|
||
brush.Color := Color;
|
||
rectangle(left,top,right,bottom);
|
||
Brush.Color := SavedBrushColor;
|
||
end;
|
||
end;
|
||
|
||
procedure TGDIPages.DrawBMP(rec: TRect; bmp: TBitmap);
|
||
begin
|
||
if Self=nil then exit; // avoid GPF
|
||
CheckHeaderDone;
|
||
PrintBitmap(fCanvas, MmToPrinter(rec), bmp);
|
||
end;
|
||
|
||
procedure TGDIPages.DrawBMP(bmp: TBitmap; bLeft, bWidth: integer; const Legend: string);
|
||
begin
|
||
DrawGraphic(bmp,bLeft,bWidth,Legend);
|
||
end;
|
||
|
||
procedure TGDIPages.DrawGraphic(graph: TGraphic; bLeft, bWidth: integer;
|
||
const Legend: SynUnicode);
|
||
var R: TRect;
|
||
H: Integer;
|
||
begin
|
||
if (self=nil) or (graph=nil) or graph.Empty then
|
||
exit; // avoid GPF
|
||
// compute position and draw bitmap
|
||
if bLeft=maxInt then // do center
|
||
bLeft := PrinterPxToMmX(fPageMarginsPx.Left+
|
||
(fPhysicalSizePx.x-fPageMarginsPx.Right-fPageMarginsPx.Left-MmToPrinterPxX(bWidth))shr 1) else
|
||
inc(bLeft,LeftMargin);
|
||
R.Left := bLeft;
|
||
R.Right := bLeft+bWidth;
|
||
R.Bottom := (graph.Height*bWidth) div graph.Width;
|
||
if Legend<>'' then
|
||
H := LineHeight else
|
||
H := 0;
|
||
if not HasSpaceFor(R.Bottom+H) then begin
|
||
NewPage;
|
||
DoHeader;
|
||
NewHalfLine;
|
||
end;
|
||
R.Top := CurrentYPos;
|
||
Inc(R.Bottom,R.Top);
|
||
if graph.InheritsFrom(TBitmap) then
|
||
DrawBMP(R,graph as TBitmap) else
|
||
if graph.InheritsFrom(TMetaFile) then
|
||
DrawMeta(R,graph as TMetaFile);
|
||
CurrentYPos := R.Bottom;
|
||
// draw optional caption bottom
|
||
if Legend<>'' then begin
|
||
SaveLayout;
|
||
TextAlign := taCenter;
|
||
Font.Style := [];
|
||
Font.Size := (Font.Size*3)shr 2; // smaller font for caption text
|
||
DrawTextW(Legend);
|
||
RestoreSavedLayout;
|
||
end else
|
||
NewHalfLine;
|
||
end;
|
||
|
||
procedure TGDIPages.DrawMeta(rec: TRect; meta: TMetafile);
|
||
var old: Integer;
|
||
begin
|
||
if Self=nil then exit; // avoid GPF
|
||
CheckHeaderDone;
|
||
rec := MmToPrinter(rec);
|
||
old := SaveDC(fCanvas.Handle); // ensure safe metafile embedding
|
||
PlayEnhMetaFile(fCanvas.Handle, meta.Handle, rec);
|
||
RestoreDC(fCanvas.Handle,old);
|
||
end;
|
||
|
||
procedure TGDIPages.DrawArrow(Point1, Point2: TPoint;
|
||
HeadSize: integer; SolidHead: boolean);
|
||
begin
|
||
if Self=nil then exit; // avoid GPF
|
||
CheckHeaderDone;
|
||
Point1.X := MmToPrinterPxX(Point1.X);
|
||
Point1.Y := MmToPrinterPxY(Point1.Y);
|
||
Point2.X := MmToPrinterPxX(Point2.X);
|
||
Point2.Y := MmToPrinterPxY(Point2.Y);
|
||
HeadSize := MmToPrinterPxX(max(HeadSize,0));
|
||
fCanvas.Pen.Width := MulDiv(fDefaultLineWidth,Self.Font.Size, 8);
|
||
DrawArrowInternal(fCanvas, Point1, Point2, HeadSize, SolidHead);
|
||
end;
|
||
|
||
procedure TGDIPages.DrawLine(doubleline: boolean);
|
||
begin
|
||
if Self=nil then exit; // avoid GPF
|
||
CheckHeaderDone;
|
||
LineInternal(fPageMarginsPx.left, fPhysicalSizePx.x-fPageMarginsPx.right, doubleline);
|
||
NewLine;
|
||
end;
|
||
|
||
procedure TGDIPages.DrawDashedLine;
|
||
var
|
||
Y: integer;
|
||
begin
|
||
if Self=nil then exit; // avoid GPF
|
||
CheckHeaderDone;
|
||
with fCanvas do
|
||
begin
|
||
Pen.Width := 1;
|
||
Pen.Style := psDash;
|
||
Y := fCurrentYPos + (GetLineHeight shr 1) - (Pen.Width shr 1);
|
||
MoveTo(fPageMarginsPx.left, Y);
|
||
LineTo(fPhysicalSizePx.x-fPageMarginsPx.right, Y);
|
||
Pen.Style := psSolid;
|
||
end;
|
||
NewLine;
|
||
end;
|
||
|
||
procedure TGDIPages.DrawColumnLine(ColIndex: integer; aAtTop: boolean;
|
||
aDoDoubleLine: boolean);
|
||
var Y: integer;
|
||
begin
|
||
if aAtTop then
|
||
Y := fCurrentYPos - 1 else
|
||
Y := fCurrentYPos + fLineHeight + 1;
|
||
with fColumns[ColIndex] do
|
||
LineInternal(Y, ColLeft, ColRight, aDoDoubleLine);
|
||
end;
|
||
|
||
procedure TGDIPages.NewLine;
|
||
begin
|
||
if Self=nil then exit; // avoid GPF
|
||
CheckHeaderDone;
|
||
inc(fCurrentYPos, GetLineHeight);
|
||
fForcedLeftOffset := -1;
|
||
// fCanvasText := fCanvasText+#13#10;
|
||
end;
|
||
|
||
procedure TGDIPages.NewHalfLine;
|
||
begin
|
||
if Self=nil then exit; // avoid GPF
|
||
CheckHeaderDone;
|
||
inc(fCurrentYPos, GetLineHeight shr 1);
|
||
// fCanvasText := fCanvasText+#13#10;
|
||
end;
|
||
|
||
procedure TGDIPages.NewLines(count: integer);
|
||
begin
|
||
if Self=nil then exit; // avoid GPF
|
||
CheckHeaderDone;
|
||
if count < 1 then exit;
|
||
inc(fCurrentYPos, GetLineHeight* count);
|
||
// fCanvasText := fCanvasText+#13#10;
|
||
end;
|
||
|
||
procedure TGDIPages.NewPage(ForceEndGroup: boolean);
|
||
begin
|
||
if Self=nil then exit; // avoid GPF
|
||
if ForceEndGroup then
|
||
EndGroup else
|
||
if Assigned(fGroupPage) then
|
||
raise Exception.Create('Cannot call NewPage within a group block.');
|
||
CheckHeaderDone;
|
||
NewPageInternal;
|
||
end;
|
||
|
||
procedure TGDIPages.NewPageIfAnyContent;
|
||
begin
|
||
if Self=nil then exit; // avoid GPF
|
||
if fHeaderDone then
|
||
NewPage;
|
||
end;
|
||
|
||
procedure TGDIPages.BeginGroup;
|
||
begin
|
||
if Self=nil then exit; // avoid GPF
|
||
if not fHeaderDone then exit; // i.e. haven't even started a page yet
|
||
if Assigned(fGroupPage) then
|
||
raise Exception.create('Group already started!');
|
||
|
||
if not GroupsMustBeOnSamePage then begin
|
||
// Group "light" implementation
|
||
if fHeaderDone and not HasSpaceForLines(20) then
|
||
NewPageInternal;
|
||
exit;
|
||
end;
|
||
|
||
//make sure there's room for at least 2 lines otherwise just start a new page
|
||
//(a group surely contains at least 2 lines )
|
||
if not HasSpaceForLines(2) then begin
|
||
NewPageInternal;
|
||
exit;
|
||
end;
|
||
fGroupVerticalSpace :=
|
||
fPhysicalSizePx.y - fCurrentYPos - fPageMarginsPx.bottom - fFooterHeight;
|
||
fColumnsUsedInGroup := false;
|
||
fColumnHeaderInGroup := false;
|
||
if Assigned(fCanvas) then
|
||
FreeAndNil(fCanvas);
|
||
fGroupPage := CreateMetaFile(fPhysicalSizePx.x,fGroupVerticalSpace + fPhysicalOffsetPx.Y);
|
||
fCanvas := CreateMetafileCanvas(fGroupPage);
|
||
fGroupVerticalPos := fCurrentYPos;
|
||
fCurrentYPos := 0;
|
||
fBeforeGroupText := fCanvasText;
|
||
fCanvasText := '';
|
||
end;
|
||
|
||
procedure TGDIPages.EndGroup;
|
||
begin
|
||
if Self=nil then exit; // avoid GPF
|
||
if not Assigned(fGroupPage) then
|
||
exit;
|
||
FreeAndNil(fCanvas); //closes fGroupPage canvas
|
||
fCanvas := CreateMetafileCanvas(fCurrentMetaFile);
|
||
fCanvas.Draw(0,0,fCurrentMetaFile); //re-draw the last page
|
||
fCanvas.Draw(0,fGroupVerticalPos,fGroupPage); //add the Group data
|
||
FreeAndNil(fGroupPage); //destroy Group metafile
|
||
inc(fCurrentYPos,fGroupVerticalPos);
|
||
fCanvasText := fBeforeGroupText+fCanvasText;
|
||
fBeforeGroupText := '';
|
||
end;
|
||
|
||
function TGDIPages.CurrentGroupPosStart: integer;
|
||
begin
|
||
if Self=nil then
|
||
result := 0 else begin
|
||
if Assigned(fGroupPage) then
|
||
result := fGroupVerticalPos else
|
||
result := fPageMarginsPx.top;
|
||
result := PrinterPXtoMmY(result);
|
||
end;
|
||
end;
|
||
|
||
function GetNextItemW(var P: PWideChar): SynUnicode;
|
||
var S: PWideChar;
|
||
begin
|
||
if P=nil then
|
||
result := '' else begin
|
||
S := P;
|
||
while (S^<>#0) and (S^<>',') do
|
||
inc(S);
|
||
SetString(result,P,S-P);
|
||
if S^<>#0 then
|
||
P := S+1 else
|
||
P := nil;
|
||
end;
|
||
end;
|
||
|
||
function GetNextItemS(var P: PChar): string;
|
||
var S: PChar;
|
||
begin
|
||
if P=nil then
|
||
result := '' else begin
|
||
S := P;
|
||
while (S^<>#0) and (S^<>',') do
|
||
inc(S);
|
||
SetString(result,P,S-P);
|
||
if S^<>#0 then
|
||
P := S+1 else
|
||
P := nil;
|
||
end;
|
||
end;
|
||
|
||
const // zoom percentages for popup menu entries
|
||
MenuZoom: array[0..6] of byte = (25,50,75,100,125,150,200);
|
||
|
||
procedure TGDIPages.EndDoc;
|
||
var PC: PChar;
|
||
i, n, aX: integer;
|
||
Men: TGdiPagePreviewButton;
|
||
M, Root: TMenuItem;
|
||
Page: TMetaFile;
|
||
s: string;
|
||
begin
|
||
if Self=nil then exit; // avoid GPF
|
||
fLinksCurrent := -1;
|
||
EndGroup;
|
||
DoFooter;
|
||
if Assigned(fCanvas) then
|
||
FreeAndNil(fCanvas);
|
||
n := length(fPages);
|
||
if (n>1) and not HeaderDone then begin
|
||
// cancel the last page if it hasn't been started ...
|
||
FreeAndNil(fCurrentMetaFile);
|
||
dec(n);
|
||
SetLength(fPages,n);
|
||
end else
|
||
FlushPageContent;
|
||
if (n>0) and (fPagesToFooterText<>'') then
|
||
// add 'Page #/#' caption at the specified position
|
||
for i := 0 to n-1 do begin
|
||
Page := CreateMetaFile(fPages[i].SizePx.X,fPages[i].SizePx.Y);
|
||
try
|
||
fCanvas := CreateMetafileCanvas(Page);
|
||
fCanvas.Draw(0,0,GetMetaFileForPage(i)); // re-draw the original page
|
||
s := format(fPagesToFooterText,[i+1,n]); // add 'Page #/#' caption
|
||
aX := fPagesToFooterAt.X;
|
||
if aX<0 then
|
||
aX := fPages[i].SizePx.X-fPages[i].MarginPx.Right;
|
||
SavedState := fPagesToFooterState;
|
||
if TextAlign=taRight then
|
||
dec(aX,fCanvas.TextWidth(s));
|
||
with fPages[i] do
|
||
fCanvas.TextOut(aX,SizePx.Y-MarginPx.bottom-fFooterHeight+
|
||
fFooterGap+fPagesToFooterAt.Y,s);
|
||
FreeAndNil(fCanvas);
|
||
SetMetaFileForPage(i,Page); // replace page content
|
||
finally
|
||
Page.Free;
|
||
end;
|
||
end;
|
||
// OK, all Metafile pages have now been created and added to Pages[]
|
||
if Assigned(fOnDocumentProducedEvent) then
|
||
fOnDocumentProducedEvent(Self); // notify report just generated
|
||
fCurrPreviewPage := 1;
|
||
if Assigned(fPreviewPageChangedEvent) then
|
||
fPreviewPageChangedEvent(Self); // notify page changed
|
||
Invalidate;
|
||
// update popup menu content
|
||
if PopupMenu=nil then // caller may have created a TPopupMenu instance
|
||
PopupMenu := PopupMenuClass.Create(Self) else
|
||
PopupMenu.Items.Clear;
|
||
PopupMenu.OnPopup := PopupMenuPopup;
|
||
PC := pointer(string(sReportPopupMenu1));
|
||
// 'Next,Previous,GotoPage,Zoom,Bookmarks,CopyasText,Print,PDF,Close,Pagefit,Pagewidth'
|
||
for Men := rNextPage to rClose do
|
||
NewPopupMenuItem(GetNextItemS(PC),-ord(Men)).Enabled :=
|
||
(Men<rPrint) or (Men=rClose) or
|
||
( (Men=rPrint) and fHasPrinterInstalled) or
|
||
( (Men=rExportPDF) {$ifdef USEPDFPRINTER}and fHasPDFPrinterInstalled{$endif});
|
||
PopupMenu.Items[ord(rClose)-1].Visible := false;
|
||
M := PopupMenu.Items[ord(rZoom)-1];
|
||
NewPopupMenuItem(GetNextItemS(PC),-1000-PAGE_FIT,M);
|
||
NewPopupMenuItem(GetNextItemS(PC),-1000-PAGE_WIDTH,M);
|
||
for i := 0 to high(MenuZoom) do
|
||
NewPopupMenuItem(format('%d %%',[MenuZoom[i]]),-1000-MenuZoom[i],M);
|
||
Root := PopupMenu.Items[ord(rBookmarks)-1];
|
||
if UseOutlines and (fOutline.Count>0) then begin
|
||
Root.Enabled := true;
|
||
M := Root;
|
||
for i := 0 to fOutline.Count-1 do
|
||
with TGDIPagereference(fOutline.Objects[i]) do begin
|
||
while (M<>Root) and (cardinal(-2000-M.Tag)<cardinal(fOutline.Count)) and
|
||
(Rect.Bottom<=TGDIPagereference(fOutline.Objects[-2000-M.Tag]).Rect.Bottom) do
|
||
M := M.Parent;
|
||
M := NewPopupMenuItem(fOutline[i],-2000-i,M);
|
||
end;
|
||
end else
|
||
Root.Enabled := false;
|
||
end;
|
||
|
||
function TGDIPages.PrintPages(PrintFrom, PrintTo: integer): boolean;
|
||
var i: integer;
|
||
rec: TRect;
|
||
CheckCurrentPtr: string;
|
||
UseStretchDraw: boolean;
|
||
BMP: TBitmap;
|
||
begin
|
||
result := false;
|
||
if Self=nil then exit; // avoid GPF
|
||
if not fHasPrinterInstalled then
|
||
raise Exception.Create('No printer driver is currently installed.');
|
||
if PrintFrom<0 then
|
||
with TPrintDialog.Create(nil) do
|
||
try
|
||
Options := [poPageNums];
|
||
MinPage := 1;
|
||
MaxPage := PageCount;
|
||
FromPage := 1;
|
||
ToPage := PageCount;
|
||
if not Execute then
|
||
exit;
|
||
PrintFrom := FromPage;
|
||
PrintTo := ToPage;
|
||
finally
|
||
Free;
|
||
end;
|
||
result := true;
|
||
// ideally, the user has changed printers BEFORE generating a report, but
|
||
// if they want a report sent to a different printer then use StretchDraw ...
|
||
CheckCurrentPtr := CurrentPrinterName;
|
||
if CheckCurrentPtr <> fCurrentPrinter then begin
|
||
GetPrinterParams; // also updates fCurrentPrinter
|
||
UseStretchDraw := true;
|
||
end else
|
||
UseStretchDraw := false;
|
||
PrintFrom := max(PrintFrom-1,0);
|
||
if PrintTo=0 then
|
||
PrintTo := high(fPages) else
|
||
PrintTo := min(PrintTo-1,high(fPages));
|
||
{$ifdef PRINTERNEW} // set enhanced TPrinterNew class color/BW or duplex mode
|
||
with PrinterNew do begin
|
||
if ForcePrintColorMode<>printColorDefault then begin
|
||
if (ForcePrintColorMode=printColor) and HasColorMode then
|
||
ColorMode := true else
|
||
if ForcePrintColorMode=printBW then
|
||
ColorMode := false;
|
||
end;
|
||
if ForcePrintDuplexMode<>printDuplexDefault then begin
|
||
if (ForcePrintDuplexMode=printDuplex) and HasDuplexMode then
|
||
DuplexMode := true else
|
||
if ForcePrintDuplexMode=printSimplex then
|
||
DuplexMode := false;
|
||
end;
|
||
{$else}
|
||
with Printer do begin
|
||
{$endif}
|
||
if Caption='' then
|
||
{$ifndef USEPDFPRINTER}
|
||
if ExportPDFApplication<>'' then
|
||
Title := ExportPDFApplication else
|
||
{$endif}
|
||
Title := Application.Title else
|
||
Title := Caption;
|
||
Orientation := Self.Orientation; // just in case fPrinter changed
|
||
BeginDoc;
|
||
try
|
||
Screen.Cursor := crHourGlass;
|
||
if ForcePrintAsBitmap then begin // very slow printing
|
||
BMP := TBitmap.Create;
|
||
try
|
||
BMP.Width := GetDeviceCaps(handle, PHYSICALWIDTH);
|
||
BMP.Height := GetDeviceCaps(handle, PHYSICALHEIGHT);
|
||
for i := PrintFrom to PrintTo do
|
||
with fPages[i] do begin
|
||
BMP.Canvas.StretchDraw(Rect(0,0,Bmp.Width,Bmp.Height),GetMetaFileForPage(i));
|
||
Canvas.Draw(-OffsetPx.x,-OffsetPx.y,BMP);
|
||
if i<PrintTo then
|
||
NewPage;
|
||
end;
|
||
finally
|
||
BMP.Free;
|
||
end;
|
||
end else
|
||
for i := PrintFrom to PrintTo do begin
|
||
// nb: the printer's page origin is fPhysicalOffsetPx so it's
|
||
// necessary to offset our rect by -OffsetPx ...
|
||
if ForceScreenResolution then begin
|
||
rec := Rect(0, 0, GetDeviceCaps(handle, PHYSICALWIDTH),
|
||
GetDeviceCaps(handle, PHYSICALHEIGHT));
|
||
OffsetRect(rec, -GetDeviceCaps(handle,PHYSICALOFFSETX),
|
||
-GetDeviceCaps(handle,PHYSICALOFFSETY));
|
||
Canvas.StretchDraw(rec,GetMetaFileForPage(i));
|
||
end else
|
||
with fPages[i] do
|
||
if UseStretchDraw then
|
||
Canvas.StretchDraw(Rect(-OffsetPx.x,-OffsetPx.y,
|
||
SizePx.x-OffsetPx.x, SizePx.y-OffsetPx.y),GetMetaFileForPage(i)) else
|
||
Canvas.Draw(-OffsetPx.x,-OffsetPx.y,GetMetaFileForPage(i));
|
||
if i<PrintTo then
|
||
NewPage;
|
||
end;
|
||
EndDoc;
|
||
finally
|
||
Screen.Cursor := crDefault;
|
||
end;
|
||
end;
|
||
end;
|
||
|
||
|
||
procedure TGDIPages.SetTabStops(const tabs: array of integer);
|
||
var i: integer;
|
||
begin
|
||
if Self=nil then exit; // avoid GPF
|
||
FillChar(fTab[0],MAXTABS*sizeof(fTab[0]),0);
|
||
fTabCount := min(high(tabs)+1,MAXTABS);
|
||
//ignore trailing 0 tabs in array ...
|
||
if (fTabCount > 0) then
|
||
while (fTabCount > 0) and (tabs[fTabCount-1] = 0) do
|
||
dec(fTabCount);
|
||
|
||
if (fTabCount > 1) then begin
|
||
if (tabs[0] <= 0) then
|
||
raise Exception.Create('Tabs stops must be greater than 0.');
|
||
fTab[0] := MmToPrinterPxX(tabs[0]);
|
||
for i := 1 to fTabCount -1 do
|
||
if tabs[i] > tabs[i-1] then
|
||
fTab[i] := MmToPrinterPxX(tabs[i]) else
|
||
raise Exception.Create('Tabs stops must be in ascending order');
|
||
end else
|
||
if fTabCount = 1 then begin
|
||
//if one tab set then use that tab as the interval for subsequent tabs
|
||
for i := 0 to MAXTABS-1 do
|
||
fTab[i] := MmToPrinterPxX((i+1)*tabs[0]);
|
||
fTabCount := MAXTABS;
|
||
end else begin
|
||
//if no tabs set then default to tabs every 20mm
|
||
for i := 0 to MAXTABS-1 do fTab[i] := MmToPrinterPxX((i+1)*20);
|
||
fTabCount := MAXTABS;
|
||
end;
|
||
end;
|
||
|
||
|
||
function TGDIPages.GetPageMargins: TRect;
|
||
begin
|
||
if Self=nil then
|
||
FillChar(result,sizeof(result),0) else
|
||
with result do begin
|
||
Left := PrinterPxToMmX(fPageMarginsPx.left);
|
||
Top := PrinterPxToMmY(fPageMarginsPx.top);
|
||
Right := PrinterPxToMmX(fPageMarginsPx.right);
|
||
Bottom := PrinterPxToMmY(fPageMarginsPx.bottom);
|
||
end;
|
||
end;
|
||
|
||
procedure TGDIPages.SetPageMargins(Rect: TRect);
|
||
begin
|
||
fPageMarginsPx := MmToPrinter(Rect);
|
||
if not fHeaderDone then
|
||
fCurrentYPos := fPageMarginsPx.top;
|
||
end;
|
||
|
||
function TGDIPages.GetLeftMargin: integer;
|
||
begin
|
||
if Self=nil then
|
||
result := 0 else
|
||
result := PrinterPxToMmX(fPageMarginsPx.left);
|
||
end;
|
||
|
||
procedure TGDIPages.SetLeftMargin(const Value: integer);
|
||
begin
|
||
if Self=nil then exit;
|
||
fPageMarginsPx.Left := MmToPrinterPxX(Value);
|
||
end;
|
||
|
||
function TGDIPages.GetPaperSize: TSize;
|
||
begin
|
||
if Self=nil then
|
||
FillChar(result,sizeof(result),0) else begin
|
||
result.cx := PrinterPxToMmX(fPhysicalSizePx.X);
|
||
result.cy := PrinterPxToMmY(fPhysicalSizePx.Y);
|
||
end;
|
||
end;
|
||
|
||
procedure TGDIPages.AddLineToHeader(doubleline: boolean);
|
||
begin
|
||
if Self=nil then exit; // avoid GPF
|
||
fHeaderLines.Add(THeaderFooter.Create(Self,doubleline));
|
||
end;
|
||
|
||
procedure TGDIPages.AddLineToFooter(doubleline: boolean);
|
||
begin
|
||
if Self=nil then exit; // avoid GPF
|
||
if fFooterLines.Count = 0 then
|
||
CalcFooterGap;
|
||
fFooterLines.Add(THeaderFooter.Create(Self,doubleline));
|
||
inc(fFooterHeight, GetLineHeight);
|
||
end;
|
||
|
||
|
||
procedure TGDIPages.AddTextToHeader(const s: SynUnicode);
|
||
begin
|
||
if Self<>nil then
|
||
fHeaderLines.Add(THeaderFooter.Create(Self,false,s,true));
|
||
end;
|
||
|
||
procedure TGDIPages.AddTextToHeaderAt(const s: SynUnicode; XPos: integer);
|
||
var Head: THeaderFooter;
|
||
begin
|
||
if Self=nil then exit; // avoid GPF
|
||
Head := THeaderFooter.Create(Self,false,s,true);
|
||
Head.State.Flags := Head.State.Flags or ((XPos+2) shl 16);
|
||
fHeaderLines.Add(Head);
|
||
end;
|
||
|
||
procedure TGDIPages.AddTextToFooter(const s: SynUnicode);
|
||
begin
|
||
if Self=nil then exit; // avoid GPF
|
||
if fFooterLines.Count = 0 then
|
||
CalcFooterGap;
|
||
fFooterLines.Add(THeaderFooter.Create(Self,false,s,true));
|
||
inc(fFooterHeight, GetLineHeight);
|
||
end;
|
||
|
||
procedure TGDIPages.AddTextToFooterAt(const s: SynUnicode; XPos: integer);
|
||
var Foot: THeaderFooter;
|
||
begin
|
||
if Self=nil then exit; // avoid GPF
|
||
//todo - can't print at 0mm from left edge so raise exception
|
||
if fFooterLines.Count = 0 then
|
||
CalcFooterGap;
|
||
Foot := THeaderFooter.Create(Self,false,s,true);
|
||
Foot.State.Flags := Foot.State.Flags or ((XPos+2) shl 16);
|
||
fFooterLines.Add(Foot);
|
||
end;
|
||
|
||
procedure TGDIPages.AddPagesToFooterAt(const PageText: string;
|
||
XPos,YPosMultiplier: integer);
|
||
begin
|
||
if fPagesToFooterText<>'' then
|
||
exit; // only add once
|
||
fPagesToFooterText := PageText;
|
||
if XPos<0 then
|
||
fPagesToFooterAt.X := -1 else
|
||
fPagesToFooterAt.X := MmToPrinterPxX(XPos);
|
||
fPagesToFooterAt.Y := fFooterHeight * YPosMultiplier;
|
||
fPagesToFooterState := SavedState;
|
||
end;
|
||
|
||
function TGDIPages.GetColumnCount: integer;
|
||
begin
|
||
if Self=nil then
|
||
result := 0 else
|
||
result := length(fColumns);
|
||
end;
|
||
|
||
function TGDIPages.GetColumnInfo(index: integer): TColRec;
|
||
begin
|
||
if Self=nil then begin
|
||
FillChar(result,sizeof(result),0);
|
||
exit;
|
||
end;
|
||
if cardinal(index)>=cardinal(Length(fColumns)) then
|
||
raise Exception.create('GetColumnInfo: index out of range');
|
||
with fColumns[index] do begin
|
||
result.ColLeft := PrinterPxToMmX(ColLeft);
|
||
result.ColRight := PrinterPxToMmX(ColRight);
|
||
result.ColAlign := ColAlign;
|
||
result.ColBold := ColBold;
|
||
end;
|
||
end;
|
||
|
||
procedure TGDIPages.SetColumnAlign(index: integer; align: TColAlign);
|
||
begin
|
||
if Self=nil then exit; // avoid GPF
|
||
if cardinal(index)>=cardinal(Length(fColumns)) then
|
||
raise Exception.create('SetColumnAlign: index out of range') else
|
||
fColumns[index].ColAlign := align;
|
||
end;
|
||
|
||
procedure TGDIPages.SetColumnBold(index: integer);
|
||
begin
|
||
if Self=nil then exit; // avoid GPF
|
||
if cardinal(index)>=cardinal(Length(fColumns)) then
|
||
raise Exception.create('SetColumnAlign: index out of range') else
|
||
fColumns[index].ColBold := true;
|
||
end;
|
||
|
||
procedure TGDIPages.AddColumn(left, right: integer; align: TColAlign; bold: boolean);
|
||
var n: integer;
|
||
begin
|
||
if Self=nil then exit; // avoid GPF
|
||
left := MmToPrinterPxX(left);
|
||
right := MmToPrinterPxX(right);
|
||
n := length(fColumns);
|
||
if (n>0) and (left<fColumns[n-1].ColRight) then
|
||
raise Exception.create('Columns overlap!');
|
||
SetLength(fColumns,n+1);
|
||
with fColumns[n] do begin
|
||
ColLeft := left;
|
||
ColRight := right;
|
||
ColAlign := align;
|
||
ColBold := bold;
|
||
end;
|
||
end;
|
||
|
||
procedure TGDIPages.AddColumns(const PercentWidth: array of integer; align: TColAlign);
|
||
var i, sum, left, right, ww, n: integer;
|
||
begin
|
||
if Self=nil then exit; // avoid GPF
|
||
ClearColumns;
|
||
sum := 0;
|
||
for i := 0 to high(PercentWidth) do
|
||
inc(sum,abs(PercentWidth[i]));
|
||
if sum<=0 then
|
||
exit;
|
||
left := fPageMarginsPx.left;
|
||
ww := fPhysicalSizePx.x-left-fPageMarginsPx.right;
|
||
n := length(fColumns);
|
||
SetLength(fColumns,n+length(PercentWidth));
|
||
for i := 0 to high(PercentWidth) do begin
|
||
right := left+(abs(PercentWidth[i])*ww) div sum;
|
||
// manual adding (no mm conversion -> exact width)
|
||
with fColumns[i+n] do begin
|
||
ColLeft := left;
|
||
ColRight := right;
|
||
if PercentWidth[i]<0 then
|
||
ColAlign := caCenter else
|
||
ColAlign := align;
|
||
ColBold := false;
|
||
end;
|
||
left := right;
|
||
end;
|
||
end;
|
||
|
||
procedure TGDIPages.AddColumnHeaders(const headers: array of SynUnicode;
|
||
WithBottomGrayLine: boolean=false; BoldFont: boolean=false;
|
||
RowLineHeight: integer=0; flags: integer=0);
|
||
var n,i: integer;
|
||
begin
|
||
if Self=nil then exit; // avoid GPF
|
||
if flags=0 then begin
|
||
if BoldFont then
|
||
Font.Style := [fsBold];
|
||
flags := TextFormatsToFlags;
|
||
end;
|
||
n := length(fColumnHeaderList);
|
||
SetLength(fColumnHeaderList,n+1);
|
||
fColumnHeaderList[n].flags := flags;
|
||
SetLength(fColumnHeaderList[n].headers,Length(headers));
|
||
for i := 0 to high(headers) do
|
||
fColumnHeaderList[n].headers[i] := headers[i];
|
||
fColumnHeaderPrinted := false;
|
||
fColumnHeaderPrintedAtLeastOnce := false;
|
||
fColumnsWithBottomGrayLine := WithBottomGrayLine;
|
||
fColumnsRowLineHeight := RowLineHeight;
|
||
if BoldFont then
|
||
Font.Style := [];
|
||
end;
|
||
|
||
function CSVToArray(var CSV: PWideChar; n: integer): TSynUnicodeDynArray;
|
||
var i: integer;
|
||
begin
|
||
SetLength(result,n);
|
||
for i := 0 to n-1 do
|
||
result[i] := GetNextItemW(CSV);
|
||
end;
|
||
|
||
procedure TGDIPages.AddColumnHeadersFromCSV(var CSV: PWideChar;
|
||
WithBottomGrayLine, BoldFont: boolean; RowLineHeight: integer);
|
||
begin
|
||
if Self<>nil then // avoid GPF
|
||
AddColumnHeaders(CSVToArray(CSV,length(fColumns)),
|
||
WithBottomGrayLine,BoldFont,RowLineHeight);
|
||
end;
|
||
|
||
procedure TGDIPages.DrawTextAcrossColsFromCSV(var CSV: PWideChar; BackgroundColor: TColor=clNone);
|
||
begin
|
||
if Self<>nil then // avoid GPF
|
||
DrawTextAcrossCols(CSVToArray(CSV,length(fColumns)),[],BackgroundColor);
|
||
end;
|
||
|
||
/// round inverted color to white or black
|
||
function clAlways(cl: TColor): TColor;
|
||
begin
|
||
if ((GetRValue(cardinal(cl)) * 2) +
|
||
(GetGValue(cardinal(cl)) * 3) +
|
||
(GetBValue(cardinal(cl)) * 2)) < 600 then
|
||
result := clWhite else
|
||
result := clBlack;
|
||
end;
|
||
|
||
procedure TGDIPages.DrawTextAcrossCols(const StringArray: array of SynUnicode;
|
||
BackgroundColor: TColor);
|
||
begin
|
||
DrawTextAcrossCols(StringArray,[],BackgroundColor);
|
||
end;
|
||
|
||
procedure TGDIPages.DrawTextAcrossCols(const StringArray, LinkArray: array of SynUnicode;
|
||
BackgroundColor: TColor);
|
||
|
||
function HasCRLF(const s: SynUnicode): boolean;
|
||
var i: integer;
|
||
begin
|
||
result := true;
|
||
for i := 0 to length(s)-1 do
|
||
if s[i+1]<' ' then
|
||
exit;
|
||
result := false;
|
||
end;
|
||
|
||
function WrapText(s: SynUnicode; MaxWidth: integer; Lines: PSynUnicodeDynArray): integer;
|
||
var j,k,sp: integer;
|
||
begin
|
||
result := 0; // returns the line count
|
||
if Lines<>nil then
|
||
SetLength(Lines^,0);
|
||
repeat
|
||
if HasCRLF(s) or (TextWidthC(fCanvas,s)>MaxWidth) then begin
|
||
j := 1;
|
||
k := 1;
|
||
sp := 0;
|
||
while (j<length(s)) and (TextWidthC(fCanvas,copy(s,1,j))<MaxWidth) do begin
|
||
k := j; // store last fitting character index
|
||
if s[j]<=' ' then begin
|
||
sp := j; // mark space (=word delimiter) found
|
||
if s[j]<' ' then
|
||
break; // #13,#10 will force word wrap here = next line
|
||
end;
|
||
inc(j);
|
||
end;
|
||
if sp=0 then
|
||
sp := k; // if no space found, use character wrapping
|
||
end else
|
||
sp := length(s)+1;
|
||
if sp<=1 then
|
||
sp := 2;
|
||
if Lines<>nil then begin
|
||
SetLength(Lines^,length(Lines^)+1);
|
||
Lines^[high(Lines^)] := copy(s,1,sp-1);
|
||
end;
|
||
inc(result); // update lines count
|
||
s := trim(copy(s,sp,maxInt)); // trim ' ',#13,#10 for next line
|
||
until s='';
|
||
end;
|
||
|
||
var RowRect: TRect;
|
||
lh: integer;
|
||
max, i, j, k, c, H, ParenthW, LinesCount, X: integer;
|
||
s: SynUnicode;
|
||
line: string;
|
||
Lines: TSynUnicodeDynArray;
|
||
PW: PWideChar;
|
||
PWLen, Options: integer;
|
||
size: TSize;
|
||
r: TRect;
|
||
begin
|
||
if Self=nil then exit; // avoid GPF
|
||
max := high(fColumns);
|
||
if (max<0) or (length(StringArray)=0) then
|
||
exit; // no column defined
|
||
if High(StringArray)<max then
|
||
max := High(StringArray);
|
||
if max<0 then
|
||
exit; // nothing to draw
|
||
// check enough place for this column content on the page
|
||
lh := GetLineHeight;
|
||
CheckYPos;
|
||
LinesCount := 1; // by default, one line of text will be written
|
||
if WordWrapLeftCols then begin // check if stay on current page after word wrap
|
||
for j := 0 to max do
|
||
with fColumns[j] do
|
||
if (ColAlign=caLeft) and (ColRight>ColLeft) and
|
||
(HasCRLF(StringArray[j]) or
|
||
(TextWidthC(fCanvas,StringArray[j])>ColRight-ColLeft)) then begin
|
||
k := WrapText(StringArray[j],ColRight-ColLeft,nil); // calculate line counts
|
||
if k>LinesCount then
|
||
LinesCount := k; // calculate maximum line count
|
||
end;
|
||
if (LinesCount>1) and not HasSpaceForLines(LinesCount) then begin
|
||
NewPageInternal;
|
||
CheckHeaderDone;
|
||
end;
|
||
end;
|
||
if (fColumnHeaderList<>nil) and not fColumnHeaderPrinted then begin
|
||
i := length(fColumnHeaderList) + 2;
|
||
if not HasSpaceForLines(i) then
|
||
NewPageInternal;
|
||
PrintColumnHeaders;
|
||
end;
|
||
// prepare column write
|
||
if Assigned(fGroupPage) then
|
||
fColumnsUsedInGroup := true;
|
||
ParenthW := fCanvas.TextWidth(')');
|
||
RowRect.Top := fCurrentYPos;
|
||
RowRect.Bottom := RowRect.Top+lh*LinesCount;
|
||
RowRect.Right := fColumns[max].ColRight;
|
||
if BackgroundColor<>clNone then
|
||
with fCanvas do begin
|
||
Brush.Style := bsSolid;
|
||
Brush.Color := BackgroundColor;
|
||
RowRect.Left := fColumns[0].ColLeft;
|
||
FillRect(RowRect);
|
||
Brush.Style := bsClear;
|
||
Font.Color := clAlways(BackgroundColor);
|
||
end;
|
||
// main loop, used to write column content
|
||
line := '';
|
||
for i := 0 to max do begin
|
||
s := StringArray[i];
|
||
line := line+SynUnicodeToString(s)+#9; // add column content + tab for report text
|
||
if s<>'' then
|
||
with fColumns[i], fCanvas do
|
||
if ColRight>ColLeft then begin
|
||
if ColBold then
|
||
Font.Style := Font.Style+[fsBold];
|
||
Options := ETO_CLIPPED or TextFlags; // unicode version of TextRect()
|
||
if Brush.Style <> bsClear then
|
||
Options := Options or ETO_OPAQUE;
|
||
InternalUnicodeString(s,PW,PWLen,@size);
|
||
if (ColAlign=caCenter) and (size.cx>ColRight-ColLeft) then
|
||
// overlapping centered -> draw right aligned
|
||
RowRect.Left := ColRight-size.cx-ParenthW else
|
||
case ColAlign of
|
||
caLeft: begin
|
||
RowRect.Left := ColLeft;
|
||
if WordWrapLeftCols and (ColRight>ColLeft) and
|
||
(HasCRLF(s) or (size.cx>ColRight-ColLeft)) then begin
|
||
// handle optional left aligned column content word wrap
|
||
WrapText(s,ColRight-ColLeft,@Lines); // word wrap s into Lines[]
|
||
dec(RowRect.Left,ParenthW);
|
||
for j := 0 to high(Lines) do begin
|
||
InternalUnicodeString(Lines[j],PW,PWLen,@size);
|
||
if BiDiMode=bdRightToLeft then
|
||
X := ColRight-size.cx-ParenthW else
|
||
X := ColLeft;
|
||
RowRect.Top := fCurrentYPos+lh*j;
|
||
ExtTextOutW(Handle,X,RowRect.Top,Options,@RowRect,PW,PWLen,nil);
|
||
end;
|
||
RowRect.Top := fCurrentYPos;
|
||
if ColBold then
|
||
Font.Style := Font.Style-[fsBold];
|
||
Continue; // text was written as word-wrap -> write next column
|
||
end else
|
||
if BiDiMode=bdRightToleft then
|
||
RowRect.Left := ColRight-size.cx-ParenthW;
|
||
end;
|
||
caCenter:
|
||
RowRect.Left := ColLeft+(ColRight-ColLeft-size.cx)shr 1;
|
||
caRight:
|
||
if BiDiMode=bdLeftToRight then
|
||
RowRect.Left := ColRight-size.cx-ParenthW;
|
||
caCurrency: begin
|
||
if fNegsToParenthesesInCurrCols then
|
||
InternalUnicodeString(ConvertNegsToParentheses(s),PW,PWLen,@size);
|
||
RowRect.Left := ColRight-size.cx-ParenthW;
|
||
// no bdRightToleft handling necessary for caCurrency
|
||
end;
|
||
end;
|
||
dec(RowRect.Left,ParenthW);
|
||
ExtTextOutW(Handle,RowRect.Left+ParenthW,fCurrentYPos,Options,@RowRect,PW,PWLen,nil);
|
||
if (i<length(LinkArray)) and (LinkArray[i]<>'') then begin
|
||
r.Left := PrinterPxToMmX(rowrect.Left);
|
||
r.Top := PrinterPxToMmX(rowrect.Top);
|
||
r.right := PrinterPxToMmX(rowrect.left+(rowrect.right-fColumns[0].ColLeft) div (max+1));
|
||
r.Bottom := PrinterPxToMmX(rowrect.Bottom);
|
||
AddLink(LinkArray[i],r);
|
||
end;
|
||
inc(RowRect.Left,size.cx+ParenthW);
|
||
if ColBold then
|
||
Font.Style := Font.Style-[fsBold];
|
||
end;
|
||
end;
|
||
if not fDrawTextAcrossColsDrawingHeader or
|
||
not fColumnHeaderPrintedAtLeastOnce then begin
|
||
line[length(line)] := #13; // overwrite last #9
|
||
line := line+#10;
|
||
fCanvasText := fCanvasText+line; // append columns content to report text
|
||
end;
|
||
if BackgroundColor<>clNone then
|
||
fCanvas.Font.Color := clBlack;
|
||
if not fDrawTextAcrossColsDrawingHeader and (fColumnsRowLineHeight>LinesCount) then
|
||
// custom space for Row before bottom gray line
|
||
LinesCount := fColumnsRowLineHeight;
|
||
for i := 2 to LinesCount do
|
||
NewLine;
|
||
if fColumnsWithBottomGrayLine and (RowRect.Right<>0) then begin
|
||
c := fCanvas.Pen.Color;
|
||
fCanvas.Pen.Color := clLtGray;
|
||
H := lh shr 1-(lh*15)shr 4;
|
||
dec(fCurrentYPos, H);
|
||
LineInternal(GetColumnRec(0).ColLeft,RowRect.Right,false);
|
||
inc(fCurrentYPos, H);
|
||
fCanvas.Pen.Color := c;
|
||
end;
|
||
NewLine;
|
||
end;
|
||
|
||
procedure TGDIPages.DrawLinesInCurrencyCols(doublelines: boolean);
|
||
var i: integer;
|
||
begin
|
||
if Self=nil then exit; // avoid GPF
|
||
CheckYPos;
|
||
if (fColumnHeaderList<>nil) and not fColumnHeaderPrinted then begin
|
||
i := length(fColumnHeaderList) + 2;
|
||
if not HasSpaceForLines(i) then
|
||
NewPageInternal;
|
||
PrintColumnHeaders;
|
||
end;
|
||
for i := 0 to high(fColumns) do
|
||
with fColumns[i] do
|
||
if ColAlign = caCurrency then
|
||
LineInternal(ColLeft, ColRight, doublelines);
|
||
NewLine;
|
||
end;
|
||
|
||
procedure TGDIPages.ColumnHeadersNeeded;
|
||
begin
|
||
if Self=nil then exit; // avoid GPF
|
||
fColumnHeaderPrinted := false;
|
||
end;
|
||
|
||
procedure TGDIPages.Clear;
|
||
procedure ClearObjects(List: TStringList);
|
||
var i: integer;
|
||
begin
|
||
for i := 0 to List.Count-1 do
|
||
List.Objects[i].Free;
|
||
List.Clear;
|
||
end;
|
||
begin
|
||
if Self=nil then exit; // avoid GPF
|
||
if Assigned(fCanvas) then
|
||
FreeAndNil(fCanvas);
|
||
if Assigned(fGroupPage) then
|
||
FreeAndNil(fGroupPage);
|
||
FreeAndNil(fCurrentMetaFile);
|
||
SetLength(fPages,0);
|
||
ClearObjects(fBookmarks);
|
||
ClearObjects(fLinks);
|
||
ClearObjects(fOutline);
|
||
ClearHeaders;
|
||
ClearFooters;
|
||
ClearColumns;
|
||
SetTabStops([20]);
|
||
fCanvasText := '';
|
||
fLinksCurrent := -1;
|
||
fSavedCount := 0;
|
||
end;
|
||
|
||
procedure TGDIPages.ClearHeaders;
|
||
begin
|
||
if Self=nil then exit; // avoid GPF
|
||
fHeaderLines.Clear;
|
||
end;
|
||
|
||
procedure TGDIPages.ClearFooters;
|
||
begin
|
||
if Self=nil then exit; // avoid GPF
|
||
fFooterLines.Clear;
|
||
fPagesToFooterText := '';
|
||
end;
|
||
|
||
procedure TGDIPages.ClearColumns;
|
||
begin
|
||
if Self=nil then exit; // avoid GPF
|
||
SetLength(fColumns,0);
|
||
ClearColumnHeaders;
|
||
end;
|
||
|
||
procedure TGDIPages.ClearColumnHeaders;
|
||
begin
|
||
if Self=nil then exit; // avoid GPF
|
||
fColumnHeaderList := nil;
|
||
end;
|
||
|
||
function TGDIPages.CreatePictureMetaFile(Width, Height: integer;
|
||
out MetaCanvas: TCanvas): TMetaFile;
|
||
begin
|
||
if Self=nil then
|
||
result := nil else begin
|
||
result := CreateMetaFile(MmToPrinterPxX(Width),MmToPrinterPxY(Height));
|
||
MetaCanvas := CreateMetafileCanvas(result);
|
||
end;
|
||
end;
|
||
|
||
procedure TGDIPages.DrawTextFmt(const s: string; const Args: array of const;
|
||
withNewLine: boolean);
|
||
begin
|
||
DrawText(format(s,Args),withNewLine);
|
||
end;
|
||
|
||
function TGDIPages.TitleFlags: integer;
|
||
begin
|
||
result := ((Font.Size*12) div 10) or FORMAT_BOLD or FORMAT_LEFT;
|
||
end;
|
||
|
||
function TGDIPages.TextWidth(const Text: SynUnicode): integer;
|
||
begin
|
||
if Self=nil then
|
||
result := 0 else begin
|
||
if fCanvas=nil then
|
||
result := TextWidthC(Canvas,Text) else
|
||
result := TextWidthC(fCanvas,Text);
|
||
result := PrinterPxToMmX(result);
|
||
end;
|
||
end;
|
||
|
||
procedure TGDIPages.ShowPreviewForm(VisibleButtons: TGdiPagePreviewButtons);
|
||
procedure CopyMenus(Source,Dest: TMenuItem);
|
||
var i: integer;
|
||
Sub: TMenuItem;
|
||
begin
|
||
for i := 0 to Source.Count-1 do
|
||
with Source.Items[i] do begin
|
||
Sub := TMenuItem.Create(PreviewForm);
|
||
Sub.Tag := Tag;
|
||
Sub.OnClick := OnClick;
|
||
Sub.Caption := Caption;
|
||
Dest.Add(Sub);
|
||
CopyMenus(Source.Items[i],Sub);
|
||
end;
|
||
end;
|
||
const PANELWIDTH = 128;
|
||
var OldParent: TWinControl;
|
||
i,y,W: integer;
|
||
M: TMenuItem;
|
||
LeftPanel: TPanel;
|
||
begin
|
||
if Self=nil then exit; // avoid GPF
|
||
PreviewForm := TForm.Create(nil);
|
||
try
|
||
PreviewForm.Position := poScreenCenter;
|
||
PreviewForm.Height := Screen.Height-64;
|
||
PreviewForm.Caption := Caption;
|
||
PreviewForm.Font.Name := 'Tahoma';
|
||
with PaperSize do begin
|
||
if cy=0 then
|
||
y := 1 else
|
||
y := cy;
|
||
PreviewForm.Width := (cx*PreviewForm.Height) div y+(64+PANELWIDTH);
|
||
end;
|
||
if PreviewForm.Width>Screen.WorkAreaWidth then
|
||
PreviewForm.WindowState := wsMaximized;
|
||
LeftPanel := TPanel.Create(PreviewForm);
|
||
LeftPanel.Parent := PreviewForm;
|
||
LeftPanel.Width := PANELWIDTH;
|
||
LeftPanel.Align := alLeft;
|
||
W := LeftPanel.ClientWidth-8;
|
||
PreviewPageCountLabel := TLabel.Create(PreviewForm);
|
||
PreviewPageCountLabel.Transparent := true;
|
||
PreviewPageCountLabel.Parent := LeftPanel;
|
||
PreviewPageCountLabel.SetBounds(4,24,W-4,24);
|
||
PreviewPageCountLabel.Alignment := Classes.taCenter;
|
||
PreviewPageCountLabel.AutoSize := false;
|
||
PreviewPageCountLabel.Caption := format(sPageN,[Page,PageCount]);
|
||
PopupMenuPopup(nil); // refresh PopupMenu.Items[]
|
||
SetLength(PreviewButtons,PopupMenu.Items.Count);
|
||
y := 48;
|
||
for i := 0 to High(PreviewButtons) do begin
|
||
M := PopupMenu.Items[i];
|
||
PreviewButtons[i] := TButton.Create(PreviewForm);
|
||
with PreviewButtons[i] do begin
|
||
Parent := LeftPanel;
|
||
SetBounds(4,y,W,32);
|
||
Enabled := M.Enabled;
|
||
Caption := M.Caption;
|
||
Tag := M.Tag;
|
||
OnClick := PopupMenuItemClick;
|
||
if M.Count>0 then begin
|
||
PopupMenu := PopupMenuClass.Create(PreviewForm);
|
||
CopyMenus(M,PopupMenu.Items);
|
||
end;
|
||
if TGdiPagePreviewButton(i+1) in VisibleButtons then
|
||
case TGdiPagePreviewButton(i+1) of
|
||
rPrint: begin
|
||
Height := 60;
|
||
inc(y,64);
|
||
Default := true;
|
||
end;
|
||
rClose, rNextPage, rPreviousPage: begin
|
||
Height := 48;
|
||
inc(y,52);
|
||
end;
|
||
rGotoPage, rZoom, rBookmarks, rExportPDF:
|
||
inc(y,48);
|
||
else
|
||
inc(y,36);
|
||
end else begin
|
||
M.Visible := false;
|
||
Visible := false;
|
||
end;
|
||
end;
|
||
end;
|
||
OldParent := Parent;
|
||
Parent := PreviewForm;
|
||
Align := alClient;
|
||
Zoom := PAGE_FIT;
|
||
try
|
||
PreviewForm.ActiveControl := self;
|
||
PreviewForm.ShowModal;
|
||
finally
|
||
Parent := OldParent;
|
||
end;
|
||
finally
|
||
FreeAndNil(PreviewForm);
|
||
Finalize(PreviewButtons);
|
||
end;
|
||
end;
|
||
|
||
function TGDIPages.GetRightMarginPos: integer;
|
||
begin
|
||
result := PrinterPxToMmX(fPhysicalSizePx.x-fPageMarginsPx.right);
|
||
end;
|
||
|
||
function TGDIPages.NewPopupMenuItem(const aCaption: string; Tag: integer;
|
||
SubMenu: TMenuItem; OnClick: TNotifyEvent; ImageIndex: integer): TMenuItem;
|
||
begin
|
||
if (Self=nil) or (PopupMenu=nil) then begin
|
||
result := nil;
|
||
exit;
|
||
end;
|
||
result := TMenuItem.Create(PopupMenu);
|
||
result.Caption := aCaption;
|
||
result.Tag := Tag;
|
||
if Assigned(OnClick) then
|
||
result.OnClick := OnClick else
|
||
result.OnClick := PopupMenuItemClick;
|
||
if ImageIndex>=0 then
|
||
result.ImageIndex := ImageIndex;
|
||
if SubMenu=nil then
|
||
PopupMenu.Items.Add(result) else
|
||
SubMenu.Add(result);
|
||
end;
|
||
|
||
procedure TGDIPages.PopupMenuItemClick(Sender: TObject);
|
||
var Comp: TComponent absolute Sender;
|
||
i: Integer;
|
||
begin
|
||
if not Sender.InheritsFrom(TComponent) then
|
||
exit;
|
||
if Assigned(OnPopupMenuClick) then
|
||
if (Comp.Tag=0) or (Comp.Tag>PageCount) then
|
||
OnPopupMenuClick(Sender); // only notify custom events
|
||
case -Comp.Tag of
|
||
ord(rNone):
|
||
exit;
|
||
ord(rNextPage):
|
||
Page := Page+1;
|
||
ord(rPreviousPage):
|
||
Page := Page-1;
|
||
ord(rPageAsText):
|
||
if Page>0 then
|
||
Clipboard.AsText := fPages[Page-1].Text;
|
||
ord(rPrint):
|
||
if PrintPages(-1,-1) then
|
||
if PreviewForm<>nil then
|
||
PreviewForm.Close;
|
||
ord(rExportPDF):
|
||
ExportPDF('',true);
|
||
ord(rClose):
|
||
if PreviewForm<>nil then
|
||
PreviewForm.Close;
|
||
ord(rGotoPage), ord(rZoom), ord(rBookmarks):
|
||
if Sender.InheritsFrom(TButton) and (PreviewButtons<>nil) then
|
||
with PreviewButtons[-1-Comp.Tag],
|
||
PreviewForm.ClientToScreen(Point(Left,Top+Height)) do
|
||
PopupMenu.Popup(X,Y);
|
||
991..1999: // allow -1000-PAGE_WIDTH
|
||
Zoom := -1000-Comp.Tag;
|
||
2000..4000: begin // allow -2000-OutlineIndex
|
||
i := -2000-Comp.Tag;
|
||
if cardinal(i)<cardinal(fOutline.Count) then
|
||
with TGDIPagereference(fOutline.Objects[i]) do
|
||
GotoPosition(Page,Rect.Top);
|
||
end;
|
||
else
|
||
if Cardinal(Comp.Tag)<=Cardinal(PageCount) then
|
||
Page := Comp.Tag;
|
||
end;
|
||
if PreviewForm<>nil then
|
||
SetFocus;
|
||
end;
|
||
|
||
procedure TGDIPages.InternalUnicodeString(const s: SynUnicode;
|
||
var PW: PWideChar; var PWLen: integer; size: PSize);
|
||
begin
|
||
if Assigned(OnStringToUnicode) then begin
|
||
fInternalUnicodeString := OnStringToUnicode(s);
|
||
PW := pointer(fInternalUnicodeString);
|
||
PWLen := length(fInternalUnicodeString);
|
||
end else begin
|
||
PW := pointer(s);
|
||
PWLen := length(s);
|
||
end;
|
||
if size<>nil then begin
|
||
size^.cx := 0;
|
||
size^.cy := 0;
|
||
GetTextExtentPoint32W(fCanvas.Handle,PW,PWLen,size^);
|
||
end;
|
||
end;
|
||
|
||
procedure TGDIPages.PopupMenuPopup(Sender: TObject);
|
||
var P: PChar;
|
||
PageFromTo, PageN: string;
|
||
M,M2: TMenuItem;
|
||
i,j,k: integer;
|
||
procedure AddPage(Menu: TMenuItem);
|
||
begin
|
||
NewPopupMenuItem(format(PageN,[i]),i,Menu).Enabled := i<>Page;
|
||
end;
|
||
begin
|
||
with PopupMenu.Items do
|
||
if Count=0 then
|
||
exit else
|
||
while Count>ord(rClose) do
|
||
Delete(ord(rClose)); // delete after "Close" entry
|
||
PopupMenu.Items[Ord(rNextPage)-1].Enabled := Page<PageCount;
|
||
PopupMenu.Items[Ord(rPreviousPage)-1].Enabled := Page>1;
|
||
M := PopupMenu.Items[Ord(rGoToPage)-1];
|
||
while M.Count>0 do
|
||
M.Delete(0);
|
||
M.Enabled := PageCount>1;
|
||
if PageCount>=1 then begin // add 'Go to Page' sub menus (group by 10 pages)
|
||
P := pointer(string(sReportPopupMenu2));
|
||
PageFromTo := GetNextItemS(P); // Pages %d to %d
|
||
PageN := GetNextItemS(P); // Page %d
|
||
if PageCount>10 then begin
|
||
for j := 0 to PageCount div 10 do begin
|
||
k := j*10+1;
|
||
if k>PageCount then
|
||
break;
|
||
M2 := NewPopupMenuItem(format(PageFromTo,[k,k+9]),-800,M);
|
||
// Tag=-800 -> no OnClick event triggered for this entry
|
||
for i := k to k+9 do
|
||
if i>PageCount then
|
||
break else
|
||
AddPage(M2);
|
||
end;
|
||
end else
|
||
for i := 1 to PageCount do
|
||
AddPage(M);
|
||
end;
|
||
if Assigned(OnPopupMenuPopup) then
|
||
OnPopupMenuPopup(Sender);
|
||
end;
|
||
|
||
{$ifndef USEPDFPRINTER}
|
||
function TGDIPages.ExportPDFStream(aDest: TStream): boolean;
|
||
var PDF: TPDFDocument;
|
||
BackgroundImage: TPdfImage;
|
||
page: TPdfPage;
|
||
i: integer;
|
||
begin
|
||
try
|
||
PDF := TPDFDocument.Create(UseOutlines,0,ExportPDFA1,
|
||
TPdfEncryption.New(ExportPDFEncryptionLevel,ExportPDFEncryptionUserPassword,
|
||
ExportPDFEncryptionOwnerPassword,ExportPDFEncryptionPermissions));
|
||
try
|
||
PDF.GeneratePDF15File := ExportPDFGeneratePDF15File;
|
||
//PDF.CompressionMethod := cmNone;
|
||
with PDF.Info do begin
|
||
Title := SysUtils.Trim(Caption);
|
||
if ExportPDFApplication='' then
|
||
Creator := trim(Application.Title) else
|
||
Creator := trim(ExportPDFApplication);
|
||
Author := ExportPDFAuthor;
|
||
Subject := ExportPDFSubject;
|
||
Keywords := ExportPDFKeywords;
|
||
end;
|
||
PDF.EmbeddedTTF := ExportPDFEmbeddedTTF;
|
||
{$ifndef NO_USE_UNISCRIBE}
|
||
PDF.UseUniscribe := ExportPDFUseUniscribe;
|
||
{$endif}
|
||
PDF.UseFontFallBack := ExportPDFUseFontFallBack;
|
||
if ExportPDFFontFallBackName<>'' then
|
||
PDF.FontFallBackName := ExportPDFFontFallBackName;
|
||
PDF.ForceJPEGCompression := ExportPDFForceJPEGCompression;
|
||
if ExportPDFBackground=nil then
|
||
BackgroundImage := nil else begin
|
||
BackgroundImage := TPdfImage.Create(PDF,ExportPDFBackground,true);
|
||
PDF.AddXObject('BackgroundImage',BackgroundImage);
|
||
end;
|
||
PDF.SaveToStreamDirectBegin(aDest);
|
||
for i := 0 to PageCount-1 do
|
||
with Pages[i] do begin
|
||
// this loop will do all the magic :)
|
||
PDF.DefaultPageWidth := PdfCoord(25.4*SizePx.X/fPrinterPxPerInch.x);
|
||
PDF.DefaultPageHeight := PdfCoord(25.4*SizePx.Y/fPrinterPxPerInch.y);
|
||
page := PDF.AddPage;
|
||
if BackgroundImage<>nil then
|
||
PDF.Canvas.DrawXObject(0,0,page.PageWidth,page.PageHeight,'BackgroundImage');
|
||
PDF.Canvas.RenderMetaFile(GetMetaFileForPage(i),
|
||
Screen.PixelsPerInch/fPrinterPxPerInch.x,Screen.PixelsPerInch/fPrinterPxPerInch.y);
|
||
PDF.SaveToStreamDirectPageFlush;
|
||
end;
|
||
PDF.SaveToStreamDirectEnd;
|
||
finally
|
||
PDF.Free;
|
||
end;
|
||
result := true;
|
||
except
|
||
result := false;
|
||
end;
|
||
end;
|
||
{$endif}
|
||
|
||
function TGDIPages.ExportPDF(aPdfFileName: TFileName; ShowErrorOnScreen: boolean;
|
||
LaunchAfter: boolean): boolean;
|
||
{$ifdef USEPDFPRINTER}
|
||
var DefaultPrinter: integer;
|
||
{$else}
|
||
function ValidFileName(const FN: TFileName): TFileName;
|
||
var i: integer;
|
||
begin
|
||
result := FN;
|
||
for i := length(result) downto 1 do
|
||
if ord(result[i]) in [ord('/'),ord(':'),ord('\'),ord('.')] then
|
||
delete(result,i,1);
|
||
i := length(Result);
|
||
while (i>0) and (ord(result[i]) in [ord(' '),ord('-')]) do dec(i);
|
||
SetLength(Result,i);
|
||
result := trim(result);
|
||
end;
|
||
var PDFFileName: TFileName;
|
||
PDFFile: TFileStream;
|
||
i: integer;
|
||
Name: string;
|
||
TempDir: TFileName;
|
||
{$endif}
|
||
begin
|
||
result := False;
|
||
if Self=nil then
|
||
exit;
|
||
if PageCount>10 then
|
||
Screen.Cursor := crHourGlass;
|
||
{$ifdef USEPDFPRINTER}
|
||
if HasPDFPrinterInstalled then begin
|
||
DefaultPrinter := Printer.PrinterIndex;
|
||
Printer.PrinterIndex := fPDFPrinterIndex;
|
||
PrintPages(0,0);
|
||
Printer.PrinterIndex := DefaultPrinter;
|
||
end;
|
||
{$else}
|
||
// use the Synopse PDF engine
|
||
if aPdfFileName='' then
|
||
with TSaveDialog.Create(nil) do
|
||
try
|
||
TempDir := GetCurrentDir;
|
||
Filter := sPDFFile+' (*.pdf)|*.pdf';
|
||
Title := Caption;
|
||
FileName := ValidFileName(Caption);
|
||
DefaultExt := 'pdf';
|
||
Options := [ofOverwritePrompt,ofHideReadOnly,ofEnableSizing];
|
||
repeat
|
||
if not Execute then
|
||
exit;
|
||
PDFFileName := FileName;
|
||
i := FileCreate(PDFFileName); // test file create (pdf not already opened)
|
||
if i>0 then break;
|
||
MessageBox(0,pointer(Format(SIniFileWriteError,[PDFFileName])),nil,MB_ICONERROR);
|
||
until false;
|
||
FileClose(i);
|
||
finally
|
||
SetCurrentDir(TempDir); // allow unplug e.g. any USB
|
||
Free;
|
||
end else
|
||
PDFFileName := aPdfFileName;
|
||
try
|
||
PDFFile := TFileStream.Create(PDFFileName,fmCreate);
|
||
try
|
||
ExportPDFStream(PDFFile);
|
||
finally
|
||
PDFFile.Free;
|
||
end;
|
||
if LaunchAfter then
|
||
ShellExecute(Application.MainForm.Handle,'open',Pointer(PDFFileName),
|
||
nil,nil,SW_NORMAL);
|
||
except
|
||
on E: Exception do begin // show any error raised during PDF creation
|
||
if ShowErrorOnScreen then
|
||
MessageBox(0,pointer(E.Message),Pointer(Name),MB_ICONERROR);
|
||
exit;
|
||
end;
|
||
end;
|
||
{$endif}
|
||
result := true;
|
||
if PageCount>10 then
|
||
Screen.Cursor := crDefault;
|
||
end;
|
||
|
||
procedure TGDIPages.WMEraseBkgnd(var Message: TWmEraseBkgnd);
|
||
var R: TRect;
|
||
begin
|
||
Message.Result := 1; // no erasing is necessary after this method call
|
||
if Message.DC=0 then exit;
|
||
// erase outside the preview surface
|
||
R.Left := 0;
|
||
R.Right := fPreviewSurface.left;
|
||
R.Top := 0;
|
||
R.Bottom := Height;
|
||
FillRect(Message.DC,R,Brush.Handle);
|
||
R.Left := R.Right+fPreviewSurface.Width;
|
||
R.Right := Width;
|
||
FillRect(Message.DC,R,Brush.Handle);
|
||
R.Left := 0;
|
||
R.Bottom := fPreviewSurface.Top;
|
||
FillRect(Message.DC,R,Brush.Handle);
|
||
R.Top := fPreviewSurface.Top+fPreviewSurface.Height;
|
||
R.Bottom := Height;
|
||
FillRect(Message.DC,R,Brush.Handle);
|
||
end;
|
||
|
||
procedure TGDIPages.AppendRichEdit(RichEditHandle: HWnd;
|
||
EndOfPagePositions: PIntegerDynArray);
|
||
var Range: TFormatRange;
|
||
LogX, LogY, LastChar, MaxLen, OldMap: integer;
|
||
TextLenEx: TGetTextLengthEx; // RichEdit 2.0 Window Class
|
||
begin
|
||
if (Self<>nil) and (fCanvas<>nil) then
|
||
with Range do begin
|
||
LogX := GetDeviceCaps(fCanvas.Handle, LOGPIXELSX);
|
||
LogY := GetDeviceCaps(fCanvas.Handle, LOGPIXELSY);
|
||
rcPage.Left := (fPageMarginsPx.Left*1440) div LogX;
|
||
rcPage.Right := ((fPhysicalSizePx.x-fPageMarginsPx.Right)*1440) div LogX;
|
||
rcPage.Top := ((fPageMarginsPx.Top+fHeaderHeight)*1440) div LogY;
|
||
rcPage.Bottom := ((fPhysicalSizePx.y-fPageMarginsPx.Bottom-fFooterHeight)*1440) div LogY;
|
||
CheckHeaderDone;
|
||
rc := rcPage;
|
||
rc.Top := (fCurrentYPos*1440) div LogY;
|
||
LastChar := 0;
|
||
TextLenEx.flags := GTL_DEFAULT;
|
||
TextLenEx.codepage := CP_ACP;
|
||
MaxLen := SendMessage(RichEditHandle, EM_GETTEXTLENGTHEX, PtrInt(@TextLenEx), 0);
|
||
chrg.cpMax := -1;
|
||
OldMap := SetMapMode(hdc, MM_TEXT);
|
||
try
|
||
SendMessage(RichEditHandle, EM_FORMATRANGE, 0, 0);
|
||
repeat
|
||
chrg.cpMin := LastChar;
|
||
hdc := fCanvas.Handle;
|
||
hdcTarget := hdc;
|
||
LastChar := SendMessage(RichEditHandle, EM_FORMATRANGE, 1, PtrInt(@Range));
|
||
if EndOfPagePositions<>nil then
|
||
AddInteger(EndOfPagePositions^,LastChar);
|
||
if cardinal(LastChar)>=cardinal(MaxLen) then
|
||
break;
|
||
NewPageInternal;
|
||
DoHeader;
|
||
rc := rcPage;
|
||
until false;
|
||
fCurrentYPos := (rc.Bottom*LogY) div 1440;
|
||
finally
|
||
SendMessage(RichEditHandle, EM_FORMATRANGE, 0, 0);
|
||
SetMapMode(hdc, OldMap);
|
||
end;
|
||
end;
|
||
end;
|
||
|
||
function TGDIPages.AddBookMark(const aBookmarkName: string; aYPosition: integer=0): boolean;
|
||
begin
|
||
if fBookmarks.IndexOf(aBookmarkName)>=0 then // avoid duplicate bookmarks
|
||
result := false else begin
|
||
if aYPosition=0 then begin
|
||
CheckYPos;
|
||
aYPosition := fCurrentYPos;
|
||
end;
|
||
fBookMarks.AddObject(aBookmarkName,
|
||
TGDIPagereference.Create(PageCount,0,aYPosition,0,0));
|
||
{$ifndef USEPDFPRINTER}
|
||
fCanvas.MoveTo(0,aYPosition);
|
||
GDICommentBookmark(fCanvas.Handle,StringToUTF8(aBookmarkName));
|
||
{$endif}
|
||
result := true;
|
||
end;
|
||
end;
|
||
|
||
procedure TGDIPages.GotoPosition(aPage: integer; aYPos: integer);
|
||
begin
|
||
Page := aPage;
|
||
HorzScrollbar.Position := 0;
|
||
VertScrollbar.Position := (aYPos*VertScrollbar.Range) div fPhysicalSizePx.y
|
||
end;
|
||
|
||
function TGDIPages.GotoBookmark(const aBookmarkName: string): Boolean;
|
||
var i: integer;
|
||
begin
|
||
i := fBookmarks.IndexOf(aBookmarkName);
|
||
result := i>=0;
|
||
if result then
|
||
with TGDIPagereference(fBookmarks.Objects[i]) do
|
||
GotoPosition(Page,Rect.Top);
|
||
end;
|
||
|
||
procedure TGDIPages.AddOutline(const aTitle: string; aLevel: Integer;
|
||
aYPosition: integer=0; aPageNumber: integer=0);
|
||
begin
|
||
if aPageNumber=0 then
|
||
aPageNumber := PageCount;
|
||
if aYPosition=0 then begin
|
||
CheckYPos;
|
||
aYPosition := fCurrentYPos;
|
||
end;
|
||
fOutline.AddObject(aTitle,
|
||
TGDIPagereference.Create(aPageNumber,0,aYPosition,0,aLevel));
|
||
{$ifndef USEPDFPRINTER}
|
||
fCanvas.MoveTo(0,aYPosition);
|
||
GDICommentOutline(fCanvas.Handle, StringToUtf8(aTitle),aLevel);
|
||
{$endif}
|
||
end;
|
||
|
||
procedure TGDIPages.AddLink(const aBookmarkName: string; aRect: TRect;
|
||
aPageNumber: integer; aNoBorder: boolean);
|
||
begin
|
||
if aPageNumber=0 then
|
||
aPageNumber := PageCount;
|
||
aRect := MmToPrinter(aRect);
|
||
with aRect do
|
||
fLinks.AddObject(aBookmarkName,
|
||
TGDIPagereference.Create(aPageNumber,Left,Top,Right,Bottom));
|
||
{$ifndef USEPDFPRINTER}
|
||
GDICommentLink(fCanvas.Handle,StringToUtf8(aBookmarkName),aRect,aNoBorder);
|
||
{$endif}
|
||
end;
|
||
|
||
|
||
{ TGDIPagereference }
|
||
|
||
constructor TGDIPagereference.Create(PageNumber: integer; Left, Top, Right,
|
||
Bottom: integer);
|
||
begin
|
||
inherited Create;
|
||
Page := PageNumber;
|
||
Rect.Left := Left;
|
||
Rect.Top := Top;
|
||
Rect.Right := Right;
|
||
Rect.Bottom := Bottom;
|
||
end;
|
||
|
||
procedure TGDIPagereference.ToPreview(Pages: TGDIPages);
|
||
var W,H: integer;
|
||
begin // do it for all pages (zoom is not reset between page shift)
|
||
if Page<>0 then
|
||
with Pages.fPreviewSurface do begin
|
||
W := Width-GRAY_MARGIN*2;
|
||
H := Height-GRAY_MARGIN*2;
|
||
Preview.Left := GRAY_MARGIN+(Rect.Left*W) div Pages.fPhysicalSizePx.x;
|
||
Preview.Right := GRAY_MARGIN+(Rect.Right*W) div Pages.fPhysicalSizePx.x;
|
||
Preview.Top := GRAY_MARGIN+(Rect.Top*H) div Pages.fPhysicalSizePx.y;
|
||
Preview.Bottom := GRAY_MARGIN+(Rect.Bottom*H) div Pages.fPhysicalSizePx.y;
|
||
end;
|
||
end;
|
||
|
||
|
||
{ THeaderFooter }
|
||
|
||
constructor THeaderFooter.Create(Report: TGDIPages; doubleline: boolean;
|
||
const aText: SynUnicode=''; IsText: boolean=false);
|
||
begin
|
||
Text := aText;
|
||
State := Report.SavedState;
|
||
if not IsText then
|
||
if doubleline then
|
||
State.Flags := State.Flags or FORMAT_DOUBLELINE else
|
||
State.Flags := State.Flags or FORMAT_SINGLELINE;
|
||
end;
|
||
|
||
|
||
{$ifdef RENDERPAGES}
|
||
|
||
{ TRenderPages }
|
||
|
||
procedure TRenderPages.Clear;
|
||
begin
|
||
inherited;
|
||
fRdrCol.Clear;
|
||
fFontCache.Clear;
|
||
end;
|
||
|
||
constructor TRenderPages.Create(AOwner: TComponent);
|
||
begin
|
||
inherited;
|
||
fRdr := TRenderBox.Create(self);
|
||
fRdrCol := TObjectList.Create;
|
||
fFontCache := TObjectList.Create;
|
||
end;
|
||
|
||
destructor TRenderPages.Destroy;
|
||
begin
|
||
inherited;
|
||
FreeAndNil(fRdrCol);
|
||
FreeAndNil(fRdr);
|
||
FreeAndNil(fFontCache);
|
||
end;
|
||
|
||
function TRenderPages.GetCurrentFontCacheIndex: integer;
|
||
var F: TFont;
|
||
begin
|
||
for result := 0 to fFontCache.Count-1 do
|
||
with TFont(fFontCache.List[result]) do
|
||
if (Color=Font.Color) and (Height=Font.Height) and (Style=Font.Style) and
|
||
(Name=Font.Name) then
|
||
exit;
|
||
F := TFont.Create;
|
||
F.Assign(Font);
|
||
result := fFontCache.Add(F);
|
||
end;
|
||
|
||
function TRenderPages.GetCurrentFontCacheIndexAndSelect: integer;
|
||
var H: HDC;
|
||
begin
|
||
result := GetCurrentFontCacheIndex;
|
||
H := Canvas.Handle;
|
||
with TFont(fFontCache[result]) do begin // same as TCanvas.CreateFont
|
||
SelectObject(H,Handle);
|
||
SetTextColor(H,ColorToRGB(Color));
|
||
if length(fFontCacheSpace)<fFontCache.Count then
|
||
SetLength(fFontCacheSpace,fFontCache.Count+20);
|
||
if fFontCacheSpace[result].cx=0 then
|
||
GetTextExtentPoint32W(H,' ',1,fFontCacheSpace[result]);
|
||
end;
|
||
end;
|
||
|
||
function TRenderPages.GetSavedRender: TSavedStateRender;
|
||
begin
|
||
with result do begin
|
||
FirstLineIndent := ParagraphFirstLineIndent;
|
||
Before := ParagraphBefore;
|
||
After := ParagraphAfter;
|
||
RightIndent := ParagraphRightIndent;
|
||
LeftIndent := ParagraphLeftIndent;
|
||
end;
|
||
end;
|
||
|
||
procedure TRenderPages.NewPageInternal;
|
||
begin
|
||
{ TODO : close any pending paragraph }
|
||
inherited;
|
||
end;
|
||
|
||
procedure TRenderPages.RdrParagraph;
|
||
begin
|
||
if ParagraphBefore<>0 then
|
||
CurrentYPos := CurrentYPos+ParagraphBefore;
|
||
Rdr.Flush(fPageMarginsPx.left,fCurrentYPos,false,0,False);
|
||
if ParagraphAfter<>0 then
|
||
CurrentYPos := CurrentYPos+ParagraphAfter;
|
||
end;
|
||
|
||
procedure TRenderPages.RdrPard;
|
||
var State: TSavedState;
|
||
begin
|
||
if self=nil then
|
||
exit;
|
||
fAlign := taLeft;
|
||
SetSavedRender(fDefaultStateRender);
|
||
State := SavedState;
|
||
if State.Flags<>fDefaultState.Flags then begin
|
||
State.Flags := fDefaultState.Flags;
|
||
SavedState := State; // will set FORMAT_RIGHT/CENTER/JUSTIFIED
|
||
end;
|
||
end;
|
||
|
||
procedure TRenderPages.RdrPardPlain;
|
||
begin
|
||
if self=nil then
|
||
exit;
|
||
if fDefaultState.FontName='' then
|
||
RdrPlain else
|
||
SavedState := fDefaultState;
|
||
SetSavedRender(fDefaultStateRender);
|
||
end;
|
||
|
||
procedure TRenderPages.RdrPlain;
|
||
var State: TSavedState;
|
||
begin
|
||
if self=nil then
|
||
exit;
|
||
if (fDefaultState.FontName='') or (fDefaultState.Flags=0) then begin
|
||
Font.Size := 12;
|
||
Font.Style := [];
|
||
Font.Color := clBlack;
|
||
end else begin
|
||
State := fDefaultState;
|
||
State.Flags :=
|
||
// void FORMAT_RIGHT/CENTER/JUSTIFIED
|
||
(State.Flags and not (FORMAT_RIGHT or FORMAT_CENTER or FORMAT_JUSTIFIED)) or
|
||
// keep current FORMAT_RIGHT/CENTER/JUSTIFIED
|
||
(TextFormatsToFlags and (FORMAT_RIGHT or FORMAT_CENTER or FORMAT_JUSTIFIED));
|
||
SavedState := State;
|
||
end;
|
||
end;
|
||
|
||
procedure TRenderPages.RdrSetCurrentStateAsDefault;
|
||
begin
|
||
fDefaultState := SavedState;
|
||
fDefaultStateRender := GetSavedRender;
|
||
end;
|
||
|
||
function TRenderPages.RdrTableBegin(const PercentWidth: array of integer): Boolean;
|
||
var i, sum, w: integer;
|
||
col: TRenderBox;
|
||
begin
|
||
result := (Self<>nil) and (fRdrCol.Count=0);
|
||
if not result then
|
||
exit;
|
||
sum := 0;
|
||
for i := 0 to high(PercentWidth) do
|
||
inc(sum,PercentWidth[i]);
|
||
if sum<=0 then begin
|
||
result := false;
|
||
exit;
|
||
end;
|
||
w := fPhysicalSizePx.x-fPageMarginsPx.Left-fPageMarginsPx.right;
|
||
for i := 0 to high(PercentWidth) do begin
|
||
col := TRenderBox.Create(self);
|
||
col.Width := (w*100)div sum;
|
||
fRdrCol.Add(col);
|
||
end;
|
||
end;
|
||
|
||
function TRenderPages.RdrTableColumn(aColumnIndex: Integer): TRenderBox;
|
||
begin
|
||
if (Self=nil) or (cardinal(aColumnIndex)>=cardinal(fRdrCol.Count-1)) then
|
||
result := nil else
|
||
result := TRenderBox(fRdrCol.List[aColumnIndex]);
|
||
end;
|
||
|
||
function TRenderPages.RdrTableEnd: Boolean;
|
||
begin
|
||
result := (Self<>nil) and (fRdrCol.Count>0);
|
||
if not result then
|
||
exit;
|
||
|
||
fRdrCol.Clear;
|
||
end;
|
||
|
||
procedure TRenderPages.RestoreSavedLayout;
|
||
begin
|
||
if Self=nil then exit; // avoid GPF
|
||
if fSavedCount>=length(fSavedRender) then
|
||
Setlength(fSavedRender,fSavedCount+20);
|
||
fSavedRender[fSavedCount] := GetSavedRender;
|
||
inherited;
|
||
end;
|
||
|
||
procedure TRenderPages.SaveLayout;
|
||
begin
|
||
if Self=nil then exit; // avoid GPF
|
||
if fSavedCount<=0 then
|
||
exit;
|
||
inherited;
|
||
SetSavedRender(fSavedRender[fSavedCount]);
|
||
end;
|
||
|
||
procedure TRenderPages.SetSavedRender(const State: TSavedStateRender);
|
||
begin
|
||
with State do begin
|
||
ParagraphFirstLineIndent := FirstLineIndent;
|
||
ParagraphBefore := Before;
|
||
ParagraphAfter := After;
|
||
ParagraphRightIndent := RightIndent;
|
||
ParagraphLeftIndent := LeftIndent;
|
||
end;
|
||
end;
|
||
|
||
|
||
{ TRenderBox }
|
||
|
||
procedure TRenderBox.AddText(const s: string);
|
||
var PW: PWideChar;
|
||
PWLen: integer;
|
||
begin
|
||
if (self=nil) or (Owner=nil) then
|
||
exit; // avoid GPF
|
||
// convert text to unicode and add to fText[] internal buffer
|
||
Owner.InternalUnicodeString(StringToSynUnicode(s),PW,PWLen,nil);
|
||
AddText(PW,PWLen);
|
||
end;
|
||
|
||
procedure TRenderBox.AddText(PW: PWideChar; PWLen: integer);
|
||
var PDBeg, PD: PWideChar;
|
||
aFontIndex, aFontSpaceWidth: integer;
|
||
begin
|
||
if (self=nil) or (Owner=nil) or (PWLen=0) then
|
||
exit; // avoid GPF
|
||
if PWLen+fTextLen>length(fText) then
|
||
SetLength(fText,length(fText)+PWLen+1024);
|
||
PD := @fText[fTextLen];
|
||
inc(fTextLen,PWLen);
|
||
// create associated word markers
|
||
aFontIndex := Owner.GetCurrentFontCacheIndexAndSelect;
|
||
aFontSpaceWidth := Owner.fFontCacheSpace[aFontIndex].cx;
|
||
repeat
|
||
PDBeg := PD;
|
||
while true do
|
||
case integer(PW^) of
|
||
0, 32: break;
|
||
1..31: if PD<>PDBeg then break else Inc(PW);
|
||
else begin
|
||
PD^ := PW^;
|
||
inc(PW);
|
||
inc(PD);
|
||
end;
|
||
end;
|
||
if fBoxCount>=Length(fBox) then
|
||
SetLength(fBox,fBoxCount+200);
|
||
with fBox[fBoxCount] do begin
|
||
TextOffset := PD-@fText[0];
|
||
TextLength := PD-PDBeg;
|
||
FontIndex := aFontIndex;
|
||
FontSpaceWidth := aFontSpaceWidth;
|
||
GetTextExtentPoint32W(Owner.Canvas.Handle,PDBeg,TextLength,Size);
|
||
SpaceAfterCount := 0;
|
||
while integer(PW^) in [1..32] do begin
|
||
PD^ := ' ';
|
||
inc(PW);
|
||
inc(PD);
|
||
inc(SpaceAfterCount);
|
||
end;
|
||
LinkNumber := fLinksBookMarkNameCurrent;
|
||
end;
|
||
inc(fBoxCount);
|
||
until PW^=#0;
|
||
end;
|
||
|
||
procedure TRenderBox.Clear;
|
||
begin
|
||
if Self=nil then
|
||
exit;
|
||
Finalize(fLinksBookMarkName);
|
||
Finalize(fBox);
|
||
fLayoutCount := 0;
|
||
fBoxCount := 0;
|
||
fTextLen := 0;
|
||
fHeight := 0;
|
||
fLinksBookMarkNameCurrent := 0;
|
||
end;
|
||
|
||
constructor TRenderBox.Create(Owner: TRenderPages);
|
||
begin
|
||
fOwner := Owner;
|
||
fBiDiMode := Owner.BiDiMode;
|
||
fOwnerFont := Owner.Font;
|
||
end;
|
||
|
||
/// format the already inserted text into the TRenderPages owner
|
||
// - this TRenderBox text content will be cleared at the end of this method
|
||
// - you don't have to call it usualy: use Owner.RdrParagraph instead
|
||
// - by default, will render top aligned to the X=Left/Y=Top position
|
||
// - for vertical alignment, specify an height in ForcedHeightBottomCentered
|
||
// then will be centered if ForcedAtBottom=false, or bottom aligned if true
|
||
// - if CurrentPageOnly is true, will only flush the content which will fit on
|
||
// the current page - then the fLayout[] array will contain remaining boxes; otherwise,
|
||
// this will flush all content to multiple pages
|
||
|
||
procedure TRenderBox.Flush(Left, Top: Integer; CurrentPageOnly: boolean;
|
||
ForcedHeightBottomCentered: Integer; ForcedAtBottom: boolean);
|
||
var H, Y, i, fitLayout: integer;
|
||
WillBreak: boolean;
|
||
begin
|
||
if (self=nil) or (Owner=nil) then
|
||
exit; // avoid GPF
|
||
H := GetHeight; // will populate fLayout[] from fBox[] if necessary
|
||
{ render on document Canvas }
|
||
WillBreak := false;
|
||
fitLayout := fLayoutCount-1;
|
||
for i := 0 to fitLayout do
|
||
if fLayout[i].Top>=H then begin
|
||
fitLayout := i-1;
|
||
WillBreak := true;
|
||
break;
|
||
end;
|
||
|
||
{ TODO : handle TGDIPagereference creation from fLayout[].LastBox.LinkNumber }
|
||
// reset internal TRenderBox content
|
||
Clear;
|
||
end;
|
||
|
||
function TRenderBox.GetHeight: integer;
|
||
begin
|
||
if self=nil then
|
||
result := 0 else begin
|
||
if fHeight=0 then
|
||
// need to recalculate the layout to refresh the resulting Height
|
||
InternalRender;
|
||
result := fHeight;
|
||
end;
|
||
end;
|
||
|
||
procedure TRenderBox.InternalRender;
|
||
var ndx, ndxFirst: integer;
|
||
X, Y, H, W, LineW: integer;
|
||
txt: PWideChar;
|
||
Box: PRenderBoxWord;
|
||
LineLayout, LineNdx: integer;
|
||
procedure AddLayout(DoLineFeed, LastLine: boolean);
|
||
var nspace, Adjust, i, j, aLeft, n: Integer;
|
||
align: TTextAlign;
|
||
TmpLayout: array of TRenderBoxLayout;
|
||
begin
|
||
if fLayoutCount>=length(fLayout) then
|
||
SetLength(fLayout,fLayoutCount+50);
|
||
with fLayout[fLayoutCount] do begin
|
||
Text := txt;
|
||
with Box^ do
|
||
txt := @fText[TextOffset+TextLength]; // txt^ points to ' ' after text
|
||
Length := txt-Text;
|
||
Left := X;
|
||
Top := Y;
|
||
Width := W;
|
||
LineIndex := LineNdx;
|
||
LastBox := Box;
|
||
BreakExtra := 0;
|
||
BreakCount := 0;
|
||
end;
|
||
if DoLineFeed then begin
|
||
// we must handle the line feed layout
|
||
Align := Owner.TextAlign;
|
||
Adjust := LineW-(X+W);
|
||
if (Adjust<=0) or
|
||
// force left align if wider than expected (i.e. overpass right margin)
|
||
(LastLine and (Align=taJustified)) then
|
||
// last line of justified paragraph is never justified
|
||
Align := taLeft;
|
||
if BiDiMode=bdRightToLeft then begin
|
||
case Align of
|
||
taLeft: Align := taRight;
|
||
taRight: Align := taLeft;
|
||
end;
|
||
n := fLayoutCount-LineLayout+1;
|
||
if n>1 then begin
|
||
// multi layouts: change logical to visual order for RTL languages
|
||
SetLength(TmpLayout,n);
|
||
Move(fLayout[LineLayout],TmpLayOut[0],n*sizeof(TmpLayOut[0]));
|
||
aLeft := fLayout[LineLayout].Left;
|
||
for i := 0 to n-1 do begin
|
||
move(TmpLayout[i],fLayout[fLayoutCount-i],sizeof(TmpLayOut[0]));
|
||
with fLayout[fLayoutCount-i] do begin
|
||
Left := aLeft;
|
||
Inc(aLeft,Width+LastBox^.FontSpaceWidth*LastBox^.SpaceAfterCount);
|
||
end;
|
||
end;
|
||
end;
|
||
end;
|
||
case Align of
|
||
taRight:
|
||
for i := LineLayout to fLayoutCount do
|
||
inc(fLayout[i].Left,Adjust);
|
||
taCenter: begin
|
||
Adjust := Adjust div 2;
|
||
for i := LineLayout to fLayoutCount do
|
||
inc(fLayout[i].Left,Adjust);
|
||
end;
|
||
taJustified:
|
||
if Adjust>0 then begin
|
||
// compute SetTextJustification() values and update Left position
|
||
aLeft := fLayout[LineLayout].Left;
|
||
nspace := 0;
|
||
for i := LineLayout to fLayoutCount do
|
||
with fLayout[i] do begin
|
||
for j := 0 to Length-1 do
|
||
if Text[j]=' ' then
|
||
inc(BreakCount);
|
||
inc(nspace,BreakCount);
|
||
end;
|
||
if nspace>0 then
|
||
for i := LineLayout to fLayoutCount do
|
||
with fLayout[i] do begin
|
||
Left := aLeft;
|
||
BreakExtra := (Adjust*BreakCount) div nspace;
|
||
dec(Width,LastBox^.FontSpaceWidth*BreakCount-BreakExtra);
|
||
inc(aLeft,Width);
|
||
end;
|
||
end;
|
||
end;
|
||
for i := LineLayout to fLayoutCount do
|
||
fLayout[i].Height := H; // same height for all fLayout[] of this line
|
||
with Owner do
|
||
X := MmToPrinterPxX(ParagraphLeftIndent);
|
||
inc(Y,H);
|
||
H := 0; // force recalculate line height
|
||
LineLayout := fLayoutCount;
|
||
inc(LineNdx);
|
||
end else begin
|
||
// just append this "word" box to fLayout[fLayoutCount]
|
||
with Box^ do
|
||
// compute next position
|
||
inc(X,W+FontSpaceWidth*SpaceAfterCount);
|
||
end;
|
||
inc(fLayoutCount);
|
||
ndxFirst := ndx+1;
|
||
W := 0;
|
||
end;
|
||
begin // compute TRenderBoxWord.X/Y and fHeight
|
||
fHeight := 0;
|
||
fLayoutCount := 0;
|
||
SetLength(fLayout,fBoxCount shr 2);
|
||
if fBoxCount=0 then
|
||
exit; // no text added
|
||
with Owner do begin
|
||
X := MmToPrinterPxX(ParagraphFirstLineIndent);
|
||
LineW := self.fWidth-MmToPrinterPxX(ParagraphRightIndent);
|
||
end;
|
||
LineNdx := 0;
|
||
Y := 0;
|
||
H := 0;
|
||
W := 0;
|
||
LineLayout := 0;
|
||
txt := @fText[0];
|
||
ndxFirst := 0;
|
||
for ndx := 0 to fBoxCount-1 do begin
|
||
Box := @fBox[ndx];
|
||
if Box^.Size.cy>H then
|
||
H := Box^.Size.cy;
|
||
inc(W,Box^.Size.cx);
|
||
if ndx=fBoxCount-1 then
|
||
// reached last box -> flush pending line content
|
||
AddLayout(true,true) else
|
||
with fBox[ndx+1] do
|
||
if X+W+Size.cx>LineW then
|
||
// not enough space in current line -> flush+adjust and go to next line
|
||
AddLayout(true,false) else
|
||
if (FontIndex<>Box^.FontIndex) or (LinkNumber<>Box^.LinkNumber) then
|
||
// text formatting or Link will change -> add a layout box
|
||
AddLayout(false,false);
|
||
end;
|
||
fHeight := Y;
|
||
end;
|
||
|
||
procedure TRenderBox.LinkBegin(const aBookmarkName: string);
|
||
|
||
begin
|
||
if (self=nil) or (Owner=nil) then
|
||
exit; // avoid GPF
|
||
LinkEnd; // no nested links
|
||
fLinksBookMarkNameCurrent := Length(fLinksBookMarkName)+1;
|
||
SetLength(fLinksBookMarkName,fLinksBookMarkNameCurrent);
|
||
fLinksBookMarkName[fLinksBookMarkNameCurrent-1] := aBookmarkName;
|
||
end;
|
||
|
||
function TRenderBox.LinkEnd: boolean;
|
||
begin
|
||
result := false;
|
||
if (self=nil) or (Owner=nil) or (fLinksBookMarkNameCurrent=0) then
|
||
exit; // avoid GPF
|
||
fLinksBookMarkNameCurrent := 0;
|
||
result := true;
|
||
end;
|
||
|
||
procedure TRenderBox.NewLine;
|
||
begin
|
||
if (self=nil) or (Owner=nil) then
|
||
exit; // avoid GPF
|
||
|
||
end;
|
||
|
||
procedure TRenderBox.Pard;
|
||
begin
|
||
if (self<>nil) and (Owner<>nil) then // avoid GPF
|
||
Owner.RdrPard;
|
||
end;
|
||
|
||
procedure TRenderBox.PardPlain;
|
||
begin
|
||
if (self<>nil) and (Owner<>nil) then // avoid GPF
|
||
Owner.RdrPardPlain;
|
||
end;
|
||
|
||
procedure TRenderBox.Plain;
|
||
begin
|
||
if (self<>nil) and (Owner<>nil) then // avoid GPF
|
||
Owner.RdrPlain;
|
||
end;
|
||
|
||
{$endif RENDERPAGES}
|
||
|
||
end.
|
||
|