home *** CD-ROM | disk | FTP | other *** search
/ Chip 2001 December / Chip_2001-12_cd1.bin / zkuste / delphi / kompon / d3456 / POWERPDF.ZIP / PowerPdf / PReport.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  2001-09-15  |  63.1 KB  |  2,412 lines
  1. {*
  2.  * << P o w e r P d f >> -- PReport.pas
  3.  *
  4.  * Copyright (c) 1999-2001 Takezou. <takeshi_kanno@est.hi-ho.ne.jp>
  5.  *
  6.  * This library is free software; you can redistribute it and/or modify it
  7.  * under the terms of the GNU Library General Public License as published
  8.  * by the Free Software Foundation; either version 2 of the License, or any
  9.  * later version.
  10.  *
  11.  * This library is distributed in the hope that it will be useful, but WITHOUT
  12.  * ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
  13.  * FOR A PARTICULAR PURPOSE. See the GNU Library general Public License for more
  14.  * details.
  15.  *
  16.  * You should have received a copy of the GNU Library General Public License
  17.  * along with this library.
  18.  *
  19.  * 2001.01.28 create
  20.  * 2001.06.24 added strech property to TPRImage.
  21.  * 2001.06.30 added chinese font(Experimental).
  22.  *            fixed TPRImage bug.
  23.  *            move TPRText.GetInternalDoc method to TPRItem.
  24.  * 2001.07.20 fixed font setting bugs.
  25.  * 2001.07.25 changed TPRPage text width routines.
  26.  * 2001.08.01 added TPReport.PageLayout.
  27.  * 2001.08.08 changed the algorithm of the free XObject name.
  28.  * 2001.08.10 changed the text width routine(bugs when large font size).
  29.  * 2001.08.15 added TPROutline and TPRDestination.
  30.  * 2001.09.01 changed the implementation of the image.
  31.  * 2001.09.08 added OpenAction function.
  32.  *            added AlignJustified property to TPRLabel.
  33.  * 2001.09.13 added ViewerPreference functions.
  34.  *            added check functions to TPReport.
  35.  *
  36.  *}
  37. unit PReport;
  38.  
  39. interface
  40.  
  41. //{$DEFINE USE_JPFONTS}
  42. //{$DEFINE USE_GBFONTS}
  43.  
  44. uses
  45.   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  46.   ExtCtrls, PdfDoc, PdfFonts, PdfTypes, PdfImages
  47.   {$IFDEF USE_JPFONTS}
  48.   , PdfJPFonts
  49.   {$ENDIF}
  50.   {$IFDEF USE_GBFONTS}
  51.   , PdfGBFonts
  52.   {$ENDIF}
  53.   ;
  54.  
  55. const
  56.   POWER_PDF_VERSION_STR = POWER_PDF_VERSION_TEXT;
  57.   POWER_PDF_COPYRIGHT = 'copyright (c) 1999-2001 takeshi kanno';
  58.  
  59. type
  60.   TPRFontName = (fnFixedWidth
  61.                , fnArial
  62.                , fnTimesRoman
  63.                {$IFDEF USE_JPFONTS}
  64.                , fnGothic
  65.                , fnMincyo
  66.                , fnPGothic
  67.                , fnPMincyo
  68.                {$ELSE}
  69.                {$IFDEF USE_GBFONTS}
  70.                , fnChinese
  71.                {$ENDIF}
  72.                {$ENDIF}
  73.                );
  74.   TPRPage = class;
  75.   TPRCanvas = class;
  76.   TPRPanel = class;
  77.   TPRItem = class;
  78.   TPROutlineEntry = class;
  79.   TPRDestination = class;
  80.   TPROutlineRoot = class;
  81.  
  82.   TPRPrintPageEvent = procedure(Sender: TObject;
  83.                               ACanvas: TPRCanvas) of object;
  84.   TPRPrintPanelEvent = procedure(Sender: TObject; ACanvas: TPRCanvas;
  85.                               Rect: TRect) of object;
  86.   TPRPrintItemEvent = TPRPrintPanelEvent;
  87.   TPRPrintChildPanelEvent = procedure(Sender: TObject; ACanvas: TPRCanvas;
  88.                               ACol, ARow: integer; Rect: TRect) of object;
  89.   TPrintDirection = (pdHorz, pdVert);
  90.   TPRDestinationType = TPdfDestinationType;
  91.   TPRPageLayout = TPdfPageLayout;
  92.   TPRPageMode = TPdfPageMode;
  93.   TPRCompressionMethod = TPdfCompressionMethod;
  94.   TPRViewerPreference = TPdfViewerPreference;
  95.   TPRViewerPreferences = TPdfViewerPreferences;
  96.  
  97.   { TPReport }
  98.   TPReport = class(TAbstractPReport)
  99.   private
  100.     FFileName: string;
  101.     FPage: integer;
  102.     FAuthor: string;
  103.     FCreationDate: TDateTime;
  104.     FCreator: string;
  105.     FKeywords: string;
  106.     FModDate: TDateTime;
  107.     FSubject: string;
  108.     FTitle: string;
  109.     FCanvas: TPRCanvas;
  110.     FDoc: TPdfDoc;
  111.     FPageMode: TPRPageMode;
  112.     FNonFullScreenPageMode: TPRPageMode;
  113.     FPageLayout: TPRPageLayout;
  114.     FCompressionMethod: TPRCompressionMethod;
  115.     FUseOutlines: boolean;
  116.     FOutlineRoot: TPROutlineRoot;
  117.     FOpenAction: TPRDestination;
  118.     FViewerPreference: TPRViewerPreferences;
  119.     procedure SetOpenAction(ADest: TPRDestination);
  120.     procedure SetAuthor(Value: string);
  121.     procedure SetCreationDate(Value: TDateTime);
  122.     procedure SetCreator(Value: string);
  123.     procedure SetKeyWords(Value: string);
  124.     procedure SetModDate(Value: TDateTime);
  125.     procedure SetSubject(Value: string);
  126.     procedure SetTitle(Value: string);
  127.     procedure SetPageLayout(Value: TPRPageLayout);
  128.     procedure SetPageMode(Value: TPRPageMode);
  129.     procedure SetNonFullScreenPageMode(Value: TPRPageMode);
  130.     procedure SetUseOutlines(Value: boolean);
  131.     procedure SetViewerPreference(Value: TPRViewerPreferences);
  132.     function GetOpenAction: TPRDestination;
  133.     function GetOutlineRoot: TPROutlineRoot;
  134.   protected
  135.     { Protected }
  136.   public
  137.     constructor Create(AOwner: TComponent); override;
  138.     destructor Destroy; override;
  139.     procedure BeginDoc;
  140.     procedure Print(APage: TPRPage);
  141.     procedure EndDoc;
  142.     procedure Abort;
  143.     function CreateDestination: TPRDestination;
  144.     function GetPdfDoc: TPdfDoc;
  145.     property PageNumber: integer read FPage;
  146.     property OutlineRoot: TPROutlineRoot read GetOutlineRoot;
  147.     property OpenAction: TPRDestination read GetOpenAction write SetOpenAction;
  148.   published
  149.     property FileName: string read FFileName write FFileName;
  150.     property Author: string read FAuthor write SetAuthor;
  151.     property CreationDate: TDateTime read FCreationDate write SetCreationDate;
  152.     property Creator: string read FCreator write SetCreator;
  153.     property Keywords: string read FKeyWords write SetKeyWords;
  154.     property ModDate: TDateTime read FModDate write SetModDate;
  155.     property Subject: string read FSubject write SetSubject;
  156.     property Title: string read FTitle write SetTitle;
  157.     property PageLayout: TPRPageLayout read FPageLayout
  158.                            write SetPageLayout default plSinglePage;
  159.     property PageMode: TPRPageMode read FPageMode
  160.                            write SetPageMode default pmUseNone;
  161.     property NonFullScreenPageMode: TPRPageMode read FNonFullScreenPageMode
  162.                            write SetNonFullScreenPageMode default pmUseNone;
  163.     property CompressionMethod: TPRCompressionMethod
  164.        read FCompressionMethod write FCompressionMethod default cmNone;
  165.     property UseOutlines: boolean read FUseOutlines write SetUseOutlines;
  166.     property ViewerPreference: TPRViewerPreferences
  167.                            read FViewerPreference write SetViewerPreference;
  168.   end;
  169.  
  170.   { TPRCanvas }
  171.   TPRCanvas = class(TPersistent)
  172.   private
  173.     FCanvas: TPdfCanvas;
  174.     procedure SetPdfCanvas(ACanvas: TPdfCanvas);
  175.     function GetPageHeight: integer;
  176.     function GetPageWidth: integer;
  177.   protected
  178.   public
  179.     constructor Create;
  180.     function TextWidth(Text: string): Single;
  181.     procedure SetCharSpace(charSpace: Single);
  182.     procedure SetWordSpace(wordSpace: Single);
  183.     procedure SetHorizontalScaling(hScaling: Word);
  184.     procedure SetLeading(leading: Single);
  185.     procedure SetFont(fontname: string; size: Single);
  186.     procedure SetTextRenderingMode(mode: TTextRenderingMode);
  187.     procedure SetTextRise(rise: Word);
  188.     procedure TextOut(X, Y: Single; Text: string);
  189.     procedure TextRect(ARect: TRect; Text: string;
  190.                             Alignment: TAlignment; Clipping: boolean);
  191.     property PdfCanvas: TPdfCanvas read FCanvas write SetPdfCanvas;
  192.     property PageHeight: integer read GetPageHeight;
  193.     property PageWidth: integer read GetPageWidth;
  194.   end;
  195.  
  196.   { TPRPage }
  197.   TPRPage = class(TCustompanel)
  198.   private
  199.     FDoc: TPdfDoc;
  200.     FMarginTop: integer;
  201.     FMarginLeft: integer;
  202.     FMarginRight: integer;
  203.     FMarginBottom: integer;
  204.     FPrintPageEvent: TPRPrintPageEvent;
  205.     procedure SetMarginTop(Value: integer);
  206.     procedure SetMarginLeft(Value: integer);
  207.     procedure SetMarginRight(Value: integer);
  208.     procedure SetMarginBottom(Value: integer);
  209.   protected
  210.     procedure AlignControls(AControl: TControl; var ARect: TRect); override;
  211.     procedure Paint; override;
  212.     procedure Print(ACanvas: TPRCanvas);
  213.     property InternalDoc: TPdfDoc read FDoc;
  214.   public
  215.     constructor Create(AOwner: TComponent); override;
  216.     destructor Destroy; override;
  217.   published
  218.     property OnPrintPage: TPRPrintPageEvent
  219.                      read FPrintPageEvent write FPrintPageEvent;
  220.     property MarginTop: integer read FMarginTop write SetMarginTop;
  221.     property MarginLeft: integer read FMarginLeft write SetMarginLeft;
  222.     property MarginRight: integer read FMarginRight write SetMarginRight;
  223.     property MarginBottom: integer read FMarginBottom write SetMarginBottom;
  224.     property Visible;
  225.   end;
  226.  
  227.   { TPRPanel }
  228.   TPRPanel = class(TCustomPanel)
  229.   private
  230.     function GetPage: TPRPage;
  231.     function GetAbsoluteRect: TRect;
  232.   protected
  233.     procedure Paint; override;
  234.     procedure Print(ACanvas: TPRCanvas; ARect: TRect); virtual;
  235.   public
  236.     property Page: TPRPage read GetPage;
  237.     constructor Create(AOwner: TComponent); override;
  238.   end;
  239.  
  240.   { TPRChildPanel }
  241.   TPRChildPanel = class(TPRPanel)
  242.   private
  243.   protected
  244.   end;
  245.  
  246.   { TPRLayoutPanel }
  247.   TPRLayoutPanel = class(TPRPanel)
  248.   private
  249.     FAfterPrint: TPRPrintPanelEvent;
  250.     FBeforePrint: TPRPrintPanelEvent;
  251.   protected
  252.     procedure SetParent(AParent: TWinControl); override;
  253.     procedure Print(ACanvas: TPRCanvas; ARect: TRect); override;
  254.   published
  255.     property Align;
  256.     property BeforePrint: TPRPrintPanelEvent
  257.                                 read FBeforePrint write FBeforePrint;
  258.     property AfterPrint: TPRPrintPanelEvent
  259.                                 read FAfterPrint write FAfterPrint;
  260.   end;
  261.  
  262.   { TRRGridPanel }
  263.   TPRGridPanel = class(TPRPanel)
  264.   private
  265.     FAfterPrint: TPRPrintPanelEvent;
  266.     FBeforePrint: TPRPrintPanelEvent;
  267.     FBeforePrintChild: TPRPrintChildPanelEvent;
  268.     FAfterPrintChild: TPRPrintChildPanelEvent;
  269.     FColCount: integer;
  270.     FRowCount: integer;
  271.     FChildPanel: TPRChildPanel;
  272.     FPrintDirection: TPrintDirection;
  273.     procedure SetColCount(Value: integer);
  274.     procedure SetRowCount(Value: integer);
  275.   protected
  276.     procedure Print(ACanvas: TPRCanvas; ARect: TRect); override;
  277.     procedure GetChildren(Proc: TGetChildProc; Root: TComponent); override;
  278.     procedure AlignControls(AControl: TControl; var ARect: TRect); override;
  279.     procedure Paint; override;
  280.     procedure SetParent(AParent: TWinControl); override;
  281.     function GetChildParent: TComponent; override;
  282.   public
  283.     constructor Create(AOwner: TComponent); override;
  284.     destructor Destroy; override;
  285.   published
  286.     property ColCount: integer read FColCount write SetColCount;
  287.     property RowCount: integer read FRowCount write SetRowCount;
  288.     property Align;
  289.     property PrintDirection: TPrintDirection
  290.                         read FPrintDirection write FPrintDirection default pdHorz;
  291.     property BeforePrint: TPRPrintPanelEvent
  292.                         read FBeforePrint write FBeforePrint;
  293.     property AfterPrint: TPRPrintPanelEvent
  294.                         read FAfterPrint write FAfterPrint;
  295.     property BeforePrintChild: TPRPrintChildPanelEvent
  296.                         read FBeforePrintChild write FBeforePrintChild;
  297.     property AfterPrintChild: TPRPrintChildPanelEvent
  298.                         read FAfterPrintChild write FAfterPrintChild;
  299.   end;
  300.  
  301.   { TPRItem }
  302.   TPRItem = class(TGraphicControl)
  303.   private
  304.     FPrintable: boolean;
  305.     function GetPage: TPRPage;
  306.   protected
  307.     procedure SetParent(AParent: TWinControl); override;
  308.     procedure Print(ACanvas: TPRCanvas; ARect: TRect); virtual;
  309.     function GetInternalDoc: TPdfDoc;
  310.     property Page: TPRPage read GetPage;
  311.   public
  312.     constructor Create(AOwner: TComponent); override;
  313.   published
  314.     property Align;
  315.     property Printable: boolean read FPrintable write FPrintable default true;
  316.   end;
  317.  
  318.   { TPRCustomLabel }
  319.   TPRCustomLabel = class(TPRItem)
  320.   private
  321.     FFontColor: TColor;
  322.     FFontName: TPRFontName;
  323.     FFontSize: Single;
  324.     FFontBold: boolean;
  325.     FFontItalic: boolean;
  326.     FCharSpace: Single;
  327.     FWordSpace: Single;
  328.     procedure SetCharSpace(Value: Single);
  329.     procedure SetWordSpace(Value: Single);
  330.     procedure SetFontColor(Value: TColor);
  331.     function GetFontClassName: string;
  332.     procedure SetFontName(Value: TPRFontName);
  333.     procedure SetFontItalic(Value: boolean);
  334.     procedure SetFontBold(Value: boolean);
  335.     procedure SetFontSize(Value: Single);
  336.   protected
  337.     function InternalTextout(APdfCanvas: TPdfCanvas;
  338.                         S: string; X, Y: integer): Single;
  339.     procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED;
  340.   public
  341.     constructor Create(AOwner: TComponent); override;
  342.   published
  343.     property FontColor: TColor read FFontColor write SetFontColor default clBlack;
  344.     property FontName: TPRFontName read FFontName write SetFontName;
  345.     property FontSize: Single read FFontSize write SetFontSize;
  346.     property FontBold: boolean read FFontBold write SetFontBold default false;
  347.     property FontItalic: boolean read FFontItalic write SetFontItalic default false;
  348.     property CharSpace: Single read FCharSpace write SetCharSpace;
  349.     property WordSpace: Single read FWordSpace write SetWordSpace;
  350.   end;
  351.  
  352.   { TPRLabel }
  353.   TPRLabel = class(TPRCustomLabel)
  354.   private
  355.     FAlignment: TAlignment;
  356.     FClipping: boolean;
  357.     FAlignJustified: boolean;
  358.     procedure SetAlignment(Value: TAlignment);
  359.     procedure SetAlignJustified(Value: boolean);
  360.     procedure SetCanvasProperties(ACanvas: TPdfCanvas);
  361.   protected
  362.     procedure Paint; override;
  363.     procedure Print(ACanvas: TPRCanvas; ARect: TRect); override;
  364.   published
  365.     function GetTextWidth: Single;
  366.     property Caption;
  367.     property Clipping: boolean read FClipping write FClipping default false;
  368.     property Alignment: TAlignment read FAlignment
  369.                      write SetAlignment default taLeftJustify;
  370.     property AlignJustified: boolean read FAlignJustified write SetAlignJustified default false;
  371.   end;
  372.  
  373.   { TPRText }
  374.   TPRText = class(TPRCustomLabel)
  375.   private
  376.     FWordwrap: boolean;
  377.     FLeading: Single;
  378.     FLines: TStrings;
  379.     procedure SetLeading(Value: Single);
  380.     procedure SetWordwrap(Value: boolean);
  381.     procedure SetLines(Value: TStrings);
  382.     procedure SetText(Value: string);
  383.     function GetText: string;
  384.     function GetLines: TStrings;
  385.   protected
  386.     procedure Paint; override;
  387.     procedure Print(ACanvas: TPRCanvas; ARect: TRect); override;
  388.   public
  389.     constructor Create(AOwner: TComponent); override;
  390.     destructor Destroy; override;
  391.     property Text: string read GetText write SetText;
  392.   published
  393.     property Leading: Single read FLeading write SetLeading;
  394.     property Lines: TStrings read GetLines write SetLines;
  395.     property WordWrap: boolean read FWordWrap write SetWordwrap default false;
  396.   end;
  397.  
  398.   { TPRShape }
  399.   TPRShape = class(TPRItem)
  400.   private
  401.     FLineWidth: Single;
  402.     FLineColor: TColor;
  403.     FLineStyle: TPenStyle;
  404.     FFillColor: TColor;
  405.     procedure SetLineColor(Value: TColor);
  406.     procedure SetFillColor(Value: TColor);
  407.     procedure SetLineWidth(Value: Single);
  408.     procedure SetLineStyle(Value: TPenStyle);
  409.   protected
  410.     procedure SetDash(ACanvas: TPdfCAnvas; APattern: TPenStyle);
  411.   public
  412.     constructor Create(AOwner: TComponent); override;
  413.   published
  414.     property LineWidth: Single read FLineWidth write SetLineWidth;
  415.     property LineColor: TColor read FLineColor write SetLineColor default clBlack;
  416.     property LineStyle: TPenStyle read FLineStyle write SetLineStyle;
  417.     property FillColor: TColor read FFillColor write SetFillColor default clNone;
  418.   end;
  419.  
  420.   { TPRRect }
  421.   TPRRect = class(TPRShape)
  422.   protected
  423.     procedure Paint; override;
  424.     procedure Print(ACanvas: TPRCanvas; ARect: TRect); override;
  425.   end;
  426.  
  427.   { TPREllipse }
  428.   TPREllipse = class(TPRShape)
  429.   protected
  430.     procedure Paint; override;
  431.     procedure Print(ACanvas: TPRCanvas; ARect: TRect); override;
  432.   end;
  433.  
  434.   { TPRImage }
  435.   TPRImage = class(TPRItem)
  436.   private
  437.     procedure SetStretch(Value: boolean);
  438.   protected
  439.     FPicture: TPicture;
  440.     FSharedImage: boolean;
  441.     FStretch: boolean;
  442.     procedure SetPicture(Value: TPicture); virtual;
  443.     procedure Paint; override;
  444.     procedure Print(ACanvas: TPRCanvas; ARect: TRect); override;
  445.   public
  446.     constructor Create(AOwner: TComponent); override;
  447.     destructor Destroy; override;
  448.   published
  449.     property Picture: TPicture read FPicture write SetPicture;
  450.     property SharedImage: boolean read FSharedImage write FSharedImage;
  451.     property Stretch: boolean read FStretch write SetStretch default true;
  452.   end;
  453.  
  454.   { TPRDestination }
  455.   TPRDestination = class(TObject)
  456.   private
  457.     FData: TPdfDestination;
  458.     procedure SetType(Value: TPRDestinationType);
  459.     function GetType: TPRDestinationType;
  460.     procedure SetElement(Index: integer; Value: Integer);
  461.     procedure SetZoom(Value: Single);
  462.     function GetElement(Index: integer): Integer;
  463.     function GetZoom: Single;
  464.   protected
  465.     constructor Create(AData: TPdfDestination);
  466.   public
  467.     property Data: TPdfDestination read FData;
  468.     property DestinationType: TPRDestinationType read GetType write SetType;
  469.     property Left: Integer index 0 read GetElement write SetElement;
  470.     property Top: Integer index 1 read GetElement write SetElement;
  471.     property Right: Integer index 2 read GetElement write SetElement;
  472.     property Bottom: Integer index 3 read GetElement write SetElement;
  473.     property Zoom: Single read GetZoom write SetZoom;
  474.   end;
  475.  
  476.   { TPROutlineEntry }
  477.   TPROutlineEntry = class(TObject)
  478.   private
  479.     FData: TPdfOutlineEntry;
  480.     function GetParent: TPROutlineEntry;
  481.     function GetNext: TPROutlineEntry;
  482.     function GetPrev: TPROutlineEntry;
  483.     function GetFirst: TPROutlineEntry;
  484.     function GetLast: TPROutlineEntry;
  485.     function GetDest: TPRDestination;
  486.     function GetTitle: string;
  487.     function GetOpened: boolean;
  488.     procedure SetDest(Value: TPRDestination);
  489.     procedure SetTitle(Value: string);
  490.     procedure SetOpened(Value: boolean);
  491.   public
  492.     function AddChild: TPROutlineEntry;
  493.     property Parent: TPROutlineEntry read GetParent;
  494.     property Next: TPROutlineEntry read GetNext;
  495.     property Prev: TPROutlineEntry read GetPrev;
  496.     property First: TPROutlineEntry read GetFirst;
  497.     property Last: TPROutlineEntry read GetLast;
  498.     property Dest: TPRDestination read GetDest write SetDest;
  499.     property Title: string read GetTitle write SetTitle;
  500.     property Opened: boolean read GetOpened write SetOpened;
  501.   end;
  502.  
  503.   { TPROutlineRoot }
  504.   TPROutlineRoot = class(TPROutlineEntry)
  505.   protected
  506.     constructor CreateRoot(ADoc: TPdfDoc);
  507.   end;
  508.  
  509.  
  510. const
  511.   LINE_PITCH: integer = 378;
  512.   LINE_COLOR: TColor = clSilver;
  513.   DEFAULT_MARGIN = 32;
  514.   PROTECT_AREA_COLOR: TColor = $00EFEFEF;
  515.   MIN_PANEL_SIZE = 10;
  516.   MAX_IMAGE_NUMBER = 65535;
  517. {$IFDEF USE_JPFONTS}
  518.   PDFFONT_CLASS_NAMES: array[0..6] of string = (
  519.                            'FixedWidth',
  520.                            'Arial',
  521.                            'Times-Roman',
  522.                            'Gothic',
  523.                            'Mincyo',
  524.                            'PGothic',
  525.                            'PMincyo');
  526.   PDFFONT_CLASS_BOLD_NAMES: array[0..6] of string = (
  527.                            'FixedWidth-Bold',
  528.                            'Arial-Bold',
  529.                            'Times-Bold',
  530.                            'Gothic,Bold',
  531.                            'Mincyo,Bold',
  532.                            'PGothic,Bold',
  533.                            'PMincyo,Bold');
  534.   PDFFONT_CLASS_ITALIC_NAMES: array[0..6] of string = (
  535.                            'FixedWidth-Italic',
  536.                            'Arial-Italic',
  537.                            'Times-Italic',
  538.                            'Gothic,Italic',
  539.                            'Mincyo,Italic',
  540.                            'PGothic,Italic',
  541.                            'PMincyo,Italic');
  542.   PDFFONT_CLASS_BOLDITALIC_NAMES: array[0..6] of string = (
  543.                            'FixedWidth-BoldItalic',
  544.                            'Arial-BoldItalic',
  545.                            'Times-BoldItalic',
  546.                            'Gothic,BoldItalic',
  547.                            'Mincyo,BoldItalic',
  548.                            'PGothic,BoldItalic',
  549.                            'PMincyo');
  550.   ITEM_FONT_NAMES: array[0..6] of string = (
  551.                            'Courier New',
  552.                            'Arial',
  553.                            'Times New Roman',
  554.                            #130#108#130#114#32#131#83#131#86#131#98#131#78,
  555.                            #130#108#130#114#32#150#190#146#169,
  556.                            #130#108#130#114#32#130#111#131#83#131#86#131#98#131#78,
  557.                            #130#108#130#114#32#130#111#150#190#146#169);
  558.   ITEM_FONT_CHARSETS: array[0..6] of TFontCharset = (
  559.                            ANSI_CHARSET,
  560.                            ANSI_CHARSET,
  561.                            ANSI_CHARSET,
  562.                            SHIFTJIS_CHARSET,
  563.                            SHIFTJIS_CHARSET,
  564.                            SHIFTJIS_CHARSET,
  565.                            SHIFTJIS_CHARSET);
  566. {$ELSE}
  567. {$IFDEF USE_GBFONTS}
  568.   PDFFONT_CLASS_NAMES: array[0..3] of string = (
  569.                            'FixedWidth',
  570.                            'Arial',
  571.                            'Times-Roman',
  572.                            'Chinese');
  573.   PDFFONT_CLASS_BOLD_NAMES: array[0..3] of string = (
  574.                            'FixedWidth-Bold',
  575.                            'Arial-Bold',
  576.                            'Times-Bold',
  577.                            'Chinese');
  578.   PDFFONT_CLASS_ITALIC_NAMES: array[0..3] of string = (
  579.                            'FixedWidth-Italic',
  580.                            'Arial-Italic',
  581.                            'Times-Italic',
  582.                            'Chinese');
  583.   PDFFONT_CLASS_BOLDITALIC_NAMES: array[0..3] of string = (
  584.                            'FixedWidth-BoldItalic',
  585.                            'Arial-BoldItalic',
  586.                            'Times-BoldItalic',
  587.                            'Chinese');
  588.   ITEM_FONT_NAMES: array[0..3] of string = (
  589.                            'Courier New',
  590.                            'Arial',
  591.                            'TimesNewRoman',
  592.                            'Chinese');
  593.   ITEM_FONT_CHARSETS: array[0..3] of TFontCharset = (
  594.                            ANSI_CHARSET,
  595.                            ANSI_CHARSET,
  596.                            ANSI_CHARSET,
  597.                            GB2312_CHARSET);
  598. {$ELSE}
  599.   PDFFONT_CLASS_NAMES: array[0..2] of string = (
  600.                            'FixedWidth',
  601.                            'Arial',
  602.                            'Times-Roman');
  603.   PDFFONT_CLASS_BOLD_NAMES: array[0..2] of string = (
  604.                            'FixedWidth-Bold',
  605.                            'Arial-Bold',
  606.                            'Times-Bold');
  607.   PDFFONT_CLASS_ITALIC_NAMES: array[0..2] of string = (
  608.                            'FixedWidth-Italic',
  609.                            'Arial-Italic',
  610.                            'Times-Italic');
  611.   PDFFONT_CLASS_BOLDITALIC_NAMES: array[0..2] of string = (
  612.                            'FixedWidth-BoldItalic',
  613.                            'Arial-BoldItalic',
  614.                            'Times-BoldItalic');
  615.   ITEM_FONT_NAMES: array[0..2] of string = (
  616.                            'Courier New',
  617.                            'Arial',
  618.                            'Times New Roman');
  619.   ITEM_FONT_CHARSETS: array[0..2] of TFontCharset = (
  620.                            ANSI_CHARSET,
  621.                            ANSI_CHARSET,
  622.                            ANSI_CHARSET);
  623. {$ENDIF}
  624. {$ENDIF}
  625.  
  626. implementation
  627.  
  628. { common routines }
  629.  
  630. procedure PaintGrid(Canvas: TCanvas; Width, Height: integer;
  631.   OffsetX, OffsetY: integer);
  632. var
  633.   LinePos: integer;
  634.   LineCount: integer;
  635.   LineFlg: boolean;
  636.  
  637.   // sub routine to set pen style
  638.   procedure SetPen(Canvas: TCanvas; flg: boolean);
  639.   begin
  640.     Canvas.Pen.Color := LINE_COLOR;
  641.     if flg then
  642.       Canvas.Pen.Style := psSolid
  643.     else
  644.       Canvas.Pen.Style := psDot;
  645.   end;
  646.  
  647. begin
  648.   with Canvas do
  649.   begin
  650.     // drawing vertical lines.
  651.     LineCount := 0;
  652.     LineFlg := true;
  653.     LinePos := - OffsetX;
  654.     while LinePos < Width do
  655.     begin
  656.       if LinePos > 0 then
  657.       begin
  658.         MoveTo(LinePos, 0);
  659.         SetPen(Canvas, LineFlg);
  660.         LineTo(LinePos, Height - 1);
  661.       end;
  662.       inc(LineCount);
  663.       LineFlg := not LineFlg;
  664.       LinePos := trunc(LineCount * LINE_PITCH / 20) - OffsetX;
  665.     end;
  666.  
  667.     // drawing horizontal lines.
  668.     LineCount := 0;
  669.     LineFlg := true;
  670.     LinePos := - OffsetY;
  671.     while LinePos < Height do
  672.     begin
  673.       if LinePos > 0 then
  674.       begin
  675.         MoveTo(0, LinePos);
  676.         SetPen(Canvas, LineFlg);
  677.         LineTo(Width - 1, LinePos);
  678.       end;
  679.       inc(LineCount);
  680.       LineFlg := not LineFlg;
  681.       LinePos := trunc(LineCount * LINE_PITCH / 20) - OffsetY;
  682.     end;
  683.   end;
  684. end;
  685.  
  686. { TPReport }
  687.  
  688. // Create
  689. constructor TPReport.Create(AOwner: TComponent);
  690. begin
  691.   inherited Create(AOwner);
  692.   FFileName := 'default.pdf';
  693.   FCreationDate := now;
  694.   FDoc := nil;
  695.   FCanvas := TPRCanvas.Create;
  696. end;
  697.  
  698. // Destroy
  699. destructor TPReport.Destroy;
  700. begin
  701.   FCanvas.Free;
  702.   if FDoc <> nil then Abort;
  703.   inherited;
  704. end;
  705.  
  706. // BeginDoc
  707. procedure TPReport.BeginDoc;
  708. begin
  709.   if FDoc <> nil then Abort;
  710.   FDoc := TPdfDoc.Create;
  711.   with FDoc do
  712.   begin
  713.     UseOutlines := Self.UseOutlines;
  714.     CompressionMethod := FCompressionMethod;
  715.     NewDoc;
  716.     if UseOutlines then
  717.       FOutlineRoot := TPROutlineRoot.CreateRoot(FDoc);
  718.     Root.PageMode := PageMode;
  719.     Root.PageLayout := PageLayout;
  720.     if NonFullScreenPageMode <> pmUseNone then
  721.       Root.NonFullScreenPageMode := NonFullScreenPageMode;
  722.     if ViewerPreference <> [] then
  723.       Root.ViewerPreference := ViewerPreference;
  724.     Info.Author := Author;
  725.     Info.CreationDate := CreationDate;
  726.     Info.Creator := Creator;
  727.     Info.Keywords := Keywords;
  728.     Info.ModDate := ModDate;
  729.     Info.Subject := Subject;
  730.     Info.Title := Title;
  731.   end;
  732.   FPage := 0;
  733. end;
  734.  
  735. // Print
  736. procedure TPReport.Print(APage: TPRPage);
  737. begin
  738.   FDoc.AddPage;
  739.   inc(FPage);
  740.   FCanvas.PdfCanvas := FDoc.Canvas;
  741.   APage.Print(FCanvas);
  742. end;
  743.  
  744. // EndDoc
  745. procedure TPReport.EndDoc;
  746. var
  747.   FStream: TStream;
  748. begin
  749.   if FDoc <> nil then
  750.   begin
  751.     FStream := TFileStream.Create(FFileName, fmCreate);
  752.     FDoc.SaveToStream(FStream);
  753.     FStream.Free;
  754.     FDoc.Free;
  755.     FDoc := nil;
  756.     FOutlineRoot := nil;
  757.   end
  758.   else
  759.     raise EInvalidOperation.Create('document is null..');
  760. end;
  761.  
  762. // Abort
  763. procedure TPReport.Abort;
  764. begin
  765.   if FDoc <> nil then
  766.   begin
  767.     FDoc.Free;
  768.     FDoc := nil;
  769.     FOutlineRoot := nil;
  770.   end
  771. end;
  772.  
  773. // SetOpenAction
  774. procedure TPReport.SetOpenAction(ADest: TPRDestination);
  775. begin
  776.   if (FDoc = nil) or not (FDoc.HasDoc) then
  777.     raise EPdfInvalidOperation.Create('SetOpenAction --invalid operation.')
  778.   else
  779.   begin
  780.     FDoc.Root.OpenAction := ADest.FData;
  781.     FOpenAction := ADest;
  782.   end;
  783. end;
  784.  
  785. // SetAuthor
  786. procedure TPReport.SetAuthor(Value: string);
  787. begin
  788.   if FDoc <> nil then
  789.     raise EPdfInvalidOperation.Create('SetAuthor --invalid operation.');
  790.   FAuthor := Value;
  791. end;
  792.  
  793. // SetCreationDate
  794. procedure TPReport.SetCreationDate(Value: TDateTime);
  795. begin
  796.   if FDoc <> nil then
  797.     raise EPdfInvalidOperation.Create('SetCreationDate --invalid operation.');
  798.   FCreationDate := Value;
  799. end;
  800.  
  801. // SetCreator
  802. procedure TPReport.SetCreator(Value: string);
  803. begin
  804.   if FDoc <> nil then
  805.     raise EPdfInvalidOperation.Create('SetCreator --invalid operation.');
  806.   FCreator := Value;
  807. end;
  808.  
  809. // SetKeyWords
  810. procedure TPReport.SetKeyWords(Value: string);
  811. begin
  812.   if FDoc <> nil then
  813.     raise EPdfInvalidOperation.Create('SetKeyWords --invalid operation.');
  814.   FKeyWords := Value;
  815. end;
  816.  
  817. // SetModDate
  818. procedure TPReport.SetModDate(Value: TDateTime);
  819. begin
  820.   if FDoc <> nil then
  821.     raise EPdfInvalidOperation.Create('SetModDate --invalid operation.');
  822.   FModDate := Value;
  823. end;
  824.  
  825. // SetSubject
  826. procedure TPReport.SetSubject(Value: string);
  827. begin
  828.   if FDoc <> nil then
  829.     raise EPdfInvalidOperation.Create('SetSubject --invalid operation.');
  830.   FSubject := Value;
  831. end;
  832.  
  833. // SetTitle
  834. procedure TPReport.SetTitle(Value: string);
  835. begin
  836.   if FDoc <> nil then
  837.     raise EPdfInvalidOperation.Create('SetTitle --invalid operation.');
  838.   FTitle := Value;
  839. end;
  840.  
  841. // SetPageLayout
  842. procedure TPReport.SetPageLayout(Value: TPRPageLayout);
  843. begin
  844.   if FDoc <> nil then
  845.     raise EPdfInvalidOperation.Create('SetPageLayout --invalid operation.');
  846.   FPageLayout := Value;
  847. end;
  848.  
  849. // SetPageMode
  850. procedure TPReport.SetPageMode(Value: TPRPageMode);
  851. begin
  852.   if FDoc <> nil then
  853.     raise EPdfInvalidOperation.Create('SetPageMode --invalid operation.');
  854.   FPageMode := Value;
  855. end;
  856.  
  857. // SetNonFullScreenPageMode
  858. procedure TPReport.SetNonFullScreenPageMode(Value: TPRPageMode);
  859. begin
  860.   if FDoc <> nil then
  861.     raise EPdfInvalidOperation.Create('SetNonFullScreenPageMode --invalid operation.');
  862.   if Value = pmFullScreen then
  863.     FNonFullScreenPageMode := pmUseNone
  864.   else
  865.     FNonFullScreenPageMode := Value;
  866. end;
  867.  
  868. // SetUseOutlines
  869. procedure TPReport.SetUseOutlines(Value: boolean);
  870. begin
  871.   if FDoc <> nil then
  872.     raise EPdfInvalidOperation.Create('SetUseOutlines --invalid operation.');
  873.   FUseOutlines := Value;
  874. end;
  875.  
  876. // SetViewerPreference
  877. procedure TPReport.SetViewerPreference(Value: TPRViewerPreferences);
  878. begin
  879.   if FDoc <> nil then
  880.     raise EPdfInvalidOperation.Create('SetViewerPreference --invalid operation.');
  881.   FViewerPreference := Value;
  882. end;
  883.  
  884. // GetOpenAction
  885. function TPReport.GetOpenAction: TPRDestination;
  886. begin
  887.   if (FDoc = nil) or not (FDoc.HasDoc) then
  888.     raise EPdfInvalidOperation.Create('GetOpenAction --invalid operation.')
  889.   else
  890.     result := FOpenAction;
  891. end;
  892.  
  893. // GetPdfDoc
  894. function TPReport.GetPdfDoc: TPdfDoc;
  895. begin
  896.   result := FDoc;
  897. end;
  898.  
  899. // GetOutlineRoot
  900. function TPReport.GetOutlineRoot: TPROutlineRoot;
  901. begin
  902.   if (FDoc = nil) or not (FDoc.HasDoc) or not (FUseOutlines) then
  903.     raise EPdfInvalidOperation.Create('GetOutlineRoot --invalid operation.')
  904.   else
  905.     result := FOutlineRoot;
  906. end;
  907.  
  908. // CreateDestination
  909. function TPReport.CreateDestination: TPRDestination;
  910. begin
  911.   if (FDoc = nil) or not (FDoc.HasDoc) then
  912.     raise EPdfInvalidOperation.Create('CreateDestination --invalid operation.')
  913.   else
  914.   begin
  915.     result := TPRDestination.Create(FDoc.CreateDestination);
  916.     result.Top := -10;
  917.     result.Zoom := 1;
  918.   end;
  919. end;
  920.  
  921. { TPRCanvas }
  922.  
  923. // Create
  924. constructor TPRCanvas.Create;
  925. begin
  926.   inherited;
  927.   FCanvas := nil;
  928. end;
  929.  
  930. // SetPdfCanvas
  931. procedure TPRCanvas.SetPdfCanvas(ACanvas: TPdfCanvas);
  932. begin
  933.   FCanvas := ACanvas;
  934. end;
  935.  
  936. // GetPageHeight
  937. function TPRCanvas.GetPageHeight: integer;
  938. begin
  939.   result := PdfCanvas.PageHeight;
  940. end;
  941.  
  942. // GetPageWidth
  943. function TPRCanvas.GetPageWidth: integer;
  944. begin
  945.   result := PdfCanvas.PageWidth;
  946. end;
  947.  
  948. // SetCharSpace
  949. procedure TPRCanvas.SetCharSpace(charSpace: Single);
  950. begin
  951.   PdfCanvas.SetCharSpace(charSpace);
  952. end;
  953.  
  954. // SetWordSpace
  955. procedure TPRCanvas.SetWordSpace(wordSpace: Single);
  956. begin
  957.   PdfCanvas.SetWordSpace(wordSpace);
  958. end;
  959.  
  960. // SetHorizontalScaling
  961. procedure TPRCanvas.SetHorizontalScaling(hScaling: Word);
  962. begin
  963.   PdfCanvas.SetHorizontalScaling(hScaling);
  964. end;
  965.  
  966. // SetLeading
  967. procedure TPRCanvas.SetLeading(leading: Single);
  968. begin
  969.   PdfCanvas.SetLeading(leading);
  970. end;
  971.  
  972. // SetFont
  973. procedure TPRCanvas.SetFont(fontname: string; size: Single);
  974. begin
  975.   PdfCanvas.SetFont(fontname, size);
  976. end;
  977.  
  978. // SetTextRenderingMode
  979. procedure TPRCanvas.SetTextRenderingMode(mode: TTextRenderingMode);
  980. begin
  981.   PdfCanvas.SetTextRenderingMode(mode);
  982. end;
  983.  
  984. // SetTextRise
  985. procedure TPRCanvas.SetTextRise(rise: Word);
  986. begin
  987.   PdfCanvas.SetTextRise(rise);
  988. end;
  989.  
  990. // TextOut
  991. procedure TPRCanvas.TextOut(X, Y: Single; Text: string);
  992. begin
  993.   with PdfCanvas do
  994.     TextOut(X, PageHeight - Y - Attribute.FontSize * 0.85, Text);
  995. end;
  996.  
  997. // TextRect
  998. procedure TPRCanvas.TextRect(ARect: TRect; Text: string;
  999.                             Alignment: TAlignment; Clipping: boolean);
  1000. begin
  1001.   with ARect, PdfCanvas do
  1002.     TextRect(_PdfRect(Left, PageHeight - Top, Right,
  1003.       PageHeight - Bottom), Text, TPdfAlignment(ord(Alignment)), Clipping);
  1004. end;
  1005.  
  1006. // TextWidth
  1007. function TPRCanvas.TextWidth(Text: string): Single;
  1008. begin
  1009.   result := PdfCanvas.TextWidth(Text);
  1010. end;
  1011.  
  1012. { TPRPage }
  1013.  
  1014. // Create
  1015. constructor TPRPage.Create(AOwner: TComponent);
  1016. begin
  1017.   inherited Create(AOwner);
  1018.   Width := PDF_DEFAULT_PAGE_WIDTH;
  1019.   Height := PDF_DEFAULT_PAGE_HEIGHT;
  1020.   FMarginTop := DEFAULT_MARGIN;
  1021.   FMarginLeft := DEFAULT_MARGIN;
  1022.   FMarginRight := DEFAULT_MARGIN;
  1023.   FMarginBottom := DEFAULT_MARGIN;
  1024.   // create internel doc
  1025.   FDoc := TPdfDoc.Create;
  1026.   FDoc.SetVirtualMode;
  1027. end;
  1028.  
  1029. // Destroy
  1030. destructor TPRPage.Destroy;
  1031. begin
  1032.   FDoc.Free;
  1033.   inherited;
  1034. end;
  1035.  
  1036. // AlignControls
  1037. procedure TPRPage.AlignControls(AControl: TControl; var ARect: TRect);
  1038. begin
  1039.   ARect := Rect(ARect.Left + FMarginLeft, ARect.Top + FMarginTop,
  1040.     ARect.Right - FMarginRight, ARect.Bottom - FMarginBottom);
  1041.   inherited AlignControls(AControl, ARect);
  1042. end;
  1043.  
  1044. // Paint
  1045. procedure TPRPage.Paint;
  1046. var
  1047.   LinePos: integer;
  1048.   LineCount: Integer;
  1049. begin
  1050.   inherited Paint;
  1051.  
  1052.   with Canvas do
  1053.   begin
  1054.     Brush.Color := clWhite;
  1055.     FillRect(GetClientRect);
  1056.     PaintGrid(Canvas, Width, Height, 0, 0);
  1057.     Font.Size := 8;
  1058.     Font.Color := clSilver;
  1059.  
  1060.     LineCount := 0;
  1061.     LinePos := 0;
  1062.     while LinePos < Width do
  1063.     begin
  1064.       TextOut(LinePos + 1, 1, IntToStr(LineCount));
  1065.       inc(LineCount);
  1066.       LinePos := trunc(LineCount * LINE_PITCH / 10);
  1067.     end;
  1068.     LineCount := 0;
  1069.     LinePos := 0;
  1070.     while LinePos < Height do
  1071.     begin
  1072.       TextOut(1, LinePos + 1, IntToStr(LineCount));
  1073.       inc(LineCount);
  1074.       LinePos := trunc(LineCount * LINE_PITCH / 10);
  1075.     end;
  1076.  
  1077.     Font := Self.Font;
  1078.     TextOut(4, 4, Name);
  1079.   end;
  1080. end;
  1081.  
  1082. // Print
  1083. procedure TPRPage.Print(ACanvas: TPRCanvas);
  1084. var
  1085.   i: integer;
  1086. begin
  1087.   with ACanvas.PdfCanvas do
  1088.   begin
  1089.     PageHeight := Height;
  1090.     PageWidth := Width;
  1091.   end;
  1092.   if Assigned(FPrintPageEvent) then
  1093.     FPrintPageEvent(Self, ACanvas);
  1094.   for i := 0 to ControlCount - 1 do
  1095.   begin
  1096.     if (Controls[i] is TPRPanel) then
  1097.       with (Controls[i] as TPRPanel) do
  1098.         Print(ACanvas, BoundsRect);
  1099.   end;
  1100. end;
  1101.  
  1102. // SetMarginTop
  1103. procedure TPRPage.SetMarginTop(Value: integer);
  1104. var
  1105.   Rect: TRect;
  1106. begin
  1107.   if (FMarginTop <> Value) and (Value >= 0) and (Value < Width div 2) then
  1108.   begin
  1109.     Rect := ClientRect;
  1110.     FMarginTop := Value;
  1111.     AlignControls(nil, Rect);
  1112.   end;
  1113. end;
  1114.  
  1115. // SetMarginLeft
  1116. procedure TPRPage.SetMarginLeft(Value: integer);
  1117. var
  1118.   Rect: TRect;
  1119. begin
  1120.   if (FMarginLeft <> Value) and (Value >= 0) and (Value < Width div 2) then
  1121.   begin
  1122.     Rect := ClientRect;
  1123.     FMarginLeft := Value;
  1124.     AlignControls(nil, Rect);
  1125.   end;
  1126. end;
  1127.  
  1128. // SetMarginRight
  1129. procedure TPRPage.SetMarginRight(Value: integer);
  1130. var
  1131.   Rect: TRect;
  1132. begin
  1133.   if (FMarginRight <> Value) and (Value >= 0) and (Value < Width div 2) then
  1134.   begin
  1135.     Rect := ClientRect;
  1136.     FMarginRight := Value;
  1137.     AlignControls(nil, Rect);
  1138.   end;
  1139. end;
  1140.  
  1141. // SSetMarginBottom
  1142. procedure TPRPage.SetMarginBottom(Value: integer);
  1143. var
  1144.   Rect: TRect;
  1145. begin
  1146.   if (FMarginBottom <> Value) and (Value >= 0) and (Value < Width div 2) then
  1147.   begin
  1148.     Rect := ClientRect;
  1149.     FMarginBottom := Value;
  1150.     AlignControls(nil, Rect);
  1151.   end;
  1152. end;
  1153.  
  1154. { TPRPanel }
  1155.  
  1156. // Create
  1157. constructor TPRPanel.Create(AOwner: TComponent);
  1158. begin
  1159.   inherited Create(AOwner);
  1160. //  Align := alTop;
  1161.   Height := 100;
  1162.   BevelOuter := bvNone;
  1163.   Color := clWindow;
  1164.   BorderStyle := bsNone;
  1165. end;
  1166.  
  1167. // GetPage
  1168. function TPRPanel.GetPage: TPRPage;
  1169. begin
  1170.   if (Parent is TPRPage) then
  1171.     result := TPRPage(Parent)
  1172.   else
  1173.     result := (Parent as TPRPanel).GetPage;
  1174. end;
  1175.  
  1176. // Paint
  1177. procedure TPRPanel.Paint;
  1178. var
  1179.   TmpRect: TRect;
  1180. begin
  1181.   with Canvas do
  1182.   begin
  1183.     Brush.Color := clWhite;
  1184.     FillRect(Rect(0,0,Width,Height));
  1185.     TmpRect := GetAbsoluteRect;
  1186.     PaintGrid(Canvas, Width, Height, TmpRect.Left, TmpRect.Top);
  1187.     TextOut(2, 2, Name);
  1188.     Pen.Color := clGreen;
  1189.     Pen.Style := psDot;
  1190.     MoveTo(0,0);
  1191.     LineTo(Width-1,0);
  1192.     LineTo(Width-1,Height-1);
  1193.     LineTo(0,Height-1);
  1194.     LineTo(0,0);
  1195.   end;
  1196. end;
  1197.  
  1198. // GetAbsoluteRect
  1199. function TPRPanel.GetAbsoluteRect: TRect;
  1200. begin
  1201.   // return absolute position which based on TPRPage.
  1202.   if (Parent is TPRPanel) then
  1203.   begin
  1204.     result := TPRPanel(Parent).GetAbsoluteRect;
  1205.     OffsetRect(result, Left, Top);
  1206.   end
  1207.   else
  1208.     result := Rect(Left, Top, Left+Width, Top+Height);
  1209. end;
  1210.  
  1211. // Print
  1212. procedure TPRPanel.Print(ACanvas: TPRCanvas; ARect: TRect);
  1213. var
  1214.   i: integer;
  1215.   tmpRect: TRect;
  1216. begin
  1217.   for i := 0 to ControlCount - 1 do
  1218.   begin
  1219.     tmpRect := Controls[i].BoundsRect;
  1220.     OffsetRect(tmpRect, ARect.Left, ARect.Top);
  1221.     if (Controls[i] is TPRPanel) then
  1222.       TPRPanel(Controls[i]).Print(ACanvas, tmpRect)
  1223.     else
  1224.     if (Controls[i] is TPRItem) then
  1225.       if TPRItem(Controls[i]).Printable then
  1226.         TPRItem(Controls[i]).Print(ACanvas, tmpRect);
  1227.   end;
  1228. end;
  1229.  
  1230. { TPRLayoutPanel }
  1231.  
  1232. // SetParent
  1233. procedure TPRLayoutPanel.SetParent(AParent: TWinControl);
  1234. begin
  1235.   if (AParent <> nil) and
  1236.    (not (AParent is TPRPanel) and not (AParent is TPRPage)) then
  1237.     raise Exception.Create('TPRPage can not set on ' + AParent.ClassName);
  1238.   if (AParent is TPRGridPanel) then
  1239.     AParent := TPRGridPanel(AParent).FChildPanel;
  1240.   inherited SetParent(AParent);
  1241. end;
  1242.  
  1243. // Print
  1244. procedure TPRLayoutPanel.Print(ACanvas: TPRCanvas; ARect: TRect);
  1245. begin
  1246.   if Assigned(FBeforePrint) then
  1247.     FBeforePrint(Self, ACanvas, ARect);
  1248.     
  1249.   inherited Print(ACanvas, ARect);
  1250.  
  1251.   if Assigned(FAfterPrint) then
  1252.     FAfterPrint(Self, ACanvas, ARect);
  1253. end;
  1254.  
  1255. { TPRGridPanel }
  1256.  
  1257. // Create
  1258. constructor TPRGridPanel.Create(AOwner: TComponent);
  1259. begin
  1260.   inherited Create(AOwner);
  1261.   FColCount := 1;
  1262.   FRowCount := 1;
  1263.   FChildPanel := TPRChildPanel.Create(Self);
  1264.   FChildPanel.Align := alClient;
  1265.   FChildPanel.Parent := Self;
  1266. end;
  1267.  
  1268. // Destroy
  1269. destructor TPRGridPanel.Destroy;
  1270. begin
  1271.   FChildPanel.Free;
  1272.   inherited;
  1273. end;
  1274.  
  1275. // GetChildParent
  1276. function TPRGridPanel.GetChildParent: TComponent;
  1277. begin
  1278.   Result := FChildPanel;
  1279. end;
  1280.  
  1281. // GetChildren
  1282. procedure TPRGridPanel.GetChildren(Proc: TGetChildProc; Root: TComponent);
  1283. begin
  1284.   FChildPanel.GetChildren(Proc, Root);
  1285. end;
  1286.  
  1287. // AlignControls
  1288. procedure TPRGridPanel.AlignControls(AControl: TControl; var ARect: TRect);
  1289. begin
  1290.   if FColCount > 1 then
  1291.     ARect.Right := ARect.Left + (ARect.Right-ARect.Left) div ColCount;
  1292.   if FRowCount > 1 then
  1293.     ARect.Bottom := ARect.Top + (ARect.Bottom-ARect.Top) div RowCount;
  1294.   inherited AlignControls(AControl, ARect);
  1295. end;
  1296.  
  1297. // SetColCount
  1298. procedure TPRGridPanel.SetColCount(Value: integer);
  1299. var
  1300.   Rect: TRect;
  1301. begin
  1302.   if Value <> FColCount then
  1303.   begin
  1304.     if (Value < 1) or ((Width div Value) < MIN_PANEL_SIZE) then
  1305.       raise Exception.Create('invalid colcount');
  1306.     FColCount := Value;
  1307.     Rect := GetClientRect;
  1308.     AlignControls(nil, Rect);
  1309.     Invalidate;
  1310.   end;
  1311. end;
  1312.  
  1313. // SetRowCount
  1314. procedure TPRGridPanel.SetRowCount(Value: integer);
  1315. var
  1316.   Rect: TRect;
  1317. begin
  1318.   if Value <> FRowCount then
  1319.   begin
  1320.     if (Value < 1) or ((Height div Value) < MIN_PANEL_SIZE) then
  1321.       raise Exception.Create('invalid rowcount');
  1322.     FRowCount := Value;
  1323.     Rect := GetClientRect;
  1324.     AlignControls(nil, Rect);
  1325.     Invalidate;
  1326.   end;
  1327. end;
  1328.  
  1329. // Paint
  1330. procedure TPRGridPanel.Paint;
  1331. var
  1332.   TmpRect: TRect;
  1333.   TmpWidth, TmpHeight: integer;
  1334.   i: integer;
  1335. begin
  1336.   with Canvas do
  1337.   begin
  1338.     if (FColCount > 1) or (FRowCount > 1) then
  1339.     begin
  1340.       Brush.Color := PROTECT_AREA_COLOR;
  1341.       FillRect(GetClientRect);
  1342.     end;
  1343.     TmpWidth := Trunc(Width / FColCount);
  1344.     TmpHeight := Trunc(Height / FRowCount);
  1345.     Brush.Color := clWhite;
  1346.     FillRect(Rect(0,0,TmpWidth,TmpHeight));
  1347.     TmpRect := GetAbsoluteRect;
  1348.     PaintGrid(Canvas, Width, Height, TmpRect.Left, TmpRect.Top);
  1349.  
  1350.     // draw ruled line
  1351.     Pen.Color := clBlue;
  1352.     Pen.Style := psDot;
  1353.     for i := 0 to FRowCount do
  1354.     begin
  1355.       TmpHeight := Trunc(Height*i/FRowCount);
  1356.       if TmpHeight = Height then
  1357.         dec(TmpHeight);
  1358.       MoveTo(0,TmpHeight);
  1359.       LineTo(Width,TmpHeight);
  1360.     end;
  1361.     for i := 0 to FColCount do
  1362.     begin
  1363.       TmpWidth := Trunc(Width*i/FColCount);
  1364.       if TmpWidth = Width then
  1365.         dec(TmpWidth);
  1366.       MoveTo(TmpWidth,0);
  1367.       LineTo(TmpWidth,Height);
  1368.     end;
  1369.  
  1370.     FChildPanel.Repaint;
  1371.   end;
  1372. end;
  1373.  
  1374. // Print
  1375. procedure TPRGridPanel.Print(ACanvas: TPRCanvas; ARect: TRect);
  1376. var
  1377.   i, j: integer;
  1378.  
  1379.   procedure PrintSubPanel(ACol, ARow: integer);
  1380.   var
  1381.     tmpRect: TRect;
  1382.     OffsetY, OffsetX: Integer;
  1383.   begin
  1384.     tmpRect := ARect;
  1385.     OffsetY := Trunc(Height * ARow / FRowCount);
  1386.     OffsetX := Trunc(Width * ACol / FColCount);
  1387.     tmpRect.Right := tmpRect.Left + FChildPanel.Width;
  1388.     tmpRect.Bottom := tmpRect.Top + FChildPanel.Height;
  1389.     OffsetRect(tmpRect, OffsetX, OffsetY);
  1390.     if Assigned(FBeforePrintChild) then
  1391.       FBeforePrintChild(Self, ACanvas, ACol, ARow, tmpRect);
  1392.     FChildPanel.Print(ACanvas, tmpRect);
  1393.     if Assigned(FAfterPrintChild) then
  1394.       FAfterPrintChild(Self, ACanvas, ACol, ARow, tmpRect);
  1395.   end;
  1396. begin
  1397.   if Assigned(FBeforePrint) then
  1398.     FBeforePrint(Self, ACanvas, ARect);
  1399.   // printing FChildPanel each row and col.
  1400.   if FPrintDirection = pdVert then
  1401.     for i := 0 to FColCount - 1 do
  1402.       for j := 0 to FRowCount - 1 do
  1403.         PrintSubPanel(j, i)
  1404.   else
  1405.     for j := 0 to FRowCount - 1 do
  1406.       for i := 0 to FColCount - 1 do
  1407.         PrintSubPanel(i, j);
  1408.   if Assigned(FAfterPrint) then
  1409.     FAfterPrint(Self, ACanvas, ARect);
  1410. end;
  1411.  
  1412. // SetParent
  1413. procedure TPRGridPanel.SetParent(AParent: TWinControl);
  1414. begin
  1415.   if (AParent <> nil) and
  1416.    (not (AParent is TPRPanel) and not (AParent is TPRPage)) then
  1417.     raise Exception.Create('TPRPage can not set on ' + AParent.ClassName);
  1418.   inherited SetParent(AParent);
  1419. end;
  1420.  
  1421. { TPRItem }
  1422.  
  1423. constructor TPRItem.Create(AOwner: TComponent);
  1424. begin
  1425.   inherited Create(AOwner);
  1426.   Width := 100;
  1427.   Height := 30;
  1428.   FPrintable := true;
  1429. end;
  1430.  
  1431. // SetParent
  1432. procedure TPRItem.SetParent(AParent: TWinControl);
  1433. begin
  1434.   if (AParent <> nil) and
  1435.    (not (AParent is TPRPanel)) then
  1436.     raise Exception.Create('this component must set on TPRPanel');
  1437.   if (AParent is TPRGridPanel) then
  1438.     AParent := TPRGridPanel(AParent).FChildPanel;
  1439.   inherited SetParent(AParent);
  1440. end;
  1441.  
  1442. // Print
  1443. procedure TPRItem.Print(ACanvas: TPRCanvas; ARect: TRect);
  1444. begin
  1445.   // abstract method..
  1446. end;
  1447.  
  1448. // GetPage
  1449. function TPRItem.GetPage: TPRPage;
  1450. begin
  1451.   result := (Parent as TPRPanel).Page;
  1452. end;
  1453.  
  1454. // GetInternalDoc
  1455. function TPRItem.GetInternalDoc: TPdfDoc;
  1456. begin
  1457.   result := Page.InternalDoc;
  1458. end;
  1459.  
  1460. { TPRCustomLabel }
  1461.  
  1462. constructor TPRCustomLabel.Create(AOwner: TComponent);
  1463. begin
  1464.   inherited Create(AOwner);
  1465.   Canvas.Brush.Style := bsClear;
  1466.   FFontName := fnArial;
  1467.   FFontSize := 12;
  1468.   FFontBold := false;
  1469.   FFontItalic := false;
  1470.   {$IFDEF USE_JPFONTS}
  1471.   FFontName := fnGothic;
  1472.   {$ENDIF}
  1473.   Font.Name := ITEM_FONT_NAMES[ord(FFontName)];
  1474.   Font.CharSet := ITEM_FONT_CHARSETS[ord(FFontName)];
  1475.   Font.Size := Round(FFontSize*0.75);
  1476.   ParentFont := false;
  1477. end;
  1478.  
  1479. // SetFontName
  1480. procedure TPRCustomLabel.SetFontName(Value: TPRFontName);
  1481. begin
  1482.   if FFontName <> Value then
  1483.   begin
  1484.     FFontName := Value;
  1485.     Font.Name := ITEM_FONT_NAMES[ord(Value)];
  1486.     Font.CharSet := ITEM_FONT_CHARSETS[ord(Value)];
  1487.     Invalidate;
  1488.   end;
  1489. end;
  1490.  
  1491. // SetFontItalic
  1492. procedure TPRCustomLabel.SetFontItalic(Value: boolean);
  1493. begin
  1494.   if FFontItalic <> Value then
  1495.   begin
  1496.     FFontItalic := Value;
  1497.     if Value then
  1498.       Font.Style := Font.Style + [fsItalic]
  1499.     else
  1500.       Font.Style := Font.Style - [fsItalic];
  1501.     Invalidate;
  1502.   end;
  1503. end;
  1504.  
  1505. // SetFontBold
  1506. procedure TPRCustomLabel.SetFontBold(Value: boolean);
  1507. begin
  1508.   if FFontBold <> Value then
  1509.   begin
  1510.     FFontBold := Value;
  1511.     if Value then
  1512.       Font.Style := Font.Style + [fsBold]
  1513.     else
  1514.       Font.Style := Font.Style - [fsBold];
  1515.     Invalidate;
  1516.   end;
  1517. end;
  1518.  
  1519. // SetFontSize
  1520. procedure TPRCustomLabel.SetFontSize(Value: Single);
  1521. begin
  1522.   if (FFontSize <> Value) and (Value > 0) then
  1523.   begin
  1524.     FFontSize := Value;
  1525.     Font.Size := Round(Value*0.75);
  1526.     Invalidate;
  1527.   end;
  1528. end;
  1529.  
  1530. // SetWordSpace
  1531. procedure TPRCustomLabel.SetWordSpace(Value: Single);
  1532. begin
  1533.   if (Value <> FWordSpace) and (Value >= 0) then
  1534.   begin
  1535.     FWordSpace := Value;
  1536.     Invalidate;
  1537.   end;
  1538. end;
  1539.  
  1540. // CMTextChanged
  1541. procedure TPRCustomLabel.CMTextChanged(var Message: TMessage);
  1542. begin
  1543.   Invalidate;
  1544. end;
  1545.  
  1546. // InternalTextout
  1547. function TPRCustomLabel.InternalTextout(APdfCanvas: TPdfCanvas;
  1548.                        S: string; X, Y: integer): Single;
  1549. var
  1550.   Pos: Double;
  1551.   i: integer;
  1552.   Word: string;
  1553.   ln: integer;
  1554. begin
  1555.   // printing text and the end point of canvas.
  1556.   i := 1;
  1557.   Pos := X;
  1558.   ln := Length(S);
  1559.  
  1560.   if ((ln >= 2) and (S[ln] = #10) and (S[ln-1] = #13)) then
  1561.     ln := ln - 2;
  1562.  
  1563.   while true do
  1564.   begin
  1565.     if i > ln then
  1566.       Break;
  1567.     if ByteType(S, i) = mbLeadByte then
  1568.     begin
  1569.       Word := Copy(S, i, 2);
  1570.       inc(i);
  1571.     end
  1572.     else
  1573.       Word := S[i];
  1574.     Canvas.TextOut(Round(Pos), Y, Word);
  1575.     with APdfCanvas do
  1576.       Pos := Pos + TextWidth(Word) + Attribute.CharSpace;
  1577.     if S[i] = ' ' then
  1578.       Pos := Pos + FWordSpace;
  1579.     inc(i);
  1580.   end;
  1581.   result := Pos;
  1582. end;
  1583.  
  1584. // GetFontClassName
  1585. function TPRCustomLabel.GetFontClassName: string;
  1586. begin
  1587.   if FFontBold then
  1588.     if FFontItalic then
  1589.       result := PDFFONT_CLASS_BOLDITALIC_NAMES[ord(FFontName)]
  1590.     else
  1591.       result := PDFFONT_CLASS_BOLD_NAMES[ord(FFontName)]
  1592.   else
  1593.     if FFontItalic then
  1594.       result := PDFFONT_CLASS_ITALIC_NAMES[ord(FFontName)]
  1595.     else
  1596.       result := PDFFONT_CLASS_NAMES[ord(FFontName)];
  1597. end;
  1598.  
  1599. { TPRLabel }
  1600.  
  1601. // SetAlignment
  1602. procedure TPRLabel.SetAlignment(Value: TAlignment);
  1603. begin
  1604.   if Value <> FAlignment then
  1605.   begin
  1606.     FAlignment := Value;
  1607.     Invalidate;
  1608.   end;
  1609. end;
  1610.  
  1611. // SetAlignJustified
  1612. procedure TPRLabel.SetAlignJustified(Value: boolean);
  1613. begin
  1614.   if Value <> FAlignJustified then
  1615.   begin
  1616.     FAlignJustified := Value;
  1617.     Invalidate;
  1618.   end;
  1619. end;
  1620.  
  1621. // Paint
  1622. procedure TPRLabel.Paint;
  1623. var
  1624.   PdfCanvas: TPdfCanvas;
  1625.   FText: string;
  1626.   tmpWidth: Single;
  1627.   XPos: integer;
  1628. begin
  1629.   if Length(Caption) = 0 then Exit;
  1630.  
  1631.   PdfCanvas := GetInternalDoc.Canvas;
  1632.  
  1633.   // setting canvas attribute to the internal doc(to get font infomation).
  1634.   SetCanvasProperties(PdfCanvas);
  1635.  
  1636.   with Canvas do
  1637.   begin
  1638.     Font := Self.Font;
  1639.     FText := Caption;
  1640.  
  1641.     // calculate text width
  1642.     tmpWidth := PdfCanvas.TextWidth(FText);
  1643.  
  1644.     case FAlignment of
  1645.       taCenter: XPos := Round((Width - tmpWidth) / 2);
  1646.       taRightJustify: XPos :=Width - Round(tmpWidth);
  1647.     else
  1648.       XPos := 0;
  1649.     end;
  1650.     InternalTextout(PdfCanvas, FText, XPos, 0);
  1651.   end;
  1652. end;
  1653.  
  1654. // Print
  1655. procedure TPRLabel.Print(ACanvas: TPRCanvas; ARect: TRect);
  1656. begin
  1657.   if Length(Caption) = 0 then Exit;
  1658.  
  1659.   SetCanvasProperties(ACanvas.PdfCanvas);
  1660.  
  1661.   ACanvas.TextRect(ARect, Caption, FAlignment, Clipping);
  1662. end;
  1663.  
  1664. function TPRLabel.GetTextWidth: Single;
  1665. begin
  1666.   with GetInternalDoc do
  1667.   begin
  1668.     SetCanvasProperties(Canvas);
  1669.     Result := Canvas.TextWidth(Caption);
  1670.   end;
  1671. end;
  1672.  
  1673. procedure TPRLabel.SetCanvasProperties(ACanvas: TPdfCanvas);
  1674. var
  1675.   tmpWidth: Single;
  1676.   tmpCharSpace: Single;
  1677.   CharCount: integer;
  1678. begin
  1679.   // setting canvas attribute to the internal doc(to get font infomation).
  1680.   with ACanvas do
  1681.   begin
  1682.     SetFont(GetFontClassName, FontSize);
  1683.     SetRGBFillColor(FontColor);
  1684.     SetWordSpace(WordSpace);
  1685.     if AlignJustified then
  1686.     begin
  1687.       SetCharSpace(0);
  1688.       tmpWidth := TextWidth(Caption);
  1689.       CharCount := _GetCharCount(Caption);
  1690.       if CharCount > 1 then
  1691.         tmpCharSpace := (Width - tmpWidth) / (CharCount - 1)
  1692.       else
  1693.         tmpCharSpace := 0;
  1694.       if tmpCharSpace > 0 then
  1695.         SetCharSpace(tmpCharSpace);
  1696.     end
  1697.     else
  1698.       SetCharSpace(CharSpace);
  1699.   end;
  1700. end;
  1701.  
  1702. { TPRText }
  1703.  
  1704. // SetLines
  1705. procedure TPRText.SetLines(Value: TStrings);
  1706. begin
  1707.   FLines.Assign(Value);
  1708.   Invalidate;
  1709. end;
  1710.  
  1711. // GetLines
  1712. function TPRText.GetLines: TStrings;
  1713. begin
  1714.   result := FLines;
  1715. end;
  1716.  
  1717. // SetText
  1718. procedure TPRText.SetText(Value: string);
  1719. begin
  1720.   FLines.Text := Value;
  1721. end;
  1722.  
  1723. // GetText
  1724. function TPRText.GetText: string;
  1725. begin
  1726.   result := Trim(FLines.Text);
  1727. end;
  1728.  
  1729. // Create
  1730. constructor TPRText.Create(AOwner: TComponent);
  1731. begin
  1732.   inherited Create(AOwner);
  1733.   FLeading := 14;
  1734.   FLines := TStringList.Create;
  1735. end;
  1736.  
  1737. // Destroy
  1738. destructor TPRText.Destroy;
  1739. begin
  1740.   FLines.Free;
  1741.   inherited;
  1742. end;
  1743.  
  1744. // Paint
  1745. procedure TPRText.Paint;
  1746. var
  1747.   i: integer;
  1748.   S1, S2: string;
  1749.   XPos: Single;
  1750.   TmpXPos: Double;
  1751.   ARect: TRect;
  1752.   ln: integer;
  1753.   PdfCanvas: TPdfCanvas;
  1754.   FText: string;
  1755.   ForceReturn: boolean;
  1756.   tmpWidth: Single;
  1757.  
  1758.   procedure DrawRect;
  1759.   begin
  1760.     with Canvas do
  1761.     begin
  1762.       Pen.Color := clNavy;
  1763.       Pen.Style := psDot;
  1764.       MoveTo(0, 0);
  1765.       LineTo(Width-1, 0);
  1766.       LineTo(Width-1, Height-1);
  1767.       LineTo(0, Height-1);
  1768.       LineTo(0, 0);
  1769.     end;
  1770.   end;
  1771.  
  1772. begin
  1773.   // this is useless way, but I don't think of more smart way.
  1774.   PdfCanvas := GetInternalDoc.Canvas;
  1775.  
  1776.   // setting canvas attribute to the internal doc(to get font infomation).
  1777.   with PdfCanvas do
  1778.   begin
  1779.     SetFont(GetFontClassName, FontSize);
  1780.     SetLeading(Leading);
  1781.     SetWordSpace(WordSpace);
  1782.     SetCharSpace(CharSpace);
  1783.   end;
  1784.  
  1785.   with Canvas do
  1786.   begin
  1787.     Font := Self.Font;
  1788.     ARect := ClientRect;
  1789.     FText := Lines.Text;
  1790.     i := 1;
  1791.     S2 := PdfCanvas.GetNextWord(FText, i);
  1792.     XPos := ARect.Left + PdfCanvas.TextWidth(S2);
  1793.     if (S2 <> '') and (S2[Length(S2)] = ' ') then
  1794.       XPos := XPos + WordSpace;
  1795.  
  1796.     while i <= Length(FText) do
  1797.     begin
  1798.       ln := Length(S2);
  1799.       if (ln >= 2) and (S2[ln] = #10) and (S2[ln-1] = #13) then
  1800.       begin
  1801.         S2 := Copy(S2, 1, ln - 2);
  1802.         ForceReturn := true;
  1803.       end
  1804.       else
  1805.         ForceReturn := false;
  1806.  
  1807.       S1 := PdfCanvas.GetNextWord(FText, i);
  1808.  
  1809.       tmpWidth := PdfCanvas.TextWidth(S1);
  1810.       TmpXPos := XPos + tmpWidth;
  1811.  
  1812.       if (FWordWrap and (TmpXPos > ARect.Right)) or
  1813.         ForceReturn then
  1814.       begin
  1815.         if S2 <> '' then
  1816.           InternalTextOut(PdfCanvas, S2, ARect.Left, ARect.Top);
  1817.         S2 := '';
  1818.         ARect.Top := ARect.Top + Round(Leading);
  1819.         if ARect.Top > ARect.Bottom - FontSize then
  1820.           Break;
  1821.         XPos := ARect.Left;
  1822.       end;
  1823.       XPos := XPos + tmpWidth;
  1824.       if S1[Length(S1)] = ' ' then
  1825.         XPos := XPos + WordSpace;
  1826.       S2 := S2 + S1;
  1827.     end;
  1828.  
  1829.     if S2 <> '' then
  1830.       InternalTextout(PdfCanvas, S2, ARect.Left, ARect.Top);
  1831.   end;
  1832.  
  1833.   DrawRect;
  1834. end;
  1835.  
  1836. // Print
  1837. procedure TPRText.Print(ACanvas: TPRCanvas; ARect: TRect);
  1838. begin
  1839.   with ACanvas.PdfCanvas do
  1840.   begin
  1841.     SetFont(GetFontClassName, FontSize);
  1842.     SetRGBFillColor(FontColor);
  1843.     SetCharSpace(CharSpace);
  1844.     SetWordSpace(WordSpace);
  1845.     SetLeading(Leading);
  1846.  
  1847.     with ARect do
  1848.       MultilineTextRect(_PdfRect(Left, GetPage.Height- Top, Right, GetPage.Height- Bottom),
  1849.         Text, WordWrap);
  1850.   end;
  1851. end;
  1852.  
  1853. // SetCharSpace
  1854. procedure TPRCustomLabel.SetCharSpace(Value: Single);
  1855. begin
  1856.   if (Value <> FCharSpace) then
  1857.   begin
  1858.     FCharSpace := Value;
  1859.     Invalidate;
  1860.   end;
  1861. end;
  1862.  
  1863. // SetLeading
  1864. procedure TPRText.SetLeading(Value: Single);
  1865. begin
  1866.   if (Value <> FLeading) and (Value >= 0) then
  1867.   begin
  1868.     FLeading := Value;
  1869.     Invalidate;
  1870.   end;
  1871. end;
  1872.  
  1873. // SetWordwrap
  1874. procedure TPRText.SetWordwrap(Value: boolean);
  1875. begin
  1876.   if Value <> FWordwrap then
  1877.   begin
  1878.     FWordwrap := Value;
  1879.     Invalidate;
  1880.   end;
  1881. end;
  1882.  
  1883. // SetFontColor
  1884. procedure TPRCustomLabel.SetFontColor(Value: TColor);
  1885. begin
  1886.   if Value > $0FFFFFFF then
  1887.     raise EPdfInvalidValue.Create('the color you selected is not allowed.');
  1888.   if (Value <> FFontColor) then
  1889.   begin
  1890.     FFontColor := Value;
  1891.     Font.Color := Value;
  1892.     Invalidate;
  1893.   end;
  1894. end;
  1895.  
  1896. { TPRShape }
  1897.  
  1898. // Create
  1899. constructor TPRShape.Create(AOwner: TComponent);
  1900. begin
  1901.   inherited Create(AOwner);
  1902.   FLineColor := clBlack;
  1903.   FFillColor := clNone;
  1904. end;
  1905.  
  1906. // SetLineColor
  1907. procedure TPRShape.SetLineColor(Value: TColor);
  1908. begin
  1909.   if Value <> FLineColor then
  1910.   begin
  1911.     FLineColor := Value;
  1912.     Invalidate;
  1913.   end;
  1914. end;
  1915.  
  1916. // SetLineStyle
  1917. procedure TPRShape.SetLineStyle(Value: TPenStyle);
  1918. begin
  1919.   if Value <> FLineStyle then
  1920.   begin
  1921.     FLineStyle := Value;
  1922.     Invalidate;
  1923.   end;
  1924. end;
  1925.  
  1926. // SetFillColor
  1927. procedure TPRShape.SetFillColor(Value: TColor);
  1928. begin
  1929.   if Value <> FFillColor then
  1930.   begin
  1931.     FFillColor := Value;
  1932.     Invalidate;
  1933.   end;
  1934. end;
  1935.  
  1936. // SetLineWidth
  1937. procedure TPRShape.SetLineWidth(Value: Single);
  1938. begin
  1939.   if (Value <> FLineWidth) and (Value >= 0) then
  1940.   begin
  1941.     FLineWidth := Value;
  1942.     Invalidate;
  1943.   end;
  1944. end;
  1945.  
  1946. // SetDash
  1947. procedure TPRShape.SetDash(ACanvas: TPdfCAnvas; APattern: TPenStyle);
  1948. begin
  1949.   // emurate TPenStyle
  1950.   with ACanvas do
  1951.     case APattern of
  1952.       psSolid, psInsideFrame: SetDash([0], 0);
  1953.       psDash: SetDash([16, 8], 0);
  1954.       psDashDot: SetDash([8, 7, 2, 7], 0);
  1955.       psDashDotDot: SetDash([8, 4, 2, 4, 2, 4], 0);
  1956.       psDot: SetDash([3], 0);
  1957.     end;
  1958. end;
  1959.  
  1960.  
  1961. { TPRRect }
  1962.  
  1963. // Paint
  1964. procedure TPRRect.Paint;
  1965. var
  1966.   ARect: TRect;
  1967. begin
  1968.   ARect := ClientRect;
  1969.   with ARect, Canvas do
  1970.   begin
  1971.     if Height > 1 then
  1972.       Bottom := Bottom - 1;
  1973.     if Width > 1 then
  1974.       Right := Right - 1;
  1975.  
  1976.     if FillColor <> clNone then
  1977.     begin
  1978.       Brush.Color := FFillColor;
  1979.       Brush.Style := bsSolid;
  1980.       FillRect(ARect);
  1981.     end
  1982.     else
  1983.       Brush.Style := bsClear;
  1984.  
  1985.     if LineColor <> clNone then
  1986.     begin
  1987.       Pen.Style := FLineStyle;
  1988.       Pen.Width := Round(FLineWidth);
  1989.       Pen.Color := FLineColor;
  1990.       Polygon([Point(Left,Top), Point(Right,Top),
  1991.         Point(Right,Bottom), Point(Left,Bottom)]);
  1992.     end;
  1993.   end;
  1994. end;
  1995.  
  1996. // Print
  1997. procedure TPRRect.Print(ACanvas: TPRCanvas; ARect: TRect);
  1998. var
  1999.   PageHeight: integer;
  2000. begin
  2001.   PageHeight := GetPage.Height;
  2002.   with ARect do
  2003.   begin
  2004.     Top := PageHeight - Top;
  2005.     if Height > 1 then
  2006.       Bottom := PageHeight - Bottom + 1
  2007.     else
  2008.       Bottom := PageHeight - Bottom;
  2009.     if Width > 1 then
  2010.       Right := Right - 1;
  2011.  
  2012.     if (Height <= 1) and (Width <= 1) then Exit;
  2013.  
  2014.     if (LineColor = clNone) or (LineStyle = psClear) then
  2015.       if (Height <= 1) or (Width <= 1) then Exit;
  2016.  
  2017.     SetDash(ACanvas.PdfCanvas, FLineStyle);
  2018.  
  2019.     with ACanvas.PdfCanvas do
  2020.     begin
  2021.       MoveTo(Left, Top);
  2022.  
  2023.       if Width > 1 then
  2024.       begin
  2025.         LineTo(Right, Top);
  2026.         if Height > 1 then
  2027.           LineTo(Right, Bottom);
  2028.       end;
  2029.       if Height > 1 then
  2030.         LineTo(Left, Bottom);
  2031.  
  2032.       if (FillColor <> clNone) and (Width > 1) and (Height > 1) then
  2033.         SetRGBFillColor(FFillColor);
  2034.  
  2035.       if LineColor <> clNone then
  2036.       begin
  2037.         SetRGBStrokeColor(FLineColor);
  2038.         SetLineWidth(FLineWidth);
  2039.       end;
  2040.  
  2041.       if FillColor <> clNone then
  2042.         if (Width > 1) and (Height > 1) then
  2043.           if (LineColor <> clNone) and (LineStyle <> psClear) then
  2044.             ClosepathFillStroke
  2045.           else
  2046.           begin
  2047.             Closepath;
  2048.             Fill;
  2049.           end
  2050.         else
  2051.         begin
  2052.           Stroke;
  2053.           Newpath;
  2054.         end
  2055.       else
  2056.         if (Width > 1) and (Height > 1) then
  2057.           ClosePathStroke
  2058.         else
  2059.         begin
  2060.           Stroke;
  2061.           Newpath;
  2062.         end;
  2063.     end;
  2064.   end;
  2065. end;
  2066.  
  2067. { TPREllipse }
  2068.  
  2069. // Paint
  2070. procedure TPREllipse.Paint;
  2071. var
  2072.   ARect: TRect;
  2073. begin
  2074.   ARect := ClientRect;
  2075.   with ARect, Canvas do
  2076.   begin
  2077.     if Height > 1 then
  2078.       Bottom := Bottom - 1;
  2079.     if Width > 1 then
  2080.       Right := Right - 1;
  2081.  
  2082.     if FillColor <> clNone then
  2083.     begin
  2084.       Brush.Color := FFillColor;
  2085.       Brush.Style := bsSolid;
  2086.     end
  2087.     else
  2088.       Brush.Style := bsClear;
  2089.  
  2090.     if (LineColor <> clNone) and (LineStyle <> psClear) then
  2091.     begin
  2092.       Pen.Style := FLineStyle;
  2093.       Pen.Width := Round(FLineWidth);
  2094.       Pen.Color := FLineColor;
  2095.     end
  2096.     else
  2097.       Pen.Style := psClear;
  2098.  
  2099.     Ellipse(Left, Top, Right, Bottom);
  2100.   end;
  2101. end;
  2102.  
  2103. // Print
  2104. procedure TPREllipse.Print(ACanvas: TPRCanvas; ARect: TRect);
  2105. var
  2106.   PageHeight: integer;
  2107. begin
  2108.   PageHeight := GetPage.Height;
  2109.   with ARect do
  2110.   begin
  2111.     Top := PageHeight - Top;
  2112.     if Height > 1 then
  2113.       Bottom := PageHeight - Bottom + 1
  2114.     else
  2115.       Bottom := PageHeight - Bottom;
  2116.     if Width > 1 then
  2117.       Right := Right - 1;
  2118.  
  2119.     if (Height <= 1) and (Width <= 1) then Exit;
  2120.  
  2121.     if (LineColor = clNone) or (LineStyle = psClear) then
  2122.       if (Height <= 1) or (Width <= 1) then Exit;
  2123.  
  2124.     SetDash(ACanvas.PdfCanvas, FLineStyle);
  2125.  
  2126.     with ACanvas.PdfCanvas do
  2127.     begin
  2128.       with ARect do
  2129.         Ellipse(Left, Top, Right - Left, Bottom - Top);
  2130.  
  2131.       if (FillColor <> clNone) and (Width > 1) and (Height > 1) then
  2132.         SetRGBFillColor(FFillColor);
  2133.  
  2134.       if LineColor <> clNone then
  2135.       begin
  2136.         SetRGBStrokeColor(FLineColor);
  2137.         SetLineWidth(FLineWidth);
  2138.       end;
  2139.  
  2140.       if FillColor <> clNone then
  2141.         if (Width > 1) and (Height > 1) then
  2142.           if (LineColor <> clNone) and (LineStyle <> psClear) then
  2143.             ClosepathFillStroke
  2144.           else
  2145.           begin
  2146.             Closepath;
  2147.             Fill;
  2148.           end
  2149.         else
  2150.         begin
  2151.           Stroke;
  2152.           Newpath;
  2153.         end
  2154.       else
  2155.         if (Width > 1) and (Height > 1) then
  2156.           ClosePathStroke
  2157.         else
  2158.         begin
  2159.           Stroke;
  2160.           Newpath;
  2161.         end;
  2162.     end;
  2163.   end;
  2164. end;
  2165.  
  2166. { TPRImage }
  2167.  
  2168. // Paint
  2169. procedure TPRImage.Paint;
  2170. begin
  2171.   if (FPicture = nil) or (FPicture.Graphic = nil) or
  2172.    (FPicture.Graphic.Empty) then
  2173.     with Canvas do
  2174.     begin
  2175.       Brush.Style := bsClear;
  2176.       TextOut(4, 4, Name);
  2177.       Pen.Color := clBlue;
  2178.       Pen.Style := psDot;
  2179.       Polygon([Point(0, 0), Point(Width-1, 0),
  2180.         Point(Width-1, Height-1), Point(0, Height-1)]);
  2181.     end
  2182.   else
  2183.   if FStretch then
  2184.     Canvas.StretchDraw(GetClientRect, FPicture.Graphic)
  2185.   else
  2186.     Canvas.Draw(0, 0, FPicture.Graphic);
  2187. end;
  2188.  
  2189. // Print
  2190. procedure TPRImage.Print(ACanvas: TPRCanvas; ARect: TRect);
  2191. var
  2192.   FDoc: TPdfDoc;
  2193.   FXObjectName: string;
  2194.   i: integer;
  2195.   FIdx: integer;
  2196. begin
  2197.   if (FPicture = nil) or (FPicture.Graphic = nil) or
  2198.    (FPicture.Graphic.Empty) or not (FPicture.Graphic is TBitmap) then
  2199.     Exit;
  2200.   FDoc := ACanvas.PdfCanvas.Doc;
  2201.   if SharedImage then
  2202.   begin
  2203.     FXObjectName := Self.Name;
  2204.     if FDoc.GetXObject(FXObjectName) = nil then
  2205.       FDoc.AddXObject(FXObjectName, CreatePdfImage(FPicture.Graphic, 'Pdf-Bitmap'));
  2206.   end
  2207.   else
  2208.   begin
  2209.     FIdx := Random(MAX_IMAGE_NUMBER - 1);
  2210.     for i := 0 to MAX_IMAGE_NUMBER - 1 do
  2211.     begin
  2212.       FXObjectName := Self.Name + IntToStr(FIdx);
  2213.       if FDoc.GetXObject(FXObjectName) = nil then Break;
  2214.       if i = MAX_IMAGE_NUMBER then
  2215.         raise Exception.Create('image count over max value..');
  2216.       inc(FIdx);
  2217.       if FIdx >= MAX_IMAGE_NUMBER then
  2218.         FIdx := 0;
  2219.     end;
  2220.     FDoc.AddXObject(FXObjectName, CreatePdfImage(FPicture.Graphic, 'Pdf-Bitmap'));
  2221.   end;
  2222.   with ARect, ACanvas.PdfCanvas do
  2223.     if FStretch then
  2224.       DrawXObject(Left, GetPage.Height - Bottom, Width, Height, FXObjectName)
  2225.     else
  2226.       DrawXObjectEx(Left, GetPage.Height - Top - FPicture.Height,
  2227.             FPicture.Width, FPicture.Height,
  2228.             Left, GetPage.Height - Top - Height, Width, Height, FXObjectName);
  2229. end;
  2230.  
  2231. // Create
  2232. constructor TPRImage.Create(AOwner: TComponent);
  2233. begin
  2234.   inherited;
  2235.   FPicture := TPicture.Create;
  2236.   FSharedImage := true;
  2237.   FStretch := true;
  2238.   Randomize;
  2239. end;
  2240.  
  2241. // SetPicture
  2242. procedure TPRImage.SetPicture(Value: TPicture);
  2243. begin
  2244.   if (Value = nil) or (Value.Graphic = nil) or (Value.Graphic is TBitmap) then
  2245.   begin
  2246.     FPicture.Assign(Value);
  2247.     Invalidate;
  2248.   end
  2249.   else
  2250.     raise exception.Create('only bitmap image is allowed.');
  2251. end;
  2252.  
  2253. // SetStretch
  2254. procedure TPRImage.SetStretch(Value: boolean);
  2255. begin
  2256.   if Value = FStretch then Exit;
  2257.   FStretch := Value;
  2258.   Invalidate;
  2259. end;
  2260.  
  2261. // Destroy
  2262. destructor TPRImage.Destroy;
  2263. begin
  2264.   FPicture.Free;
  2265.   inherited;
  2266. end;
  2267.  
  2268. { TPRDestination }
  2269. procedure TPRDestination.SetType(Value: TPRDestinationType);
  2270. begin
  2271.   FData.DestinationType := Value;
  2272. end;
  2273.  
  2274. function TPRDestination.GetType: TPRDestinationType;
  2275. begin
  2276.   result := FData.DestinationType;
  2277. end;
  2278.  
  2279. procedure TPRDestination.SetElement(Index: integer; Value: Integer);
  2280. begin
  2281.   case Index of
  2282.     0: FData.Left := Value;
  2283.     1: FData.Top := FData.PageHeight - Value;
  2284.     2: FData.Right := Value;
  2285.     3: FData.Bottom := FData.PageHeight - Value;
  2286.   end;
  2287. end;
  2288.  
  2289. procedure TPRDestination.SetZoom(Value: Single);
  2290. begin
  2291.   FData.Zoom := Value;
  2292. end;
  2293.  
  2294. function TPRDestination.GetElement(Index: integer): Integer;
  2295. begin
  2296.   case Index of
  2297.     0: Result := FData.Left;
  2298.     1: Result := FData.Top;
  2299.     2: Result := FData.Right;
  2300.   else
  2301.     Result := FData.Bottom;
  2302.   end;
  2303. end;
  2304.  
  2305. function TPRDestination.GetZoom: Single;
  2306. begin
  2307.   Result := FData.Zoom;
  2308. end;
  2309.  
  2310. constructor TPRDestination.Create(AData: TPdfDestination);
  2311. begin
  2312.   inherited Create;
  2313.   FData := AData;
  2314.   AData.Reference := Self;
  2315. end;
  2316.  
  2317. { TPROutlineEntry }
  2318. function TPROutlineEntry.GetParent: TPROutlineEntry;
  2319. begin
  2320.   if FData.Parent <> nil then
  2321.     Result := TPROutlineEntry(FData.Parent.Reference)
  2322.   else
  2323.     Result := nil;
  2324. end;
  2325.  
  2326. function TPROutlineEntry.GetNext: TPROutlineEntry;
  2327. begin
  2328.   if FData.Next <> nil then
  2329.     Result := TPROutlineEntry(FData.Next.Reference)
  2330.   else
  2331.     Result := nil;
  2332. end;
  2333.  
  2334. function TPROutlineEntry.GetPrev: TPROutlineEntry;
  2335. begin
  2336.   if FData.Prev <> nil then
  2337.     Result := TPROutlineEntry(FData.Prev.Reference)
  2338.   else
  2339.     Result := nil;
  2340. end;
  2341.  
  2342. function TPROutlineEntry.GetFirst: TPROutlineEntry;
  2343. begin
  2344.   if FData.First <> nil then
  2345.     Result := TPROutlineEntry(FData.First.Reference)
  2346.   else
  2347.     Result := nil;
  2348. end;
  2349.  
  2350. function TPROutlineEntry.GetLast: TPROutlineEntry;
  2351. begin
  2352.   if FData.Last <> nil then
  2353.     Result := TPROutlineEntry(FData.Last.Reference)
  2354.   else
  2355.     Result := nil;
  2356. end;
  2357.  
  2358. function TPROutlineEntry.GetDest: TPRDestination;
  2359. begin
  2360.   if FData.Dest <> nil then
  2361.     Result := TPRDestination(FData.Dest.Reference)
  2362.   else
  2363.     Result := nil;
  2364. end;
  2365.  
  2366. function TPROutlineEntry.GetTitle: string;
  2367. begin
  2368.   Result := FData.Title;
  2369. end;
  2370.  
  2371. function TPROutlineEntry.GetOpened: boolean;
  2372. begin
  2373.   Result := FData.Opened;
  2374. end;
  2375.  
  2376. procedure TPROutlineEntry.SetDest(Value: TPRDestination);
  2377. begin
  2378.   if FData.Doc <> Value.FData.Doc then
  2379.     raise EPdfInvalidOperation.Create('SetDest --internal docs are not equal.');
  2380.   FData.Dest := Value.FData;
  2381. end;
  2382.  
  2383. procedure TPROutlineEntry.SetTitle(Value: string);
  2384. begin
  2385.   FData.Title := Value;
  2386. end;
  2387.  
  2388. procedure TPROutlineEntry.SetOpened(Value: boolean);
  2389. begin
  2390.   FData.Opened := Value;
  2391. end;
  2392.  
  2393. function TPROutlineEntry.AddChild: TPROutlineEntry;
  2394. begin
  2395.   Result := TPROutlineEntry.Create;
  2396.   Result.FData := Self.FData.AddChild;
  2397.   Result.FData.Reference := Result;
  2398. end;
  2399.  
  2400. { TPROutlineRoot }
  2401. constructor TPROutlineRoot.CreateRoot(ADoc: TPdfDoc);
  2402. begin
  2403.   inherited Create;
  2404.   FData := ADoc.OutlineRoot;
  2405.   ADoc.OutlineRoot.Reference := Self;
  2406. end;
  2407.  
  2408. end.
  2409.  
  2410.  
  2411.  
  2412.