Fórum migrando componente do delphi 6 para delphi 7... #276018
07/04/2005
0
Olá colegas,
Vou postar uma unit de um componente de um componente chamado ExtraDev, que um complemento do report builder, onde tenho a versão do mesmo para delphi 6 e que estou querendo instalá-lo no delphi 7, só que ocorre um erro ao instalá-lo, eis a unit:
unit TXtraDev;
{
TExtraDevices for Delphi
Written by James Waler
Copyright (c) 1998, 1999, 2000 by James Waler
All rights reserved
***************************************************************
THIS SOFTWARE IS PROVIDED ´AS IS´ WITHOUT WARRANTY OF ANY KIND,
EITHER EXPRESSED OR IMPLIED. THE USER ASSUMES THE ENTIRE RISK
OF ANY DAMAGE CAUSED BY THIS SOFTWARE.
IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR DAMAGE OF ANY
KIND, LOSS OF DATA, LOSS OF PROFITS, BUSINESS INTERRUPTION OR
OTHER PECUNIARY LOSS ARISING DIRECTLY OR INDIRECTLY.
1.
HTML - Added support for ulnone RTF
ALL - Fixed double lines
1.83
TIFF - Fixed pf1bit images
1.82 - 01/21/2001
TIFF - Fixed pf24bit images
TIFF - Made images 96 dpi
PDF - Corrected right-aligned text
PDF - Added fast compression option
1.81 - 11/28/2000
PDF - Improved right-aligned text
PDF - Added right-aligned memos
HTML - Fix for bottom line
1.8 - 11/15/2000
PDF - Right aligned single line labels work with all fonts
RTF - Added stripping of EOPs
ALL - Trim lines so that they do not hide other objects
PDF - Fixed lines joins
PDF - Fixed crosstab text
PDF - RichText over multiple pages
1.72 - 10/10/2000
Fixed checkbox in RTF
Added multiline support to RichText in PDF
Added EOP stripping for RB 5.1 FT
1.71 - 7/30/2000
Fixed barcode crop in all devices
1.7 - 5/10/2000
PDF - Checkbox support
PDF - Circle & Ellipse support
PDF - Line style support
PDF - ZLIB compression support for D5
Added barcode support to HTML, CSS2, RTF, PDF & Graphic
PDF - Improved memo rendering
PDF - Added support for Italics & Bold
XLS - First column center-aligned labels were fixed
Added component for device control
PDF - Fixed right-aligned label placement
Graphic - Added multipage TIF support
PDF - Added PlainText RichText support
PDF - Added support for non-transparent text
PDF - Added roundrect & roundsquare support
}
{$IFDEF VER130}
{$DEFINE USEZLIB}
{$ENDIF}
{$IFDEF VER140}
{$DEFINE USEZLIB}
{$ENDIF}
interface
uses
Classes, Windows, Graphics, ExtCtrls, SysUtils, Forms, Controls, ppFilDev, Math, RichEdit,
ppDevice, ppTypes, ppUtils, ppForms, ppDrwCmd, JPEG, Dialogs, Printers, ComCtrls, ppViewr,
TXTIFF, TXParse, ppRichTx{$IFDEF USEZLIB},ZLib{$ENDIF};
type
TReportItemType = (riIgnore, riText, riImage, riLine, riShape, riRTF, riBarCode, riCheckBox);
TImageCRC = class
FileName: String;
CRC: Cardinal;
end;
TReportBand = class(TList)
end;
TReportItem = class
ItemType: TReportItemType;
Row: Integer;
Top: Integer;
Left: Integer;
Height: Integer;
Width: Integer;
AdjLeft: Integer;
AdjHeight: Integer;
AdjWidth: Integer;
DrawCmd: TppDrawCommand;
ZOrder: Integer;
end;
{ TExtraDevice }
TExtraDevice = class(TppFileDevice)
private
Page: TppPage;
FRow: Integer;
FCol: Integer;
FPageNo: Integer;
FImageNo: Integer;
MemStream: TMemoryStream;
SeparateBands: Boolean;
ConvertFonts: Boolean;
ImageList: TList;
CRCTable: array[0..255] of Cardinal;
procedure GetDrawCommands(Page: TppPage; Cmds: TStringList);
procedure Write(Buffer: String); virtual;
procedure Stream(Buffer: String);
procedure SavePageToFile(Page: TppPage);
procedure CalcSize(Itm: TReportItem);
procedure DrawLine(B: TCanvas; Lne: TppDrawLine; Bounds: TRect);
procedure DrawShape(B: TCanvas; Shp: TppDrawShape; Bounds: TRect);
procedure DrawCheckBox(B: TBitmap; Txt: TppDrawText; Bounds: TRect; AdjBitmap: Boolean; IgnoreAttr: Boolean);
function ImageIndex(J: TObject; FileName: String): Integer;
function CRC(MS: TMemoryStream): Cardinal;
procedure InitCRCTable;
function WriteImage(B: TBitmap): String;
procedure DrawImage(B: TBitmap; Itm: TReportItem; Bounds: TRect; AdjBitmap, IgnoreAttr, AdjImage: Boolean);
procedure DrawRichText(B: TBitmap; DRT: TppDrawRichText; Bounds: TRect);
procedure DrawBarCode(B: TCanvas; Bar: TppDrawBarCode; Bounds: TRect);
function ConvertFont(FontName: String): String;
procedure CalcBarCodeSize(Itm: TReportItem);
protected
procedure ProcessBand(Band: TReportBand); virtual;
procedure StartBand; virtual;
procedure EndBand; virtual;
procedure StartPage; virtual;
procedure EndPage; virtual;
public
constructor Create(aOwner: TComponent); override;
destructor Destroy; override;
procedure EndJob; override;
procedure StartJob; override;
procedure ReceivePage(aPage: TppPage); override;
end;
{ TWK1Device }
TWK1Device = class(TExtraDevice)
public
procedure ProcessBand(Band: TReportBand); override;
procedure StartJob; override;
procedure EndJob; override;
class function DeviceName: String; override;
class function DefaultExt: String; override;
class function DefaultExtFilter: String; override;
class function DeviceDescription(aLanguageIndex: Longint): String; override;
end;
{ TWQ1Device }
TWQ1Device = class(TExtraDevice)
public
procedure StartJob; override;
procedure EndJob; override;
procedure ProcessBand(Band: TReportBand); override;
class function DeviceName: String; override;
class function DefaultExt: String; override;
class function DefaultExtFilter: String; override;
class function DeviceDescription(aLanguageIndex: Longint): String; override;
end;
{ TXLSDevice }
TXLSDevice = class(TExtraDevice)
FontTbl: TStringList;
FormatTbl: TStringList;
XFTbl: TStringList;
private
procedure WriteFontTbl;
procedure WriteFormatTbl;
procedure WriteXFTbl;
function FontIndex(Font: TFont): String;
function FormatIndex(Format: String): String;
function XFIndex(Txt: TppDrawText; Numeric: Boolean): String;
public
procedure StartJob; override;
procedure EndJob; override;
procedure ProcessBand(Band: TReportBand); override;
class function DeviceName: String; override;
class function DefaultExt: String; override;
class function DefaultExtFilter: String; override;
class function DeviceDescription(aLanguageIndex: Longint): String; override;
end;
{ TGraphicDevice }
TGraphicDevice = class(TExtraDevice)
private
Img: TBitmap;
Tif: TTIFImage;
Ext: String;
protected
procedure StartPage; override;
procedure EndPage; override;
procedure ProcessBand(Band: TReportBand); override;
public
procedure StartJob; override;
procedure EndJob; override;
class function DeviceName: String; override;
class function DefaultExt: String; override;
class function DefaultExtFilter: String; override;
class function DeviceDescription(aLanguageIndex: Longint): String; override;
end;
{ THTMLDevice }
THTMLDevice = class(TExtraDevice)
private
DestStream: TFileStream;
BaseFont: String;
BaseSize: Integer;
BandWidth: Integer;
TopOffset: Integer;
TotWidth: Integer;
protected
procedure StartBand; override;
procedure EndBand; override;
procedure StartPage; override;
procedure EndPage; override;
procedure Write(Buffer: String); override;
procedure ProcessBand(Band: TReportBand); override;
public
procedure StartJob; override;
procedure EndJob; override;
class function DeviceName: String; override;
class function DefaultExt: String; override;
class function DefaultExtFilter: String; override;
class function DeviceDescription(aLanguageIndex: Longint): String; override;
end;
{ TCSS2Device }
TCSS2Device = class(TExtraDevice)
private
DestStream: TFileStream;
protected
procedure StartBand; override;
procedure EndBand; override;
procedure StartPage; override;
procedure EndPage; override;
procedure Write(Buffer: String); override;
procedure ProcessBand(Band: TReportBand); override;
public
procedure StartJob; override;
procedure EndJob; override;
class function DeviceName: String; override;
class function DefaultExt: String; override;
class function DefaultExtFilter: String; override;
class function DeviceDescription(aLanguageIndex: Longint): String; override;
end;
{ TRTFDevice }
TRTFDevice = class(TExtraDevice)
private
BaseFont: String;
BaseSize: Integer;
TopOffset: Integer;
TopMargin: Integer;
BottomMargin: Integer;
LeftMargin: Integer;
RightMargin: Integer;
FontTbl: TStringList;
ColorTbl: TStringList;
protected
procedure StartBand; override;
procedure EndBand; override;
procedure StartPage; override;
procedure EndPage; override;
procedure ProcessBand(Band: TReportBand); override;
procedure WriteFontTbl;
procedure WriteColorTbl;
function FontIndex(Font: String): String;
function ColorIndex(Color: TColor): String;
public
procedure StartJob; override;
procedure EndJob; override;
class function DeviceName: String; override;
class function DefaultExt: String; override;
class function DefaultExtFilter: String; override;
class function DeviceDescription(aLanguageIndex: Longint): String; override;
end;
{ TPDFDevice }
TPDFDevice = class(TExtraDevice)
private
FontTbl: TStringList;
FontObj: TStringList;
FontNme: TStringList;
CrossRef: TStringList;
ObjNo: Integer;
RootObj: Integer;
BodyObj: String;
ProcObj: String;
MaxKids: Integer;
AnyImages: Boolean;
InStream: Boolean;
InImage: Boolean;
StreamObj: String;
PageList: TStringList;
TotPages: Integer;
StreamSize: Integer;
PageHeight: Integer;
PageWidth: Integer;
FilePos: Integer;
XRefPos: Integer;
procedure AddRef(Obj: String);
procedure WriteCrossRef;
function ImageObject(Itm: TReportItem): String;
procedure WriteBMP(ImgObj: String; B: TBitmap; Mask: Boolean);
procedure ASCII85(Source, Target: TStream);
procedure EndStream;
procedure StartStream;
{$IFNDEF USEZLIB}
procedure RunLength(Source, Target: TStream);
{$ENDIF}
function ArcTo(X1, Y1, X2, Y2, XRadius, YRadius: Extended): String;
procedure RoundRect(Left, Top, Width, Height, XRad, YRad: Extended);
function TextWidth(Txt: TppDrawText; Value: String): Extended;
function ComputeStringWidth(Wth: array of Word; Txt: TppDrawText; Value: String): Extended;
protected
procedure StartBand; override;
procedure EndBand; override;
procedure StartPage; override;
procedure EndPage; override;
procedure ProcessBand(Band: TReportBand); override;
procedure WriteFontTbl;
function FontIndex(Font: TFont): Integer;
procedure Write(Buffer: String); override;
function NextObj: String;
function ParentObj(PageNo: Integer): String;
function FontFamily(Font: TFont): String;
public
procedure StartJob; override;
procedure EndJob; override;
class function DeviceName: String; override;
class function DefaultExt: String; override;
class function DefaultExtFilter: String; override;
class function DeviceDescription(aLanguageIndex: Longint): String; override;
end;
{ TExtraDeviceOptions }
TExtraDeviceOptions = class
private
FVisible: Boolean;
procedure SetVisible(Value: Boolean); virtual;
function GetVisible: Boolean;
public
constructor Create;
property Visible: Boolean read GetVisible write SetVisible;
end;
THTMLDeviceOptions = class(TExtraDeviceOptions)
private
FPixelFormat: TPixelFormat;
FBackLink: String;
FForwardLink: String;
FUseTextFile: Boolean;
FZoomableImages: Boolean;
FShowLinks: Boolean;
procedure SetVisible(Value: Boolean); override;
public
constructor Create;
destructor Destroy; override;
property BackLink: String read FBackLink write FBackLink;
property ForwardLink: String read FForwardLink write FForwardLink;
property ShowLinks: Boolean read FShowLinks write FShowLinks;
property UseTextFileName: Boolean read FUseTextFile write FUseTextFile;
property ZoomableImages: Boolean read FZoomableImages write FZoomableImages;
property PixelFormat: TPixelFormat read FPixelFormat write FPixelFormat;
end;
TCSS2DeviceOptions = class(TExtraDeviceOptions)
private
FPixelFormat: TPixelFormat;
FBackLink: String;
FForwardLink: String;
FUseTextFile: Boolean;
FZoomableImages: Boolean;
FShowLinks: Boolean;
procedure SetVisible(Value: Boolean); override;
public
constructor Create;
destructor Destroy; override;
property BackLink: String read FBackLink write FBackLink;
property ForwardLink: String read FForwardLink write FForwardLink;
property ShowLinks: Boolean read FShowLinks write FShowLinks;
property UseTextFileName: Boolean read FUseTextFile write FUseTextFile;
property ZoomableImages: Boolean read FZoomableImages write FZoomableImages;
property PixelFormat: TPixelFormat read FPixelFormat write FPixelFormat;
end;
TRTFDeviceOptions = class(TExtraDeviceOptions)
procedure SetVisible(Value: Boolean); override;
end;
TWK1DeviceOptions = class(TExtraDeviceOptions)
procedure SetVisible(Value: Boolean); override;
end;
TWQ1DeviceOptions = class(TExtraDeviceOptions)
procedure SetVisible(Value: Boolean); override;
end;
TXLSDeviceOptions = class(TExtraDeviceOptions)
procedure SetVisible(Value: Boolean); override;
end;
TPDFDeviceOptions = class(TExtraDeviceOptions)
private
FCreator: String;
FTitle: String;
FAuthor: String;
FKeywords: String;
FSubject: String;
FFastCompression: Boolean;
FCompressImages: Boolean;
FCompressStreams: Boolean;
FScaleImages: Boolean;
FShrinkMemos: Boolean;
FPixelFormat: TPixelFormat;
procedure SetVisible(Value: Boolean); override;
public
constructor Create;
property Creator: String read FCreator write FCreator;
property Title: String read FTitle write FTitle;
property Author: String read FAuthor write FAuthor;
property Keywords: String read FKeywords write FKeywords;
property Subject: String read FSubject write FSubject;
property FastCompression: Boolean read FFastCompression write FFastCompression;
property ShrinkMemos: Boolean read FShrinkMemos write FShrinkMemos;
property CompressImages: Boolean read FCompressImages write FCompressImages;
property CompressStreams: Boolean read FCompressStreams write FCompressStreams;
property ScaleImages: Boolean read FScaleImages write FScaleImages;
property PixelFormat: TPixelFormat read FPixelFormat write FPixelFormat;
end;
TGraphicDeviceOptions = class(TExtraDeviceOptions)
private
FPixelFormat: TPixelFormat;
FUseTextFile: Boolean;
FPixelsPerInch: Integer;
private
procedure SetVisible(Value: Boolean); override;
public
constructor Create;
destructor Destroy; override;
property PixelFormat: TPixelFormat read FPixelFormat write FPixelFormat;
property UseTextFileName: Boolean read FUseTextFile write FUseTextFile;
property PixelsPerInch: Integer read FPixelsPerInch write FPixelsPerInch;
end;
TExtraOptions = class
FHTML: THTMLDeviceOptions;
FCSS2: TCSS2DeviceOptions;
FRTF: TRTFDeviceOptions;
FLotus: TWK1DeviceOptions;
FQuattro: TWQ1DeviceOptions;
FExcel: TXLSDeviceOptions;
FGraphic: TGraphicDeviceOptions;
FPDF: TPDFDeviceOptions;
public
constructor Create;
destructor Destroy; override;
property HTML: THTMLDeviceOptions read FHTML write FHTML;
property CSS2: TCSS2DeviceOptions read FCSS2 write FCSS2;
property RTF: TRTFDeviceOptions read FRTF write FRTF;
property Lotus: TWK1DeviceOptions read FLotus write FLotus;
property Quattro: TWQ1DeviceOptions read FQuattro write FQuattro;
property Excel: TXLSDeviceOptions read FExcel write FExcel;
property Graphic: TGraphicDeviceOptions read FGraphic write FGraphic;
property PDF: TPDFDeviceOptions read FPDF write FPDF;
end;
function ExtraDevices: TExtraOptions;
implementation
const
CRLF = #13 + 10;
EOP = 36 + 182;
HelvNorm: array[0..254] of Word = (0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,278,278,355,556,556,889,667,222,333,333,389,584,
278,333,278,278,556,556,556,556,556,556,556,556,556,556,278,278,584,584,584,556,1015,667,667,722,722,667,611,778,
722,278,500,667,556,833,722,778,667,778,722,667,611,722,667,944,667,667,611,278,278,278,469,556,222,556,556,500,556,
556,278,556,556,222,222,500,222,833,556,556,556,556,333,500,278,556,500,722,500,500,500,334,260,334,584,0,0,0,0,0,0,
0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,333,556,556,167,556,556,556,556,191,333,556,333,333,500,500,0,556,
556,556,278,0,537,350,222,333,333,556,1000,1000,0,611,0,333,333,333,333,333,333,333,333,0,333,333,0,333,333,333,1000,0,0,0,0,0,0,
0,0,0,0,0,0,0,0,0,0,1000,0,370,0,0,0,0,556,778,1000,365,0,0,0,0,0,889,0,0,0,278,0,0,222,611,944,611,0,0,0);
HelvBold: array[0..254] of Word = (0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,278,333,474,556,556,889,722,278,333,333,389,584,278,333,
278,278,556,556,556,556,556,556,556,556,556,556,333,333,584,584,584,611,975,722,722,722,722,667,611,778,722,278,556,722,611,833,722,778,
667,778,722,667,611,722,667,944,667,667,611,333,278,333,584,556,278,556,611,556,611,556,333,611,611,278,278,556,278,889,611,611,611,611,389,556,
333,611,556,778,556,556,500,389,280,389,584,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,333,556,556,167,556,556,556,556,
238,500,556,333,333,611,611,0,556,556,556,278,0,556,350,278,500,500,556,1000,1000,0,611,0,333,333,333,333,333,333,333,333,0,333,333,0,333,333,333,
1000,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1000,0,370,0,0,0,0,611,778,1000,365,0,0,0,0,0,889,0,0,0,278,0,0,278,611,944,611,0,0,0);
HelvBldI: array[0..254] of Word = (0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,278,333,474,556,556,889,722,278,333,333,389,584,278,
333,278,278,556,556,556,556,556,556,556,556,556,556,333,333,584,584,584,611,975,722,722,722,722,667,611,778,722,278,556,722,611,833,722,778,667,778,722,
667,611,722,667,944,667,667,611,333,278,333,584,556,278,556,611,556,611,556,333,611,611,278,278,556,278,889,611,611,611,611,389,556,333,611,556,778,556,
556,500,389,280,389,584,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,333,556,556,167,556,556,556,556,238,500,556,333,333,611,611,
0,556,556,556,278,0,556,350,278,500,500,556,1000,1000,0,611,0,333,333,333,333,333,333,333,333,0,333,333,0,333,333,333,1000,0,0,0,0,0,0,0,0,0,0,0,0,0,
0,0,0,1000,0,370,0,0,0,0,611,778,1000,365,0,0,0,0,0,889,0,0,0,278,0,0,278,611,944,611,0,0,0);
HelvItal: array[0..254] of Word = (0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,278,278,355,556,556,889,667,222,333,333,389,584,278,333,
278,278,556,556,556,556,556,556,556,556,556,556,278,278,584,584,584,556,1015,667,667,722,722,667,611,778,722,278,500,667,556,833,722,778,667,778,
722,667,611,722,667,944,667,667,611,278,278,278,469,556,222,556,556,500,556,556,278,556,556,222,222,500,222,833,556,556,556,556,333,500,278,556,500,722,
500,500,500,334,260,334,584,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,333,556,556,167,556,556,556,556,191,333,556,333,333,500,
500,0,556,556,556,278,0,537,350,222,333,333,556,1000,1000,0,611,0,333,333,333,333,333,333,333,333,0,333,333,0,333,333,333,1000,0,0,0,0,0,0,0,0,0,0,0,0,
0,0,0,0,1000,0,370,0,0,0,0,556,778,1000,365,0,0,0,0,0,889,0,0,0,278,0,0,222,611,944,611,0,0,0);
TimeBold: array[0..254] of Word = (0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,250,333,555,500,500,1000,833,333,333,333,500,570,250,333,
250,278,500,500,500,500,500,500,500,500,500,500,333,333,570,570,570,500,930,722,667,722,722,667,611,778,778,389,500,778,667,944,722,778,611,778,722,556,
667,722,722,1000,722,722,667,333,278,333,581,500,333,500,556,444,556,444,333,500,556,278,333,556,278,833,556,500,556,556,444,389,333,556,500,722,500,500,
444,394,220,394,520,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,333,500,500,167,500,500,500,500,278,500,500,333,333,556,556,0,500,
500,500,250,0,540,350,333,500,500,500,1000,1000,0,500,0,333,333,333,333,333,333,333,333,0,333,333,0,333,333,333,1000,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
1000,0,300,0,0,0,0,667,778,1000,330,0,0,0,0,0,722,0,0,0,278,0,0,278,500,722,556,0,0,0);
TimeBldI: array[0..254] of Word = (0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,250,389,555,500,500,833,778,333,333,333,500,570,250,333,
250,278,500,500,500,500,500,500,500,500,500,500,333,333,570,570,570,500,832,667,667,667,722,667,667,722,778,389,500,667,611,889,722,722,611,722,667,556,
611,722,667,889,667,611,611,333,278,333,570,500,333,500,500,444,500,444,333,500,556,278,278,500,278,778,556,500,500,500,389,389,278,556,444,667,500,444,
389,348,220,348,570,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,389,500,500,167,500,500,500,500,278,500,500,333,333,556,556,0,
500,500,500,250,0,500,350,333,500,500,500,1000,1000,0,500,0,333,333,333,333,333,333,333,333,0,333,333,0,333,333,333,1000,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
0,944,0,266,0,0,0,0,611,722,944,300,0,0,0,0,0,722,0,0,0,278,0,0,278,500,722,500,0,0,0);
TimeItal: array[0..254] of Word = (0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,250,333,420,500,500,833,778,333,333,333,500,675,250,
333,250,278,500,500,500,500,500,500,500,500,500,500,333,333,675,675,675,500,920,611,611,667,722,611,611,722,722,333,444,667,556,833,667,722,611,722,611,
500,556,722,611,833,611,556,556,389,278,389,422,500,333,500,500,444,500,444,278,500,500,278,278,444,278,722,500,500,500,500,389,389,278,500,444,667,444,
444,389,400,275,400,541,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,389,500,500,167,500,500,500,500,214,556,500,333,333,500,500,
0,500,500,500,250,0,523,350,333,556,556,500,889,1000,0,500,0,333,333,333,333,333,333,333,333,0,333,333,0,333,333,333,889,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
889,0,276,0,0,0,0,556,722,944,310,0,0,0,0,0,667,0,0,0,278,0,0,278,500,667,500,0,0,0);
TimeNorm: array[0..254] of Word = (0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,250,333,408,500,500,833,778,333,333,333,500,564,250,333,
250,278,500,500,500,500,500,500,500,500,500,500,278,278,564,564,564,444,921,722,667,667,722,611,556,722,722,333,389,722,611,889,722,722,556,722,667,556,
611,722,722,944,722,722,611,333,278,333,469,500,333,444,500,444,500,444,333,500,500,278,278,500,278,778,500,500,500,500,333,389,278,500,500,722,500,500,
444,480,200,480,541,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,333,500,500,167,500,500,500,500,180,444,500,333,333,556,556,0,500,
500,500,250,0,453,350,333,444,444,500,1000,1000,0,444,0,333,333,333,333,333,333,333,333,0,333,333,0,333,333,333,1000,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,889,
0,276,0,0,0,0,611,722,889,310,0,0,0,0,0,667,0,0,0,278,0,0,278,500,722,500,0,0,0);
DingNorm: array[0..254] of Word = (0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,278,974,961,974,980,719,789,790,791,690,960,939,549,
855,911,933,911,945,974,755,846,762,761,571,677,763,760,759,754,494,552,537,577,692,786,788,788,790,793,794,816,823,789,841,823,833,816,831,923,744,723,
749,790,792,695,776,768,792,759,707,708,682,701,826,815,789,789,707,687,696,689,786,787,713,791,785,791,873,761,762,762,759,759,892,892,788,784,438,138,
277,415,392,392,668,668,0,390,390,317,317,276,276,509,509,410,410,234,234,334,334,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,732,544,544,910,667,760,760,
776,595,694,626,788,788,788,788,788,788,788,788,788,788,788,788,788,788,788,788,788,788,788,788,788,788,788,788,788,788,788,788,788,788,788,788,788,788,
788,788,788,788,788,788,894,838,1016,458,748,924,748,918,927,928,928,834,873,828,924,924,917,930,931,463,883,836,836,867,867,696,696,874,0,874,760,946,
771,865,771,888,967,888,831,873,927,970,918);
var FOptions: TExtraOptions = Nil;
function Replace(cString, cSearch, cReplace: String): String;
var
nSize, nPos, I, nOrig, nNext: Integer;
begin
I := 0;
nPos := 0;
nSize := Length(cReplace) - Length(cSearch);
nOrig := Length(cString);
Result := cString;
nNext := Pos(cSearch, cString);
while nNext > 0 do begin
nPos := nPos + nNext;
Delete(Result, nPos + (I * nSize), Length(cSearch));
Insert(cReplace, Result, nPos + (I * nSize));
Inc(I);
nNext := Pos(cSearch, Copy(cString, nPos + 1, nOrig - nPos));
end;
end;
function IndexOf(SL: TStringList; Value: String): Integer;
var
I: Integer;
begin
Result := -1;
for I := 0 to SL.Count - 1 do begin
if SL[I] = Value then begin
Result := I;
Break;
end;
end;
end;
function MaxInt(I1, I2: Integer): Integer;
begin
if I1 > I2 then begin
Result := I1;
end else begin
Result := I2;
end;
end;
function LotWord(Value: Integer): String;
begin
Result := CHR(Value mod 256) + CHR(Trunc(Value div 256));
end;
type
IEEES = array[1..8] of byte;
function FloatToIEEE(Value: Double): String;
var
T: IEEES;
I: Integer;
begin
T := IEEES(Value);
Result := ´´;
for I := 1 to 8 do begin
Result := Result + Char(T[I]);
end;
end;
function TextToFloat(Value: String): Double;
var
I: Integer;
T: String;
begin
T := ´´;
for I := 1 to Length(Value) do begin
if Value[I] in [´0´..´9´, DecimalSeparator, ´-´, ´E´] then begin
T := T + Value[I];
end;
end;
try
Result := StrToFloat(T);
except
Result := 0;
end;
end;
function TextToIEEE(Value: String): String;
begin
Result := FloatToIEEE(TextToFloat(Value));
end;
function IncFile(FileName: String; Value: Integer; AddPath: Boolean): String;
var
Base, Ext: String;
begin
Ext := ExtractFileExt(FileName);
Base := ExtractFileName(FileName);
Base := Copy(Base, 1, Length(Base) - Length(Ext));
if AddPath then begin
Result := ExtractFilePath(FileName) + Base + FormatFloat(´0000´, Value) + Ext;
end else begin
Result := Base + FormatFloat(´0000´, Value) + Ext;
end;
end;
function ThousandthsToTwips(Value: Integer): Integer;
begin
Result := Trunc((Value / 1000) * 0.0393701 * 1440);
end;
function ThousandthsToPoints(Value: Integer): Integer;
begin
Result := Round((Value / 1000) * 0.0393701 * 72);
end;
function EThousandthsToPoints(Value: Integer): Extended;
begin
Result := (Value / 1000) * 0.0393701 * 72;
end;
function PixelsToTwips(Value: Extended): Integer;
begin
Result := Trunc((Value * (1 / 96)) * 1440);
end;
function PixelsToPoints(Value: Extended): Integer;
begin
Result := Trunc((Value * (1 / 96)) * 72);
end;
function PointsToPixels(Value: Extended): Integer;
begin
Result := Trunc((Value * (1 / 72)) * 96);
end;
function VertPixelsToThousandths(Value: Integer): Integer;
begin
Result := Round(ppFromScreenPixels(Value, utMMThousandths, pprtVertical, Nil));
end;
function HorzPixelsToThousandths(Value: Integer): Integer;
begin
Result := Round(ppFromScreenPixels(Value, utMMThousandths, pprtHorizontal, Nil));
end;
function ThousandthsToHorzPixels(Value, PixelsPerInch: Integer): Integer;
begin
Value := Trunc(Value * (PixelsPerInch / Screen.PixelsPerInch));
Result := ppToScreenPixels(Value, utMMThousandths, pprtHorizontal, Nil);
end;
function ThousandthsToVertPixels(Value, PixelsPerInch: Integer): Integer;
begin
Value := Trunc(Value * (PixelsPerInch / Screen.PixelsPerInch));
Result := ppToScreenPixels(Value, utMMThousandths, pprtVertical, Nil);
end;
procedure ClearBitmap(B: TBitmap);
begin
B.Canvas.Brush.Color := clWhite;
B.Canvas.FillRect(Rect(0, 0, B.Width, B.Height));
end;
function RTFToString(RTF: TppDrawRichText): String;
var
Buffer: String;
begin
if RTF.StartCharPos = 0 then begin
RTF.RichTextStream.Position := 0;
SetLength(Buffer, RTF.RichTextStream.Size);
RTF.RichTextStream.Read(Buffer[1], RTF.RichTextStream.Size);
if Copy(Buffer, Length(Buffer) - 2, 2) = #13 + 10 then begin
Buffer := Copy(Buffer, 1, Length(Buffer) - 2);
end;
Result := Trim(Buffer);
end else begin
Result := ´´;
end;
end;
function RTFToPlainString(RTF: TppDrawRichText): String;
var
RE: TRichEdit;
N: Integer;
begin
RE := TRichEdit.Create(Nil);
RE.Parent := ppParentWnd;
RTF.RichTextStream.Position := 0;
RE.Width := ThousandthsToHorzPixels(RTF.Width, Screen.PixelsPerInch);
RE.Lines.LoadFromStream(RTF.RichTextStream);
RE.SelStart := 0;
RE.SelLength := RTF.StartCharPos;
RE.ClearSelection;
RE.SelectAll;
N := RE.SelLength;
RE.SelStart := RTF.EndCharPos + 1;
RE.SelLength := N;
RE.ClearSelection;
Result := RE.Lines.Text;
RE.Free;
end;
function ColorToHex(Value: TColor): String;
var
Color: Integer;
begin
Color := ColorToRGB(Value);
Result := ´#´ + IntToHex(GetRValue(Color), 2) + IntToHex(GetGValue(Color), 2) + IntToHex(GetBValue(Color), 2)
end;
function ColorToStr(Value: TColor): String;
var
Color: Integer;
begin
Color := ColorToRGB(Value);
Result := FormatFloat(´000´, GetRValue(Color)) + FormatFloat(´000´, GetGValue(Color)) + FormatFloat(´000´, GetBValue(Color));
end;
function ColorToPDF(Value: TColor): String;
var
Color: Integer;
begin
Color := ColorToRGB(Value);
Result := FormatFloat(´0.000´, GetRValue(Color) / 255) + ´ ´ + FormatFloat(´0.000´, GetGValue(Color) / 255) + ´ ´ + FormatFloat(´0.000´, GetBValue(Color) / 255);
Result := Replace(Result, DecimalSeparator, ´.´);
end;
function FmtFloat(Value: Extended): String;
begin
// Result := FloatToStr(Value);
Result := FormatFloat(´#0.0´, Value);
Result := Replace(Result, DecimalSeparator, ´.´);
end;
function ZOrderSort(Item1, Item2: Pointer): Integer;
begin
Result := 0;
if TReportItem(Item1).ZOrder > TReportItem(Item2).ZOrder then begin
Result := 1;
end;
if TReportItem(Item1).ZOrder < TReportItem(Item2).ZOrder then begin
Result := -1;
end;
if TReportItem(Item1).ZOrder = TReportItem(Item2).ZOrder then begin
Result := 0;
end;
end;
function TextHeight(Font: TFont): Integer;
var
DC: HDC;
TM: TTextMetric;
SaveFont: HFont;
begin
DC := GetDC(0);
SaveFont := SelectObject(DC, Font.Handle);
GetTextMetrics(DC, TM);
Result := TM.tmAscent + TM.tmDescent + TM.tmExternalLeading;
SelectObject(DC, SaveFont);
ReleaseDC(0, DC);
Result := PixelsToPoints(Result);
end;
function Occurs(Value, Sub: String): Integer;
var
I: Integer;
begin
Result := 0;
for I := 1 to Length(Value) do begin
if Value[I] = Sub then begin
Result := Result + 1;
end;
end;
end;
function HTMLEncode(Txt: String): String;
var
I, N: Integer;
begin
Result := Txt;
Result := Replace(Result, ´&´, ´&´);
Result := Replace(Result, ´<´, ´<´);
Result := Replace(Result, ´>´, ´>´);
Result := Replace(Result, ´´´, ´"´);
Result := Replace(Result, ´ä´, ´ä´);
Result := Replace(Result, ´Ä´, ´Ä´);
Result := Replace(Result, ´ö´, ´&oml;´);
Result := Replace(Result, ´Ö´, ´&Oml;´);
Result := Replace(Result, ´ü´, ´ü´);
Result := Replace(Result, ´Ü´, ´Ü´);
N := Length(Result) - Length(TrimLeft(Result));
Result := TrimLeft(Result);
for I := 1 to N do begin
Result := ´ ´ + Result;
end;
end;
function BuildFont(Face: String; Col: TColor; Size: Integer): String;
begin
Result := ´´;
Result := Result + ´<FONT´;
Result := Result + ´ STYLE=´ + CHR(34);
Result := Result + ´ font-family: ´ + Face + ´;´;
Result := Result + ´ color: ´ + ColorToHex(Col) + ´;´;
Result := Result + ´ font-size: ´ + IntToStr(Size) + ´pt;´;
Result := Result + CHR(34) + ´>´;
end;
function RTF2HTML(RTFCmd: TppDrawRichText): String;
var
BoldOn, UndOn, ItalicOn, FontOn: Boolean;
RTF: TRTFParser;
FontSize: Integer;
FontFace: String;
FontColor: TColor;
begin
BoldOn := False;
UndOn := False;
ItalicOn := False;
FontOn := False;
FontSize := 10;
FontColor := clBlack;
FontFace := ´Arial´;
Result := ´<DIV>´;
RTFCmd.RichTextStream.Position := 0;
RTF := TRTFParser.Create(RTFCmd.RichTextStream);
while RTF.Token <> rtEOF do begin
case RTF.Token of
rtText: begin
if BoldOn then begin
Result := Result + ´´;
end;
if UndOn then begin
Result := Result + ´´;
end;
if ItalicOn then begin
Result := Result + ´´;
end;
Result := Result + HTMLEncode(RTF.TokenString);
if ItalicOn then begin
Result := Result + ´´;
end;
if UndOn then begin
Result := Result + ´´;
end;
if BoldOn then begin
Result := Result + ´´;
end;
end;
rtControl: begin
if RTF.TokenString = ´tab´ then begin
Result := Result + HTMLEncode(StringOfChar(´ ´, 9));
end;
if RTF.TokenString = ´par´ then begin
Result := Result + ´
´ + CRLF;
end;
if RTF.TokenString = ´pard´ then begin
Result := Result + ´</DIV>´;
Result := Result + ´<DIV ALIGN=LEFT ´ + Copy(BuildFont(FontFace, FontColor, FontSize), 6, 100);
end;
if RTF.TokenString = ´ql´ then begin
Result := Result + ´</DIV>´;
Result := Result + ´<DIV ALIGN=LEFT ´ + Copy(BuildFont(FontFace, FontColor, FontSize), 6, 100);
end;
if RTF.TokenString = ´qr´ then begin
Result := Result + ´</DIV>´;
Result := Result + ´<DIV ALIGN=RIGHT ´ + Copy(BuildFont(FontFace, FontColor, FontSize), 6, 100);
end;
if RTF.TokenString = ´qc´ then begin
Result := Result + ´</DIV>´;
Result := Result + ´<DIV ALIGN=CENTER ´ + Copy(BuildFont(FontFace, FontColor, FontSize), 6, 100);
end;
if RTF.TokenString = ´f´ then begin
if FontOn then begin
Result := Result + ´´;
end;
FontOn := True;
FontFace := RTF.Font[RTF.TokenValue];
Result := Result + BuildFont(FontFace, FontColor, FontSize);
end;
if RTF.TokenString = ´cf´ then begin
if FontOn then begin
Result := Result + ´´;
end;
FontOn := True;
FontColor := RTF.Color[RTF.TokenValue];
Result := Result + BuildFont(FontFace, FontColor, FontSize);
end;
if RTF.TokenString = ´fs´ then begin
if FontOn then begin
Result := Result + ´´;
end;
FontOn := True;
FontSize := RTF.TokenValue div 2;
Result := Result + BuildFont(FontFace, FontColor, FontSize);
end;
if RTF.TokenString = ´b´ then begin
if BoldOn and RTF.HasTokenValue and (RTF.TokenValue = 0) then begin
BoldOn := False;
end else begin
BoldOn := True;
end;
end;
if RTF.TokenString = ´ul´ then begin
if UndOn and RTF.HasTokenValue and (RTF.TokenValue = 0) then begin
UndOn := False;
end else begin
UndOn := True;
end;
end;
if RTF.TokenString = ´ulnone´ then begin
UndOn := False;
end;
if RTF.TokenString = ´i´ then begin
if ItalicOn and RTF.HasTokenValue and (RTF.TokenValue = 0) then begin
ItalicOn := False;
end else begin
ItalicOn := True;
end;
end;
if RTF.TokenString = ´plain´ then begin
BoldOn := False;
UndOn := False;
ItalicOn := False;
if FontOn then begin
FontOn := False;
Result := Result + ´´;
end;
end;
end;
end;
RTF.NextToken;
end;
RTF.Free;
if FontOn then begin
Result := Result + ´´;
end;
Result := Result + ´</DIV>´;
end;
{ TExtraDevice }
constructor TExtraDevice.Create(aOwner: TComponent);
begin
inherited;
end;
destructor TExtraDevice.Destroy;
begin
inherited;
end;
procedure TExtraDevice.StartJob;
begin
inherited;
MemStream := TMemoryStream.Create;
SeparateBands := True;
ConvertFonts := False;
InitCRCTable;
ImageList := TList.Create;
FRow := 0;
FCol := 0;
FPageNo := 0;
FImageNo := 0;
end;
procedure TExtraDevice.EndJob;
var
I: Integer;
begin
MemStream.Free;
for I := 0 to ImageList.Count - 1 do begin
TImageCRC(ImageList[I]).Free;
end;
ImageList.Free;
inherited;
end;
procedure TExtraDevice.StartPage;
begin
Inc(FPageNo);
end;
procedure TExtraDevice.EndPage;
begin
end;
procedure TExtraDevice.StartBand;
begin
FCol := 0;
end;
procedure TExtraDevice.EndBand;
begin
Inc(FRow);
end;
procedure TExtraDevice.ProcessBand(Band: TReportBand);
begin
end;
procedure TExtraDevice.ReceivePage(aPage: TppPage);
begin
inherited;
Page := aPage;
{$IFDEF EXTRADEMO}
if FPageNo > 0 then begin
Exit;
end;
{$ENDIF}
if IsRequestedPage then begin
DisplayMessage(aPage);
if not IsMessagePage then begin
SavePageToFile(aPage);
end;
end;
end;
procedure TExtraDevice.Write(Buffer: String);
begin
if Length(Buffer) > 0 then begin
FileStream.Write(Buffer[1], Length(Buffer));
end;
end;
procedure TExtraDevice.Stream(Buffer: String);
begin
if Length(Buffer) > 0 then begin
MemStream.Write(Buffer[1], Length(Buffer));
end;
end;
procedure TExtraDevice.GetDrawCommands(Page: TppPage; Cmds: TStringList);
var
I, N, W, X, Y, Row, LastTop: Integer;
DrawCmd: TppDrawCommand;
Order: String;
Itm: TReportItem;
Txt: TppDrawText;
begin
N := Page.DrawCommandCount;
for I := 0 to N - 1 do begin
DrawCmd := Page.DrawCommands[I];
Order := ´´;
Itm := TReportItem.Create;
Itm.ItemType := riIgnore;
Itm.DrawCmd := DrawCmd;
Itm.Top := DrawCmd.Top;
Itm.Left := DrawCmd.Left;
Itm.Width := DrawCmd.Width;
Itm.Height := DrawCmd.Height;
Itm.ZOrder := I;
if DrawCmd is TppDrawLine then begin
if TppDrawLine(DrawCmd).Pen.Style <> psClear then begin
Itm.ItemType := riLine;
if TppDrawLine(DrawCmd).LineStyle = lsSingle then begin
X := 1;
end else begin
X := 3;
end;
if TppDrawLine(DrawCmd).Pen.Width = 0 then begin
W := VertPixelsToThousandths(1);
end else begin
W := VertPixelsToThousandths(Trunc(TppDrawLine(DrawCmd).Pen.Width));
end;
case TppDrawLine(DrawCmd).LinePosition of
lpTop: begin
Itm.Height := X * (W + 3);
end;
lpBottom: begin
Y := X * (W + 3);
Itm.Top := Itm.Top + Itm.Height - Y;
Itm.Height := Y;
end;
lpLeft: begin
Itm.Width := X * (W + 3);
end;
lpRight: begin
Y := X * (W + 3);
Itm.Left := Itm.Left + Itm.Width - Y;
Itm.Width := Y;
Itm.AdjWidth := Itm.Width;
end;
end;
end;
end;
if DrawCmd is TppDrawText then begin
Txt := TppDrawText(Itm.DrawCmd);
Itm.ItemType := riText;
if (UpperCase(Txt.Font.Name) = ´WINGDINGS´) and (Length(Txt.Text) = 1) then begin
if (Txt.Text[1] in [#168, 254, 252, 251, 253]) then begin
Itm.ItemType := riCheckBox;
end;
end;
TppDrawText(Itm.DrawCmd).Font.Size := Abs(TppDrawText(Itm.DrawCmd).Font.Size);
if ConvertFonts then begin
TppDrawText(Itm.DrawCmd).Font.Name := ConvertFont(TppDrawText(Itm.DrawCmd).Font.Name);
end;
end;
if DrawCmd is TppDrawRichText then begin
Itm.ItemType := riRTF;
end;
if DrawCmd is TppDrawImage then begin
if TppDrawImage(DrawCmd).Picture.Width <> 0 then begin
Itm.ItemType := riImage;
end;
end;
if DrawCmd is TppDrawShape then begin
if (TppDrawShape(DrawCmd).Pen.Style <> psClear) or (TppDrawShape(DrawCmd).Brush.Style <> bsClear) then begin
Itm.ItemType := riShape;
end;
end;
if DrawCmd is TppDrawBarCode then begin
if TppDrawBarCode(DrawCmd).Data <> ´´ then begin
CalcBarCodeSize(Itm);
Itm.ItemType := riBarCode;
end;
end;
CalcSize(Itm);
Order := FormatFloat(´00000000´, Itm.Top) + FormatFloat(´00000000´, Itm.Left);
Cmds.AddObject(Order, Itm);
end;
Cmds.Sort;
Row := 0;
I := 0;
while I < Cmds.Count do begin
Itm := TReportItem(Cmds.Objects[I]);
LastTop := Itm.Top + 2000;
while LastTop > Itm.Top do begin
Itm.Row := Row;
Cmds[I] := FormatFloat(´00000000´, Itm.Row) + FormatFloat(´00000000´, Itm.Left);
Inc(I);
if I >= Cmds.Count then begin
Break;
end else begin
Itm := TReportItem(Cmds.Objects[I]);
end;
end;
Inc(Row);
end;
Cmds.Sort;
end;
procedure TExtraDevice.CalcSize(Itm: TReportItem);
var
Bmp: TBitmap;
Cmd: TppDrawText;
Right, Center, Left, Width, Height: Integer;
begin
Itm.AdjLeft := Itm.Left;
Itm.AdjWidth := Itm.Width;
Itm.AdjHeight := Itm.Height;
if Itm.DrawCmd is TppDrawText then begin
Left := Itm.Left;
Width := Itm.Width;
Height := Itm.Height;
Center := Itm.Left + Itm.Width div 2;
Right := Itm.Left + Itm.Width;
Cmd := TppDrawText(Itm.DrawCmd);
Bmp := TBitmap.Create;
Bmp.Canvas.Font := Cmd.Font;
if Cmd.IsMemo then begin
end else begin
Width := Bmp.Canvas.TextWidth(Cmd.Text);
Width := Trunc(ppFromScreenPixels(Width, utMMThousandths, pprtHorizontal, Nil));
Height := Bmp.Canvas.TextHeight(Cmd.Text);
Height := Trunc(ppFromScreenPixels(Height, utMMThousandths, pprtVertical, Nil));
end;
if Cmd.TextAlignment = taRightJustified then begin
Left := Right - Width;
end;
if Cmd.TextAlignment = taCentered then begin
Left := Center - Width div 2;
end;
Bmp.Free;
if Cmd.AutoSize = True then begin
Itm.Left := Left;
Itm.Width := Width;
Itm.Height := Height;
end;
Itm.AdjLeft := Left;
Itm.AdjWidth := Width;
Itm.AdjHeight := Height;
end;
end;
procedure TExtraDevice.CalcBarCodeSize(Itm: TReportItem);
var
Bmp: TBitmap;
Bar: TppDrawBarCode;
begin
Bar := TppDrawBarCode(Itm.DrawCmd);
if Bar.AutoSize = True then begin
Bmp := TBitmap.Create;
Bar.CalcBarCodeSize(Bmp.Canvas);
if Bar.Orientation in [orLeftToRight, orRightToLeft] then begin
Itm.Width := HorzPixelsToThousandths(Bar.PortraitWidth);
Itm.Height := VertPixelsToThousandths(Bar.PortraitHeight);
end else begin
Itm.Width := HorzPixelsToThousandths(Bar.PortraitHeight);
Itm.Height := VertPixelsToThousandths(Bar.PortraitWidth);
end;
Bmp.Free;
end;
end;
function TExtraDevice.ConvertFont(FontName: String): String;
begin
Result := ´Times New Roman´;
if Pos(´COURIER´, UpperCase(FontName)) <> 0 then begin
Result := ´Courier´;
end;
if Pos(´ARIAL´, UpperCase(FontName)) <> 0 then begin
Result := ´Arial´;
end;
if Pos(´WINGDINGS´, UpperCase(FontName)) <> 0 then begin
Result := ´Wingdings´;
end;
if Pos(´TIMES´, UpperCase(FontName)) <> 0 then begin
Result := ´Times New Roman´;
end;
end;
procedure TExtraDevice.SavePageToFile(Page: TppPage);
var
I: Integer;
Cmds: TStringList;
RptItem: TReportItem;
LastRow: Integer;
Band: TReportBand;
begin
Cmds := TStringList.Create;
GetDrawCommands(Page, Cmds);
if Cmds.Count = 0 then begin
Cmds.Free;
Exit;
end;
StartPage;
// Process Commands
I := 0;
while I < Cmds.Count do begin
RptItem := TReportItem(Cmds.Objects[I]);
LastRow := RptItem.Row;
StartBand;
Band := TReportBand.Create;
while (not SeparateBands) or (LastRow = RptItem.Row) do begin
Band.Add(RptItem);
Inc(I);
if I >= Cmds.Count then begin
Break;
end else begin
RptItem := TReportItem(Cmds.Objects[I]);
end;
end;
ProcessBand(Band);
Band.Free;
EndBand;
end;
EndPage;
for I := 0 to Cmds.Count - 1 do begin
TReportItem(Cmds.Objects[I]).Free;
end;
Cmds.Free;
end;
procedure TExtraDevice.DrawLine(B: TCanvas; Lne: TppDrawLine; Bounds: TRect);
var
Width, Height, N, L, H, X, XOffset, YOffset: Integer;
begin
Width := Bounds.Right - Bounds.Left;
Height := Bounds.Bottom - Bounds.Top;
B.Pen.Assign(Lne.Pen);
B.Pen.Width := 1;
X := PointsToPixels(Lne.Weight);
if X = 0 then begin
X := 1;
end;
if Lne.LineStyle = lsSingle then begin
N := 1;
end else begin
N := 2;
end;
XOffset := Bounds.Left;
YOffset := Bounds.Top;
for L := 0 to N - 1 do begin
for H := 0 to X - 1 do begin
if Lne.LinePosition = lpTop then begin
B.MoveTo(XOffset, YOffset + H + (L * X * 2));
B.LineTo(XOffset + Width, YOffset + H + (L * X * 2));
end;
if Lne.LinePosition = lpBottom then begin
B.MoveTo(XOffset, YOffset + (Height - 1) - H - (L * X * 2));
B.LineTo(XOffset + Width, YOffset + (Height - 1) - H - (L * X * 2));
end;
if Lne.LinePosition = lpLeft then begin
B.MoveTo(XOffset + H + (L * X * 2), YOffset);
B.LineTo(XOffset + H + (L * X * 2), YOffset + Height);
end;
if Lne.LinePosition = lpRight then begin
B.MoveTo(XOffset + Width - H - (L * X * 2) - 1, YOffset);
B.LineTo(XOffset + Width - H - (L * X * 2) - 1, YOffset + Height);
end;
end;
end;
end;
procedure TExtraDevice.DrawShape(B: TCanvas; Shp: TppDrawShape; Bounds: TRect);
var
Top, Left, Width, Height, XCR, YCR: Integer;
begin
// Removed 4/9/00
// if Shp.Pen.Width <> 1 then begin
// InflateRect(Bounds, -Shp.Pen.Width, -Shp.Pen.Width);
// end;
Width := Bounds.Right - Bounds.Left;
Height := Bounds.Bottom - Bounds.Top;
B.Brush.Assign(Shp.Brush);
B.Pen.Assign(Shp.Pen);
if B.Pen.Width = 0 then begin
B.Pen.Width := 1;
end;
if Shp.ShapeType in [stCircle] then begin
if Width > Height then begin
Left := Bounds.Left + (Width - Height) div 2;
B.Ellipse(Left, Bounds.Top, Left + Height, Bounds.Bottom);
end else begin
Top := Bounds.Top + (Height - Width) div 2;
B.Ellipse(Bounds.Left, Top, Bounds.Right, Top + Width);
end;
end;
if Shp.ShapeType in [stEllipse] then begin
B.Ellipse(Bounds.Left, Bounds.Top, Bounds.Right, Bounds.Bottom);
end;
if Shp.ShapeType in [stSquare] then begin
if Width > Height then begin
Left := Bounds.Left + (Width - Height) div 2;
B.Rectangle(Left, Bounds.Top, Left + Height, Bounds.Bottom);
end else begin
Top := Bounds.Top + (Height - Width) div 2;
B.Rectangle(Bounds.Left, Top, Bounds.Right, Top + Width);
end;
end;
if Shp.ShapeType in [stRectangle] then begin
B.Rectangle(Bounds.Left, Bounds.Top, Bounds.Right, Bounds.Bottom);
end;
if Shp.ShapeType in [stRoundSquare] then begin
XCR := ppToScreenPixels(Shp.XCornerRound, utMMThousandths, pprtHorizontal, Nil);
YCR := ppToScreenPixels(Shp.YCornerRound, utMMThousandths, pprtVertical, Nil);
if Width > Height then begin
Left := Bounds.Left + (Width - Height) div 2;
B.RoundRect(Left, Bounds.Top, Left + Height, Bounds.Bottom, XCR, YCR);
end else begin
Top := Bounds.Top + (Height - Width) div 2;
B.RoundRect(Bounds.Left, Top, Bounds.Right, Top + Width, XCR, YCR);
end;
end;
if Shp.ShapeType in [stRoundRect] then begin
XCR := ppToScreenPixels(Shp.XCornerRound, utMMThousandths, pprtHorizontal, Nil);
YCR := ppToScreenPixels(Shp.YCornerRound, utMMThousandths, pprtVertical, Nil);
B.RoundRect(Bounds.Left, Bounds.Top, Bounds.Right, Bounds.Bottom, XCR, YCR);
end;
end;
procedure TExtraDevice.DrawBarCode(B: TCanvas; Bar: TppDrawBarCode; Bounds: TRect);
var
T: TBitmap;
P: TPoint;
begin
T := TBitmap.Create;
Bar.CalcBarCodeSize(T.Canvas);
if Bar.Orientation in [orLeftToRight, orRightToLeft] then begin
T.Width := Bar.PortraitWidth;
T.Height := Bar.PortraitHeight;
end else begin
T.Width := Bar.PortraitHeight;
T.Height := Bar.PortraitWidth;
end;
P := Point(Screen.PixelsPerInch, Screen.PixelsPerInch);
T.Canvas.Pen.Color := clBlack;
Bar.DrawBarCode(T.Canvas, 0, 0, P, True);
B.StretchDraw(Bounds, T);
T.Free;
end;
procedure TExtraDevice.DrawRichText(B: TBitmap; DRT: TppDrawRichText; Bounds: TRect);
var
MF: TMetaFile;
MC: TMetaFileCanvas;
Width, Height: Integer;
CharRange: TCharRange;
DC: hDC;
R: TRect;
RE: TCustomRichEdit;
begin
RE := ppGetRichEditClass.Create(ppParentWnd);
RE.Parent := ppParentWnd;
DRT.RichTextStream.Position := 0;
ppGetRichEditLines(RE).LoadFromStream(DRT.RichTextStream);
CharRange.cpMin := DRT.StartCharPos;
CharRange.cpMax := DRT.EndCharPos;
DC := GetDC(0);
Width := Bounds.Right - Bounds.Left;
Height := Bounds.Bottom - Bounds.Top;
R := Rect(0, 0, Width, Height);
MF := TMetaFile.Create;
MF.Width := Width;
MF.Height := Height;
MC := TMetaFileCanvas.Create(MF, DC);
if not DRT.Transparent then begin
MC.Brush.Style := bsSolid;
MC.Brush.Color := DRT.Color;
MC.FillRect(Bounds);
end;
ppGetRTFEngine(RE).DrawRichText(MC.Handle, DC, R, CharRange);
MC.Free;
ReleaseDC(0, DC);
B.Canvas.StretchDraw(Bounds, MF);
MF.Free;
RE.Free;
end;
procedure TExtraDevice.DrawImage(B: TBitmap; Itm: TReportItem; Bounds: TRect; AdjBitmap, IgnoreAttr, AdjImage: Boolean);
var
Scale: Extended;
R: TRect;
W: TBitmap;
Width, Height: Integer;
Img: TppDrawImage;
begin
Img := TppDrawImage(Itm.DrawCmd);
Width := Bounds.Right - Bounds.Left;
Height := Bounds.Bottom - Bounds.Top;
W := TBitmap.Create;
W.PixelFormat := B.PixelFormat;
if AdjImage then begin
W.Width := Img.Picture.Width;
W.Height := Img.Picture.Height;
end else begin
W.Width := Width;
W.Height := Height;
end;
if not IgnoreAttr then begin
if Img.Stretch and Img.MaintainAspectRatio then begin
R := Rect(0, 0, Width, Height);
Scale := ppCalcAspectRatio(Img.Picture.Width, Img.Picture.Height, Width, Height);
if Img.Center then begin
R.Left := R.Left + ((Width - Trunc(Img.Picture.Width * Scale)) div 2);
R.Top := R.Top + ((Height - Trunc(Img.Picture.Height * Scale)) div 2);
end;
R.Right := R.Left + Trunc(Img.Picture.Width * Scale);
R.Bottom := R.Top + Trunc(Img.Picture.Height * Scale);
end else if Img.Stretch then begin
R := Rect(0, 0, Width, Height);
end else if Img.Center then begin
R := Rect((Width - Img.Picture.Width) div 2, (Height - Img.Picture.Height) div 2, Img.Picture.Width, Img.Picture.Height)
end else begin
R := Rect(0, 0, Img.Picture.Width, Img.Picture.Height);
end;
end else begin
R := Rect(0, 0, Img.Picture.Width, Img.Picture.Height);
end;
if AdjBitmap then begin
B.Width := W.Width;
B.Height := W.Height;
B.PixelFormat := W.PixelFormat;
if Img.Picture.Graphic is TMetaFile then begin
B.Palette := Img.Picture.MetaFile.Palette;
end;
if Img.Picture.Graphic is TBitmap then begin
B.Palette := Img.Picture.Bitmap.Palette;
end;
end;
if AdjImage then begin
B.Canvas.Draw(0, 0, Img.Picture.Graphic);
end else begin
W.Canvas.StretchDraw(R, Img.Picture.Graphic);
B.Canvas.CopyMode := cmSrcCopy;
B.Canvas.CopyRect(Bounds, W.Canvas, Rect(0, 0, Width, Height));
end;
W.Free;
if AdjImage and (((R.Right - R.Left) < Img.Picture.Width) or ((R.Bottom - R.Top) < Img.Picture.Height)) then begin
Itm.Top := Itm.Top + VertPixelsToThousandths(R.Top);
Itm.Left := Itm.Left + HorzPixelsToThousandths(R.Left);
Itm.Width := HorzPixelsToThousandths(R.Right - R.Left);
Itm.Height := VertPixelsToThousandths(R.Bottom - R.Top);
end;
end;
procedure TExtraDevice.DrawCheckBox(B: TBitmap; Txt: TppDrawText; Bounds: TRect; AdjBitmap: Boolean; IgnoreAttr: Boolean);
var
Width, Height: Integer;
begin
B.Canvas.Font := Txt.Font;
B.Canvas.Font.Size := B.Canvas.Font.Size - Trunc(B.Canvas.Font.Size * 0.10);
B.Canvas.Brush.Color := clWhite;
Width := Bounds.Right - Bounds.Left;
Height := Bounds.Bottom - Bounds.Top;
if AdjBitmap then begin
B.Width := Width;
B.Height := Height;
B.PixelFormat := pf24bit;
end;
B.Canvas.TextOut(0, 1, Txt.Text);
end;
function TExtraDevice.WriteImage(B: TBitmap): String;
var
N: Integer;
J: TJPEGImage;
begin
Result := ´IMG´ + FormatFloat(´0000´, FImageNo) + ´.JPG´;
J := TJPEGImage.Create;
J.Assign(B);
N := ImageIndex(J, Result);
if N = -1 then begin
Inc(FImageNo);
try
J.SaveToFile(ExtractFilePath(FileName) + Result);
except
raise EPrintError.Create(´File Error: ´ + Result);
end;
end else begin
Result := TImageCRC(ImageList[N]).FileName;
end;
J.Free;
end;
function TExtraDevice.ImageIndex(J: TObject; FileName: String): Integer;
var
MS: TMemoryStream;
I: Integer;
N: Cardinal;
T: TImageCRC;
begin
MS := TMemoryStream.Create;
if J is TJPEGImage then begin
(J as TJPEGImage).SaveToStream(MS);
end else begin
(J as TBitmap).SaveToStream(MS);
end;
Result := -1;
N := CRC(MS);
for I := 0 to ImageList.Count - 1 do begin
if TImageCRC(ImageList[I]).CRC = N then begin
Result := I;
Break;
end;
end;
if Result = -1 then begin
T := TImageCRC.Create;
T.FileName := FileName;
T.CRC := N;
ImageList.Add(T);
end;
MS.Free;
end;
procedure TExtraDevice.InitCRCTable;
var
I, J: Integer;
begin
for I := 0 to 255 do begin
CRCTable[I] := I;
for J := 0 to 7 do begin
if Odd(CRCTable[I]) then begin
CRCTable[I] := CRCTable[I] shr 1;
CRCTable[I] := CRCTable[I] xor $EDB88320;
end else begin
CRCTable[I] := CRCTable[I] shr 1;
end;
end;
end;
end;
function TExtraDevice.CRC(MS: TMemoryStream): Cardinal;
var
I, J: Integer;
B: String;
begin
Result := 0;
MS.Position := 0;
B := ´ ´;
for I := 0 to MS.Size - 1 do begin
MS.Read(B[1], 1);
J := (Ord(B[1]) xor Result) and $000000FF;
Result := (Result shr 8) xor CRCTable[J];
end;
Result := not Result;
end;
{ WK1 Device }
class function TWK1Device.DeviceName: String;
begin
Result := ´LotusFile´;
end;
class function TWK1Device.DefaultExt: String;
begin
Result := ´WK1´;
end;
class function TWK1Device.DefaultExtFilter: String;
begin
Result := ´123 files|*.WK1|All files|*.*´;
end;
class function TWK1Device.DeviceDescription(aLanguageIndex: Longint): String;
begin
Result := ´Lotus File´;
end;
procedure TWK1Device.StartJob;
begin
inherited;
Write(CHR(0) + CHR(0) + CHR(2) + CHR(0) + CHR(6) + CHR(4));
end;
procedure TWK1Device.EndJob;
begin
if FileStream = Nil then begin
Exit;
end;
Write(CHR(1) + CHR(0) + CHR(0) + CHR(0));
inherited;
end;
procedure TWK1Device.ProcessBand(Band: TReportBand);
var
Text: String;
I, LastCol, Col: Integer;
Itm: TReportItem;
Txt: TppDrawText;
begin
inherited;
LastCol := -1;
for I := 0 to Band.Count - 1 do begin
Itm := TReportItem(Band[I]);
if Itm.ItemType = riText then begin
Txt := TppDrawText(Itm.DrawCmd);
Col := Trunc(Itm.Left / 16934);
if Col <= LastCol then begin
Col := LastCol + 1;
end;
LastCol := Col;
if Txt.DataType in [dtCurrency, dtDouble, dtExtended, dtInteger, dtLongInt, dtSingle] then begin
Write(LotWord(14) + LotWord(13) + CHR(128 + 2) + LotWord(Col) + LotWord(FRow) + TextToIEEE(Txt.Text));
end else begin
if Txt.IsMemo then begin
Text := Replace(Copy(Txt.WrappedText.Text, 1, 255), #13, ´ ´);
Text := Replace(Text, EOP, ´´);
end else begin
Text := Replace(Txt.Text, #13 + 10, ´ ´);;
end;
Write(LotWord(15) + LotWord(Length(Text) + 7) + CHR(255) + LotWord(Col) + LotWord(FRow) + 39 + Text + CHR(0));
end;
end;
if Itm.ItemType = riRTF then begin
Col := Trunc(Itm.Left / 16934);
if Col <= LastCol then begin
Col := LastCol + 1;
end;
LastCol := Col;
Text := RTFToPlainString(TppDrawRichText(Itm.DrawCmd));
Text := Replace(Copy(Text, 1, 255), 13 + 10, ´ ´);
Text := Replace(Text, EOP, ´´);
Write(LotWord(15) + LotWord(Length(Text) + 7) + CHR(255) + LotWord(Col) + LotWord(FRow) + 39 + Text + CHR(0));
end;
end;
end;
{ WQ1 Device }
class function TWQ1Device.DeviceName: String;
begin
Result := ´QuattroFile´;
end;
class function TWQ1Device.DefaultExt: String;
begin
Result := ´WQ1´;
end;
class function TWQ1Device.DefaultExtFilter: String;
begin
Result := ´Quattro files|*.WQ1|All files|*.*´;
end;
class function TWQ1Device.DeviceDescription(aLanguageIndex: Longint): String;
begin
Result := ´Quattro File´;
end;
procedure TWQ1Device.StartJob;
begin
inherited;
Write(CHR(0) + CHR(0) + CHR(2) + CHR(0) + CHR(32) + CHR(81));
end;
procedure TWQ1Device.EndJob;
begin
if FileStream = Nil then begin
Exit;
end;
Write(CHR(1) + CHR(0) + CHR(0) + CHR(0));
inherited;
end;
procedure TWQ1Device.ProcessBand(Band: TReportBand);
var
Text: String;
I, LastCol, Col: Integer;
Itm: TReportItem;
Txt: TppDrawText;
begin
inherited;
LastCol := -1;
for I := 0 to Band.Count - 1 do begin
Itm := TReportItem(Band[I]);
if Itm.ItemType = riText then begin
Col := Trunc(Itm.Left / 16934);
if Col <= LastCol then begin
Col := LastCol + 1;
end;
LastCol := Col;
Txt := TppDrawText(Itm.DrawCmd);
if Txt.DataType in [dtCurrency, dtDouble, dtExtended, dtInteger, dtLongInt, dtSingle] then begin
Write(LotWord(14) + LotWord(13) + CHR(128 + 2) + LotWord(Col) + LotWord(FRow) + TextToIEEE(Txt.Text));
end else begin
if Txt.IsMemo then begin
Text := Replace(Copy(Txt.WrappedText.Text, 1, 255), #13, ´ ´);
Text := Replace(Text, EOP, ´´);
end else begin
Text := Replace(Txt.Text, 13 + 10, ´ ´);
end;
Write(LotWord(15) + LotWord(Length(Text) + 7) + CHR(255) + LotWord(Col) + LotWord(FRow) + 39 + CHR(Length(Text)) + Text);
end;
end;
if Itm.ItemType = riRTF then begin
Col := Trunc(Itm.Left / 16934);
if Col <= LastCol then begin
Col := LastCol + 1;
end;
LastCol := Col;
Text := RTFToPlainString(TppDrawRichText(Itm.DrawCmd));
Text := Replace(Copy(Text, 1, 255), #13 + 10, ´ ´);
Text := Replace(Text, EOP, ´´);
Write(LotWord(15) + LotWord(Length(Text) + 7) + CHR(255) + LotWord(Col) + LotWord(FRow) + 39 + CHR(Length(Text)) + Text);
end;
end;
end;
{ XLS Device }
class function TXLSDevice.DeviceName: String;
begin
Result := ´ExcelFile´;
end;
class function TXLSDevice.DefaultExt: String;
begin
Result := ´XLS´;
end;
class function TXLSDevice.DefaultExtFilter: String;
begin
Result := ´Excel files|*.XLS|All files|*.*´;
end;
class function TXLSDevice.DeviceDescription(aLanguageIndex: Longint): String;
begin
Result := ´Excel File´;
end;
function TXLSDevice.FontIndex(Font: TFont): String;
var
I, S: Integer;
FontStr: String;
begin
S := 0;
if fsBold in Font.Style then begin
S := S + 1;
end;
if fsItalic in Font.Style then begin
S := S + 2;
end;
if fsUnderline in Font.Style then begin
S := S + 4;
end;
if fsStrikeOut in Font.Style then begin
S := S + 8;
end;
FontStr := LotWord(Font.Size * 20) + LotWord(S) + LotWord(0) + CHR(Length(Font.Name)) + Font.Name;
I := IndexOf(FontTbl, FontStr);
if I = -1 then begin
FontTbl.Add(FontStr);
I := FontTbl.Count - 1;
end;
if I > 3 then begin
Inc(I);
end;
Result := CHR(I);
end;
function TXLSDevice.FormatIndex(Format: String): String;
var
I: Integer;
FormatStr: String;
begin
FormatStr := Format;
I := IndexOf(FormatTbl, FormatStr);
if I = -1 then begin
FormatTbl.Add(FormatStr);
I := FormatTbl.Count - 1;
end;
Result := CHR(I);
end;
function TXLSDevice.XFIndex(Txt: TppDrawText; Numeric: Boolean): String;
var
I, Options: Integer;
XFStr: String;
begin
XFStr := FontIndex(Txt.Font);
if Numeric then begin
XFStr := XFStr + FormatIndex(´0.00´);
end else begin
XFStr := XFStr + FormatIndex(´General´);
end;
XFStr := XFStr + CHR($00) + CHR($00); // XF Index
Options := 0;
case Txt.TextAlignment of
taLeftJustified: Options := 1;
taCentered: Options := 2;
taRightJustified: Options := 3;
end;
// if Wrap then begin
// Options := Options + 8;
// end;
XFStr := XFStr + LotWord(Options);
XFStr := XFStr + LotWord(0); // Color & Fill
XFStr := XFStr + LotWord(0); // Frame
XFStr := XFStr + LotWord(0); // Frame Type
I := IndexOf(XFTbl, XFStr);
if I = -1 then begin
XFTbl.Add(XFStr);
I := XFTbl.Count - 1;
end;
Result := LotWord(I + 20); // 20 Standard + Custom
end;
procedure TXLSDevice.WriteFontTbl;
var
I: Integer;
begin
for I := 0 to FontTbl.Count - 1 do begin
Write(CHR($31) + CHR($02) + LotWord(Length(FontTbl[I])) + FontTbl[I]);
end;
end;
procedure TXLSDevice.WriteFormatTbl;
var
I: Integer;
begin
for I := 0 to FormatTbl.Count - 1 do begin
Write(CHR($1E) + CHR($00) + LotWord(1 + Length(FormatTbl[I])) + CHR(Length(FormatTbl[I])) + FormatTbl[I]);
end;
end;
procedure TXLSDevice.WriteXFT
Vou postar uma unit de um componente de um componente chamado ExtraDev, que um complemento do report builder, onde tenho a versão do mesmo para delphi 6 e que estou querendo instalá-lo no delphi 7, só que ocorre um erro ao instalá-lo, eis a unit:
unit TXtraDev;
{
TExtraDevices for Delphi
Written by James Waler
Copyright (c) 1998, 1999, 2000 by James Waler
All rights reserved
***************************************************************
THIS SOFTWARE IS PROVIDED ´AS IS´ WITHOUT WARRANTY OF ANY KIND,
EITHER EXPRESSED OR IMPLIED. THE USER ASSUMES THE ENTIRE RISK
OF ANY DAMAGE CAUSED BY THIS SOFTWARE.
IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR DAMAGE OF ANY
KIND, LOSS OF DATA, LOSS OF PROFITS, BUSINESS INTERRUPTION OR
OTHER PECUNIARY LOSS ARISING DIRECTLY OR INDIRECTLY.
1.
HTML - Added support for ulnone RTF
ALL - Fixed double lines
1.83
TIFF - Fixed pf1bit images
1.82 - 01/21/2001
TIFF - Fixed pf24bit images
TIFF - Made images 96 dpi
PDF - Corrected right-aligned text
PDF - Added fast compression option
1.81 - 11/28/2000
PDF - Improved right-aligned text
PDF - Added right-aligned memos
HTML - Fix for bottom line
1.8 - 11/15/2000
PDF - Right aligned single line labels work with all fonts
RTF - Added stripping of EOPs
ALL - Trim lines so that they do not hide other objects
PDF - Fixed lines joins
PDF - Fixed crosstab text
PDF - RichText over multiple pages
1.72 - 10/10/2000
Fixed checkbox in RTF
Added multiline support to RichText in PDF
Added EOP stripping for RB 5.1 FT
1.71 - 7/30/2000
Fixed barcode crop in all devices
1.7 - 5/10/2000
PDF - Checkbox support
PDF - Circle & Ellipse support
PDF - Line style support
PDF - ZLIB compression support for D5
Added barcode support to HTML, CSS2, RTF, PDF & Graphic
PDF - Improved memo rendering
PDF - Added support for Italics & Bold
XLS - First column center-aligned labels were fixed
Added component for device control
PDF - Fixed right-aligned label placement
Graphic - Added multipage TIF support
PDF - Added PlainText RichText support
PDF - Added support for non-transparent text
PDF - Added roundrect & roundsquare support
}
{$IFDEF VER130}
{$DEFINE USEZLIB}
{$ENDIF}
{$IFDEF VER140}
{$DEFINE USEZLIB}
{$ENDIF}
interface
uses
Classes, Windows, Graphics, ExtCtrls, SysUtils, Forms, Controls, ppFilDev, Math, RichEdit,
ppDevice, ppTypes, ppUtils, ppForms, ppDrwCmd, JPEG, Dialogs, Printers, ComCtrls, ppViewr,
TXTIFF, TXParse, ppRichTx{$IFDEF USEZLIB},ZLib{$ENDIF};
type
TReportItemType = (riIgnore, riText, riImage, riLine, riShape, riRTF, riBarCode, riCheckBox);
TImageCRC = class
FileName: String;
CRC: Cardinal;
end;
TReportBand = class(TList)
end;
TReportItem = class
ItemType: TReportItemType;
Row: Integer;
Top: Integer;
Left: Integer;
Height: Integer;
Width: Integer;
AdjLeft: Integer;
AdjHeight: Integer;
AdjWidth: Integer;
DrawCmd: TppDrawCommand;
ZOrder: Integer;
end;
{ TExtraDevice }
TExtraDevice = class(TppFileDevice)
private
Page: TppPage;
FRow: Integer;
FCol: Integer;
FPageNo: Integer;
FImageNo: Integer;
MemStream: TMemoryStream;
SeparateBands: Boolean;
ConvertFonts: Boolean;
ImageList: TList;
CRCTable: array[0..255] of Cardinal;
procedure GetDrawCommands(Page: TppPage; Cmds: TStringList);
procedure Write(Buffer: String); virtual;
procedure Stream(Buffer: String);
procedure SavePageToFile(Page: TppPage);
procedure CalcSize(Itm: TReportItem);
procedure DrawLine(B: TCanvas; Lne: TppDrawLine; Bounds: TRect);
procedure DrawShape(B: TCanvas; Shp: TppDrawShape; Bounds: TRect);
procedure DrawCheckBox(B: TBitmap; Txt: TppDrawText; Bounds: TRect; AdjBitmap: Boolean; IgnoreAttr: Boolean);
function ImageIndex(J: TObject; FileName: String): Integer;
function CRC(MS: TMemoryStream): Cardinal;
procedure InitCRCTable;
function WriteImage(B: TBitmap): String;
procedure DrawImage(B: TBitmap; Itm: TReportItem; Bounds: TRect; AdjBitmap, IgnoreAttr, AdjImage: Boolean);
procedure DrawRichText(B: TBitmap; DRT: TppDrawRichText; Bounds: TRect);
procedure DrawBarCode(B: TCanvas; Bar: TppDrawBarCode; Bounds: TRect);
function ConvertFont(FontName: String): String;
procedure CalcBarCodeSize(Itm: TReportItem);
protected
procedure ProcessBand(Band: TReportBand); virtual;
procedure StartBand; virtual;
procedure EndBand; virtual;
procedure StartPage; virtual;
procedure EndPage; virtual;
public
constructor Create(aOwner: TComponent); override;
destructor Destroy; override;
procedure EndJob; override;
procedure StartJob; override;
procedure ReceivePage(aPage: TppPage); override;
end;
{ TWK1Device }
TWK1Device = class(TExtraDevice)
public
procedure ProcessBand(Band: TReportBand); override;
procedure StartJob; override;
procedure EndJob; override;
class function DeviceName: String; override;
class function DefaultExt: String; override;
class function DefaultExtFilter: String; override;
class function DeviceDescription(aLanguageIndex: Longint): String; override;
end;
{ TWQ1Device }
TWQ1Device = class(TExtraDevice)
public
procedure StartJob; override;
procedure EndJob; override;
procedure ProcessBand(Band: TReportBand); override;
class function DeviceName: String; override;
class function DefaultExt: String; override;
class function DefaultExtFilter: String; override;
class function DeviceDescription(aLanguageIndex: Longint): String; override;
end;
{ TXLSDevice }
TXLSDevice = class(TExtraDevice)
FontTbl: TStringList;
FormatTbl: TStringList;
XFTbl: TStringList;
private
procedure WriteFontTbl;
procedure WriteFormatTbl;
procedure WriteXFTbl;
function FontIndex(Font: TFont): String;
function FormatIndex(Format: String): String;
function XFIndex(Txt: TppDrawText; Numeric: Boolean): String;
public
procedure StartJob; override;
procedure EndJob; override;
procedure ProcessBand(Band: TReportBand); override;
class function DeviceName: String; override;
class function DefaultExt: String; override;
class function DefaultExtFilter: String; override;
class function DeviceDescription(aLanguageIndex: Longint): String; override;
end;
{ TGraphicDevice }
TGraphicDevice = class(TExtraDevice)
private
Img: TBitmap;
Tif: TTIFImage;
Ext: String;
protected
procedure StartPage; override;
procedure EndPage; override;
procedure ProcessBand(Band: TReportBand); override;
public
procedure StartJob; override;
procedure EndJob; override;
class function DeviceName: String; override;
class function DefaultExt: String; override;
class function DefaultExtFilter: String; override;
class function DeviceDescription(aLanguageIndex: Longint): String; override;
end;
{ THTMLDevice }
THTMLDevice = class(TExtraDevice)
private
DestStream: TFileStream;
BaseFont: String;
BaseSize: Integer;
BandWidth: Integer;
TopOffset: Integer;
TotWidth: Integer;
protected
procedure StartBand; override;
procedure EndBand; override;
procedure StartPage; override;
procedure EndPage; override;
procedure Write(Buffer: String); override;
procedure ProcessBand(Band: TReportBand); override;
public
procedure StartJob; override;
procedure EndJob; override;
class function DeviceName: String; override;
class function DefaultExt: String; override;
class function DefaultExtFilter: String; override;
class function DeviceDescription(aLanguageIndex: Longint): String; override;
end;
{ TCSS2Device }
TCSS2Device = class(TExtraDevice)
private
DestStream: TFileStream;
protected
procedure StartBand; override;
procedure EndBand; override;
procedure StartPage; override;
procedure EndPage; override;
procedure Write(Buffer: String); override;
procedure ProcessBand(Band: TReportBand); override;
public
procedure StartJob; override;
procedure EndJob; override;
class function DeviceName: String; override;
class function DefaultExt: String; override;
class function DefaultExtFilter: String; override;
class function DeviceDescription(aLanguageIndex: Longint): String; override;
end;
{ TRTFDevice }
TRTFDevice = class(TExtraDevice)
private
BaseFont: String;
BaseSize: Integer;
TopOffset: Integer;
TopMargin: Integer;
BottomMargin: Integer;
LeftMargin: Integer;
RightMargin: Integer;
FontTbl: TStringList;
ColorTbl: TStringList;
protected
procedure StartBand; override;
procedure EndBand; override;
procedure StartPage; override;
procedure EndPage; override;
procedure ProcessBand(Band: TReportBand); override;
procedure WriteFontTbl;
procedure WriteColorTbl;
function FontIndex(Font: String): String;
function ColorIndex(Color: TColor): String;
public
procedure StartJob; override;
procedure EndJob; override;
class function DeviceName: String; override;
class function DefaultExt: String; override;
class function DefaultExtFilter: String; override;
class function DeviceDescription(aLanguageIndex: Longint): String; override;
end;
{ TPDFDevice }
TPDFDevice = class(TExtraDevice)
private
FontTbl: TStringList;
FontObj: TStringList;
FontNme: TStringList;
CrossRef: TStringList;
ObjNo: Integer;
RootObj: Integer;
BodyObj: String;
ProcObj: String;
MaxKids: Integer;
AnyImages: Boolean;
InStream: Boolean;
InImage: Boolean;
StreamObj: String;
PageList: TStringList;
TotPages: Integer;
StreamSize: Integer;
PageHeight: Integer;
PageWidth: Integer;
FilePos: Integer;
XRefPos: Integer;
procedure AddRef(Obj: String);
procedure WriteCrossRef;
function ImageObject(Itm: TReportItem): String;
procedure WriteBMP(ImgObj: String; B: TBitmap; Mask: Boolean);
procedure ASCII85(Source, Target: TStream);
procedure EndStream;
procedure StartStream;
{$IFNDEF USEZLIB}
procedure RunLength(Source, Target: TStream);
{$ENDIF}
function ArcTo(X1, Y1, X2, Y2, XRadius, YRadius: Extended): String;
procedure RoundRect(Left, Top, Width, Height, XRad, YRad: Extended);
function TextWidth(Txt: TppDrawText; Value: String): Extended;
function ComputeStringWidth(Wth: array of Word; Txt: TppDrawText; Value: String): Extended;
protected
procedure StartBand; override;
procedure EndBand; override;
procedure StartPage; override;
procedure EndPage; override;
procedure ProcessBand(Band: TReportBand); override;
procedure WriteFontTbl;
function FontIndex(Font: TFont): Integer;
procedure Write(Buffer: String); override;
function NextObj: String;
function ParentObj(PageNo: Integer): String;
function FontFamily(Font: TFont): String;
public
procedure StartJob; override;
procedure EndJob; override;
class function DeviceName: String; override;
class function DefaultExt: String; override;
class function DefaultExtFilter: String; override;
class function DeviceDescription(aLanguageIndex: Longint): String; override;
end;
{ TExtraDeviceOptions }
TExtraDeviceOptions = class
private
FVisible: Boolean;
procedure SetVisible(Value: Boolean); virtual;
function GetVisible: Boolean;
public
constructor Create;
property Visible: Boolean read GetVisible write SetVisible;
end;
THTMLDeviceOptions = class(TExtraDeviceOptions)
private
FPixelFormat: TPixelFormat;
FBackLink: String;
FForwardLink: String;
FUseTextFile: Boolean;
FZoomableImages: Boolean;
FShowLinks: Boolean;
procedure SetVisible(Value: Boolean); override;
public
constructor Create;
destructor Destroy; override;
property BackLink: String read FBackLink write FBackLink;
property ForwardLink: String read FForwardLink write FForwardLink;
property ShowLinks: Boolean read FShowLinks write FShowLinks;
property UseTextFileName: Boolean read FUseTextFile write FUseTextFile;
property ZoomableImages: Boolean read FZoomableImages write FZoomableImages;
property PixelFormat: TPixelFormat read FPixelFormat write FPixelFormat;
end;
TCSS2DeviceOptions = class(TExtraDeviceOptions)
private
FPixelFormat: TPixelFormat;
FBackLink: String;
FForwardLink: String;
FUseTextFile: Boolean;
FZoomableImages: Boolean;
FShowLinks: Boolean;
procedure SetVisible(Value: Boolean); override;
public
constructor Create;
destructor Destroy; override;
property BackLink: String read FBackLink write FBackLink;
property ForwardLink: String read FForwardLink write FForwardLink;
property ShowLinks: Boolean read FShowLinks write FShowLinks;
property UseTextFileName: Boolean read FUseTextFile write FUseTextFile;
property ZoomableImages: Boolean read FZoomableImages write FZoomableImages;
property PixelFormat: TPixelFormat read FPixelFormat write FPixelFormat;
end;
TRTFDeviceOptions = class(TExtraDeviceOptions)
procedure SetVisible(Value: Boolean); override;
end;
TWK1DeviceOptions = class(TExtraDeviceOptions)
procedure SetVisible(Value: Boolean); override;
end;
TWQ1DeviceOptions = class(TExtraDeviceOptions)
procedure SetVisible(Value: Boolean); override;
end;
TXLSDeviceOptions = class(TExtraDeviceOptions)
procedure SetVisible(Value: Boolean); override;
end;
TPDFDeviceOptions = class(TExtraDeviceOptions)
private
FCreator: String;
FTitle: String;
FAuthor: String;
FKeywords: String;
FSubject: String;
FFastCompression: Boolean;
FCompressImages: Boolean;
FCompressStreams: Boolean;
FScaleImages: Boolean;
FShrinkMemos: Boolean;
FPixelFormat: TPixelFormat;
procedure SetVisible(Value: Boolean); override;
public
constructor Create;
property Creator: String read FCreator write FCreator;
property Title: String read FTitle write FTitle;
property Author: String read FAuthor write FAuthor;
property Keywords: String read FKeywords write FKeywords;
property Subject: String read FSubject write FSubject;
property FastCompression: Boolean read FFastCompression write FFastCompression;
property ShrinkMemos: Boolean read FShrinkMemos write FShrinkMemos;
property CompressImages: Boolean read FCompressImages write FCompressImages;
property CompressStreams: Boolean read FCompressStreams write FCompressStreams;
property ScaleImages: Boolean read FScaleImages write FScaleImages;
property PixelFormat: TPixelFormat read FPixelFormat write FPixelFormat;
end;
TGraphicDeviceOptions = class(TExtraDeviceOptions)
private
FPixelFormat: TPixelFormat;
FUseTextFile: Boolean;
FPixelsPerInch: Integer;
private
procedure SetVisible(Value: Boolean); override;
public
constructor Create;
destructor Destroy; override;
property PixelFormat: TPixelFormat read FPixelFormat write FPixelFormat;
property UseTextFileName: Boolean read FUseTextFile write FUseTextFile;
property PixelsPerInch: Integer read FPixelsPerInch write FPixelsPerInch;
end;
TExtraOptions = class
FHTML: THTMLDeviceOptions;
FCSS2: TCSS2DeviceOptions;
FRTF: TRTFDeviceOptions;
FLotus: TWK1DeviceOptions;
FQuattro: TWQ1DeviceOptions;
FExcel: TXLSDeviceOptions;
FGraphic: TGraphicDeviceOptions;
FPDF: TPDFDeviceOptions;
public
constructor Create;
destructor Destroy; override;
property HTML: THTMLDeviceOptions read FHTML write FHTML;
property CSS2: TCSS2DeviceOptions read FCSS2 write FCSS2;
property RTF: TRTFDeviceOptions read FRTF write FRTF;
property Lotus: TWK1DeviceOptions read FLotus write FLotus;
property Quattro: TWQ1DeviceOptions read FQuattro write FQuattro;
property Excel: TXLSDeviceOptions read FExcel write FExcel;
property Graphic: TGraphicDeviceOptions read FGraphic write FGraphic;
property PDF: TPDFDeviceOptions read FPDF write FPDF;
end;
function ExtraDevices: TExtraOptions;
implementation
const
CRLF = #13 + 10;
EOP = 36 + 182;
HelvNorm: array[0..254] of Word = (0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,278,278,355,556,556,889,667,222,333,333,389,584,
278,333,278,278,556,556,556,556,556,556,556,556,556,556,278,278,584,584,584,556,1015,667,667,722,722,667,611,778,
722,278,500,667,556,833,722,778,667,778,722,667,611,722,667,944,667,667,611,278,278,278,469,556,222,556,556,500,556,
556,278,556,556,222,222,500,222,833,556,556,556,556,333,500,278,556,500,722,500,500,500,334,260,334,584,0,0,0,0,0,0,
0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,333,556,556,167,556,556,556,556,191,333,556,333,333,500,500,0,556,
556,556,278,0,537,350,222,333,333,556,1000,1000,0,611,0,333,333,333,333,333,333,333,333,0,333,333,0,333,333,333,1000,0,0,0,0,0,0,
0,0,0,0,0,0,0,0,0,0,1000,0,370,0,0,0,0,556,778,1000,365,0,0,0,0,0,889,0,0,0,278,0,0,222,611,944,611,0,0,0);
HelvBold: array[0..254] of Word = (0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,278,333,474,556,556,889,722,278,333,333,389,584,278,333,
278,278,556,556,556,556,556,556,556,556,556,556,333,333,584,584,584,611,975,722,722,722,722,667,611,778,722,278,556,722,611,833,722,778,
667,778,722,667,611,722,667,944,667,667,611,333,278,333,584,556,278,556,611,556,611,556,333,611,611,278,278,556,278,889,611,611,611,611,389,556,
333,611,556,778,556,556,500,389,280,389,584,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,333,556,556,167,556,556,556,556,
238,500,556,333,333,611,611,0,556,556,556,278,0,556,350,278,500,500,556,1000,1000,0,611,0,333,333,333,333,333,333,333,333,0,333,333,0,333,333,333,
1000,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1000,0,370,0,0,0,0,611,778,1000,365,0,0,0,0,0,889,0,0,0,278,0,0,278,611,944,611,0,0,0);
HelvBldI: array[0..254] of Word = (0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,278,333,474,556,556,889,722,278,333,333,389,584,278,
333,278,278,556,556,556,556,556,556,556,556,556,556,333,333,584,584,584,611,975,722,722,722,722,667,611,778,722,278,556,722,611,833,722,778,667,778,722,
667,611,722,667,944,667,667,611,333,278,333,584,556,278,556,611,556,611,556,333,611,611,278,278,556,278,889,611,611,611,611,389,556,333,611,556,778,556,
556,500,389,280,389,584,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,333,556,556,167,556,556,556,556,238,500,556,333,333,611,611,
0,556,556,556,278,0,556,350,278,500,500,556,1000,1000,0,611,0,333,333,333,333,333,333,333,333,0,333,333,0,333,333,333,1000,0,0,0,0,0,0,0,0,0,0,0,0,0,
0,0,0,1000,0,370,0,0,0,0,611,778,1000,365,0,0,0,0,0,889,0,0,0,278,0,0,278,611,944,611,0,0,0);
HelvItal: array[0..254] of Word = (0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,278,278,355,556,556,889,667,222,333,333,389,584,278,333,
278,278,556,556,556,556,556,556,556,556,556,556,278,278,584,584,584,556,1015,667,667,722,722,667,611,778,722,278,500,667,556,833,722,778,667,778,
722,667,611,722,667,944,667,667,611,278,278,278,469,556,222,556,556,500,556,556,278,556,556,222,222,500,222,833,556,556,556,556,333,500,278,556,500,722,
500,500,500,334,260,334,584,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,333,556,556,167,556,556,556,556,191,333,556,333,333,500,
500,0,556,556,556,278,0,537,350,222,333,333,556,1000,1000,0,611,0,333,333,333,333,333,333,333,333,0,333,333,0,333,333,333,1000,0,0,0,0,0,0,0,0,0,0,0,0,
0,0,0,0,1000,0,370,0,0,0,0,556,778,1000,365,0,0,0,0,0,889,0,0,0,278,0,0,222,611,944,611,0,0,0);
TimeBold: array[0..254] of Word = (0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,250,333,555,500,500,1000,833,333,333,333,500,570,250,333,
250,278,500,500,500,500,500,500,500,500,500,500,333,333,570,570,570,500,930,722,667,722,722,667,611,778,778,389,500,778,667,944,722,778,611,778,722,556,
667,722,722,1000,722,722,667,333,278,333,581,500,333,500,556,444,556,444,333,500,556,278,333,556,278,833,556,500,556,556,444,389,333,556,500,722,500,500,
444,394,220,394,520,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,333,500,500,167,500,500,500,500,278,500,500,333,333,556,556,0,500,
500,500,250,0,540,350,333,500,500,500,1000,1000,0,500,0,333,333,333,333,333,333,333,333,0,333,333,0,333,333,333,1000,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
1000,0,300,0,0,0,0,667,778,1000,330,0,0,0,0,0,722,0,0,0,278,0,0,278,500,722,556,0,0,0);
TimeBldI: array[0..254] of Word = (0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,250,389,555,500,500,833,778,333,333,333,500,570,250,333,
250,278,500,500,500,500,500,500,500,500,500,500,333,333,570,570,570,500,832,667,667,667,722,667,667,722,778,389,500,667,611,889,722,722,611,722,667,556,
611,722,667,889,667,611,611,333,278,333,570,500,333,500,500,444,500,444,333,500,556,278,278,500,278,778,556,500,500,500,389,389,278,556,444,667,500,444,
389,348,220,348,570,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,389,500,500,167,500,500,500,500,278,500,500,333,333,556,556,0,
500,500,500,250,0,500,350,333,500,500,500,1000,1000,0,500,0,333,333,333,333,333,333,333,333,0,333,333,0,333,333,333,1000,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
0,944,0,266,0,0,0,0,611,722,944,300,0,0,0,0,0,722,0,0,0,278,0,0,278,500,722,500,0,0,0);
TimeItal: array[0..254] of Word = (0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,250,333,420,500,500,833,778,333,333,333,500,675,250,
333,250,278,500,500,500,500,500,500,500,500,500,500,333,333,675,675,675,500,920,611,611,667,722,611,611,722,722,333,444,667,556,833,667,722,611,722,611,
500,556,722,611,833,611,556,556,389,278,389,422,500,333,500,500,444,500,444,278,500,500,278,278,444,278,722,500,500,500,500,389,389,278,500,444,667,444,
444,389,400,275,400,541,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,389,500,500,167,500,500,500,500,214,556,500,333,333,500,500,
0,500,500,500,250,0,523,350,333,556,556,500,889,1000,0,500,0,333,333,333,333,333,333,333,333,0,333,333,0,333,333,333,889,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
889,0,276,0,0,0,0,556,722,944,310,0,0,0,0,0,667,0,0,0,278,0,0,278,500,667,500,0,0,0);
TimeNorm: array[0..254] of Word = (0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,250,333,408,500,500,833,778,333,333,333,500,564,250,333,
250,278,500,500,500,500,500,500,500,500,500,500,278,278,564,564,564,444,921,722,667,667,722,611,556,722,722,333,389,722,611,889,722,722,556,722,667,556,
611,722,722,944,722,722,611,333,278,333,469,500,333,444,500,444,500,444,333,500,500,278,278,500,278,778,500,500,500,500,333,389,278,500,500,722,500,500,
444,480,200,480,541,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,333,500,500,167,500,500,500,500,180,444,500,333,333,556,556,0,500,
500,500,250,0,453,350,333,444,444,500,1000,1000,0,444,0,333,333,333,333,333,333,333,333,0,333,333,0,333,333,333,1000,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,889,
0,276,0,0,0,0,611,722,889,310,0,0,0,0,0,667,0,0,0,278,0,0,278,500,722,500,0,0,0);
DingNorm: array[0..254] of Word = (0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,278,974,961,974,980,719,789,790,791,690,960,939,549,
855,911,933,911,945,974,755,846,762,761,571,677,763,760,759,754,494,552,537,577,692,786,788,788,790,793,794,816,823,789,841,823,833,816,831,923,744,723,
749,790,792,695,776,768,792,759,707,708,682,701,826,815,789,789,707,687,696,689,786,787,713,791,785,791,873,761,762,762,759,759,892,892,788,784,438,138,
277,415,392,392,668,668,0,390,390,317,317,276,276,509,509,410,410,234,234,334,334,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,732,544,544,910,667,760,760,
776,595,694,626,788,788,788,788,788,788,788,788,788,788,788,788,788,788,788,788,788,788,788,788,788,788,788,788,788,788,788,788,788,788,788,788,788,788,
788,788,788,788,788,788,894,838,1016,458,748,924,748,918,927,928,928,834,873,828,924,924,917,930,931,463,883,836,836,867,867,696,696,874,0,874,760,946,
771,865,771,888,967,888,831,873,927,970,918);
var FOptions: TExtraOptions = Nil;
function Replace(cString, cSearch, cReplace: String): String;
var
nSize, nPos, I, nOrig, nNext: Integer;
begin
I := 0;
nPos := 0;
nSize := Length(cReplace) - Length(cSearch);
nOrig := Length(cString);
Result := cString;
nNext := Pos(cSearch, cString);
while nNext > 0 do begin
nPos := nPos + nNext;
Delete(Result, nPos + (I * nSize), Length(cSearch));
Insert(cReplace, Result, nPos + (I * nSize));
Inc(I);
nNext := Pos(cSearch, Copy(cString, nPos + 1, nOrig - nPos));
end;
end;
function IndexOf(SL: TStringList; Value: String): Integer;
var
I: Integer;
begin
Result := -1;
for I := 0 to SL.Count - 1 do begin
if SL[I] = Value then begin
Result := I;
Break;
end;
end;
end;
function MaxInt(I1, I2: Integer): Integer;
begin
if I1 > I2 then begin
Result := I1;
end else begin
Result := I2;
end;
end;
function LotWord(Value: Integer): String;
begin
Result := CHR(Value mod 256) + CHR(Trunc(Value div 256));
end;
type
IEEES = array[1..8] of byte;
function FloatToIEEE(Value: Double): String;
var
T: IEEES;
I: Integer;
begin
T := IEEES(Value);
Result := ´´;
for I := 1 to 8 do begin
Result := Result + Char(T[I]);
end;
end;
function TextToFloat(Value: String): Double;
var
I: Integer;
T: String;
begin
T := ´´;
for I := 1 to Length(Value) do begin
if Value[I] in [´0´..´9´, DecimalSeparator, ´-´, ´E´] then begin
T := T + Value[I];
end;
end;
try
Result := StrToFloat(T);
except
Result := 0;
end;
end;
function TextToIEEE(Value: String): String;
begin
Result := FloatToIEEE(TextToFloat(Value));
end;
function IncFile(FileName: String; Value: Integer; AddPath: Boolean): String;
var
Base, Ext: String;
begin
Ext := ExtractFileExt(FileName);
Base := ExtractFileName(FileName);
Base := Copy(Base, 1, Length(Base) - Length(Ext));
if AddPath then begin
Result := ExtractFilePath(FileName) + Base + FormatFloat(´0000´, Value) + Ext;
end else begin
Result := Base + FormatFloat(´0000´, Value) + Ext;
end;
end;
function ThousandthsToTwips(Value: Integer): Integer;
begin
Result := Trunc((Value / 1000) * 0.0393701 * 1440);
end;
function ThousandthsToPoints(Value: Integer): Integer;
begin
Result := Round((Value / 1000) * 0.0393701 * 72);
end;
function EThousandthsToPoints(Value: Integer): Extended;
begin
Result := (Value / 1000) * 0.0393701 * 72;
end;
function PixelsToTwips(Value: Extended): Integer;
begin
Result := Trunc((Value * (1 / 96)) * 1440);
end;
function PixelsToPoints(Value: Extended): Integer;
begin
Result := Trunc((Value * (1 / 96)) * 72);
end;
function PointsToPixels(Value: Extended): Integer;
begin
Result := Trunc((Value * (1 / 72)) * 96);
end;
function VertPixelsToThousandths(Value: Integer): Integer;
begin
Result := Round(ppFromScreenPixels(Value, utMMThousandths, pprtVertical, Nil));
end;
function HorzPixelsToThousandths(Value: Integer): Integer;
begin
Result := Round(ppFromScreenPixels(Value, utMMThousandths, pprtHorizontal, Nil));
end;
function ThousandthsToHorzPixels(Value, PixelsPerInch: Integer): Integer;
begin
Value := Trunc(Value * (PixelsPerInch / Screen.PixelsPerInch));
Result := ppToScreenPixels(Value, utMMThousandths, pprtHorizontal, Nil);
end;
function ThousandthsToVertPixels(Value, PixelsPerInch: Integer): Integer;
begin
Value := Trunc(Value * (PixelsPerInch / Screen.PixelsPerInch));
Result := ppToScreenPixels(Value, utMMThousandths, pprtVertical, Nil);
end;
procedure ClearBitmap(B: TBitmap);
begin
B.Canvas.Brush.Color := clWhite;
B.Canvas.FillRect(Rect(0, 0, B.Width, B.Height));
end;
function RTFToString(RTF: TppDrawRichText): String;
var
Buffer: String;
begin
if RTF.StartCharPos = 0 then begin
RTF.RichTextStream.Position := 0;
SetLength(Buffer, RTF.RichTextStream.Size);
RTF.RichTextStream.Read(Buffer[1], RTF.RichTextStream.Size);
if Copy(Buffer, Length(Buffer) - 2, 2) = #13 + 10 then begin
Buffer := Copy(Buffer, 1, Length(Buffer) - 2);
end;
Result := Trim(Buffer);
end else begin
Result := ´´;
end;
end;
function RTFToPlainString(RTF: TppDrawRichText): String;
var
RE: TRichEdit;
N: Integer;
begin
RE := TRichEdit.Create(Nil);
RE.Parent := ppParentWnd;
RTF.RichTextStream.Position := 0;
RE.Width := ThousandthsToHorzPixels(RTF.Width, Screen.PixelsPerInch);
RE.Lines.LoadFromStream(RTF.RichTextStream);
RE.SelStart := 0;
RE.SelLength := RTF.StartCharPos;
RE.ClearSelection;
RE.SelectAll;
N := RE.SelLength;
RE.SelStart := RTF.EndCharPos + 1;
RE.SelLength := N;
RE.ClearSelection;
Result := RE.Lines.Text;
RE.Free;
end;
function ColorToHex(Value: TColor): String;
var
Color: Integer;
begin
Color := ColorToRGB(Value);
Result := ´#´ + IntToHex(GetRValue(Color), 2) + IntToHex(GetGValue(Color), 2) + IntToHex(GetBValue(Color), 2)
end;
function ColorToStr(Value: TColor): String;
var
Color: Integer;
begin
Color := ColorToRGB(Value);
Result := FormatFloat(´000´, GetRValue(Color)) + FormatFloat(´000´, GetGValue(Color)) + FormatFloat(´000´, GetBValue(Color));
end;
function ColorToPDF(Value: TColor): String;
var
Color: Integer;
begin
Color := ColorToRGB(Value);
Result := FormatFloat(´0.000´, GetRValue(Color) / 255) + ´ ´ + FormatFloat(´0.000´, GetGValue(Color) / 255) + ´ ´ + FormatFloat(´0.000´, GetBValue(Color) / 255);
Result := Replace(Result, DecimalSeparator, ´.´);
end;
function FmtFloat(Value: Extended): String;
begin
// Result := FloatToStr(Value);
Result := FormatFloat(´#0.0´, Value);
Result := Replace(Result, DecimalSeparator, ´.´);
end;
function ZOrderSort(Item1, Item2: Pointer): Integer;
begin
Result := 0;
if TReportItem(Item1).ZOrder > TReportItem(Item2).ZOrder then begin
Result := 1;
end;
if TReportItem(Item1).ZOrder < TReportItem(Item2).ZOrder then begin
Result := -1;
end;
if TReportItem(Item1).ZOrder = TReportItem(Item2).ZOrder then begin
Result := 0;
end;
end;
function TextHeight(Font: TFont): Integer;
var
DC: HDC;
TM: TTextMetric;
SaveFont: HFont;
begin
DC := GetDC(0);
SaveFont := SelectObject(DC, Font.Handle);
GetTextMetrics(DC, TM);
Result := TM.tmAscent + TM.tmDescent + TM.tmExternalLeading;
SelectObject(DC, SaveFont);
ReleaseDC(0, DC);
Result := PixelsToPoints(Result);
end;
function Occurs(Value, Sub: String): Integer;
var
I: Integer;
begin
Result := 0;
for I := 1 to Length(Value) do begin
if Value[I] = Sub then begin
Result := Result + 1;
end;
end;
end;
function HTMLEncode(Txt: String): String;
var
I, N: Integer;
begin
Result := Txt;
Result := Replace(Result, ´&´, ´&´);
Result := Replace(Result, ´<´, ´<´);
Result := Replace(Result, ´>´, ´>´);
Result := Replace(Result, ´´´, ´"´);
Result := Replace(Result, ´ä´, ´ä´);
Result := Replace(Result, ´Ä´, ´Ä´);
Result := Replace(Result, ´ö´, ´&oml;´);
Result := Replace(Result, ´Ö´, ´&Oml;´);
Result := Replace(Result, ´ü´, ´ü´);
Result := Replace(Result, ´Ü´, ´Ü´);
N := Length(Result) - Length(TrimLeft(Result));
Result := TrimLeft(Result);
for I := 1 to N do begin
Result := ´ ´ + Result;
end;
end;
function BuildFont(Face: String; Col: TColor; Size: Integer): String;
begin
Result := ´´;
Result := Result + ´<FONT´;
Result := Result + ´ STYLE=´ + CHR(34);
Result := Result + ´ font-family: ´ + Face + ´;´;
Result := Result + ´ color: ´ + ColorToHex(Col) + ´;´;
Result := Result + ´ font-size: ´ + IntToStr(Size) + ´pt;´;
Result := Result + CHR(34) + ´>´;
end;
function RTF2HTML(RTFCmd: TppDrawRichText): String;
var
BoldOn, UndOn, ItalicOn, FontOn: Boolean;
RTF: TRTFParser;
FontSize: Integer;
FontFace: String;
FontColor: TColor;
begin
BoldOn := False;
UndOn := False;
ItalicOn := False;
FontOn := False;
FontSize := 10;
FontColor := clBlack;
FontFace := ´Arial´;
Result := ´<DIV>´;
RTFCmd.RichTextStream.Position := 0;
RTF := TRTFParser.Create(RTFCmd.RichTextStream);
while RTF.Token <> rtEOF do begin
case RTF.Token of
rtText: begin
if BoldOn then begin
Result := Result + ´´;
end;
if UndOn then begin
Result := Result + ´´;
end;
if ItalicOn then begin
Result := Result + ´´;
end;
Result := Result + HTMLEncode(RTF.TokenString);
if ItalicOn then begin
Result := Result + ´´;
end;
if UndOn then begin
Result := Result + ´´;
end;
if BoldOn then begin
Result := Result + ´´;
end;
end;
rtControl: begin
if RTF.TokenString = ´tab´ then begin
Result := Result + HTMLEncode(StringOfChar(´ ´, 9));
end;
if RTF.TokenString = ´par´ then begin
Result := Result + ´
´ + CRLF;
end;
if RTF.TokenString = ´pard´ then begin
Result := Result + ´</DIV>´;
Result := Result + ´<DIV ALIGN=LEFT ´ + Copy(BuildFont(FontFace, FontColor, FontSize), 6, 100);
end;
if RTF.TokenString = ´ql´ then begin
Result := Result + ´</DIV>´;
Result := Result + ´<DIV ALIGN=LEFT ´ + Copy(BuildFont(FontFace, FontColor, FontSize), 6, 100);
end;
if RTF.TokenString = ´qr´ then begin
Result := Result + ´</DIV>´;
Result := Result + ´<DIV ALIGN=RIGHT ´ + Copy(BuildFont(FontFace, FontColor, FontSize), 6, 100);
end;
if RTF.TokenString = ´qc´ then begin
Result := Result + ´</DIV>´;
Result := Result + ´<DIV ALIGN=CENTER ´ + Copy(BuildFont(FontFace, FontColor, FontSize), 6, 100);
end;
if RTF.TokenString = ´f´ then begin
if FontOn then begin
Result := Result + ´´;
end;
FontOn := True;
FontFace := RTF.Font[RTF.TokenValue];
Result := Result + BuildFont(FontFace, FontColor, FontSize);
end;
if RTF.TokenString = ´cf´ then begin
if FontOn then begin
Result := Result + ´´;
end;
FontOn := True;
FontColor := RTF.Color[RTF.TokenValue];
Result := Result + BuildFont(FontFace, FontColor, FontSize);
end;
if RTF.TokenString = ´fs´ then begin
if FontOn then begin
Result := Result + ´´;
end;
FontOn := True;
FontSize := RTF.TokenValue div 2;
Result := Result + BuildFont(FontFace, FontColor, FontSize);
end;
if RTF.TokenString = ´b´ then begin
if BoldOn and RTF.HasTokenValue and (RTF.TokenValue = 0) then begin
BoldOn := False;
end else begin
BoldOn := True;
end;
end;
if RTF.TokenString = ´ul´ then begin
if UndOn and RTF.HasTokenValue and (RTF.TokenValue = 0) then begin
UndOn := False;
end else begin
UndOn := True;
end;
end;
if RTF.TokenString = ´ulnone´ then begin
UndOn := False;
end;
if RTF.TokenString = ´i´ then begin
if ItalicOn and RTF.HasTokenValue and (RTF.TokenValue = 0) then begin
ItalicOn := False;
end else begin
ItalicOn := True;
end;
end;
if RTF.TokenString = ´plain´ then begin
BoldOn := False;
UndOn := False;
ItalicOn := False;
if FontOn then begin
FontOn := False;
Result := Result + ´´;
end;
end;
end;
end;
RTF.NextToken;
end;
RTF.Free;
if FontOn then begin
Result := Result + ´´;
end;
Result := Result + ´</DIV>´;
end;
{ TExtraDevice }
constructor TExtraDevice.Create(aOwner: TComponent);
begin
inherited;
end;
destructor TExtraDevice.Destroy;
begin
inherited;
end;
procedure TExtraDevice.StartJob;
begin
inherited;
MemStream := TMemoryStream.Create;
SeparateBands := True;
ConvertFonts := False;
InitCRCTable;
ImageList := TList.Create;
FRow := 0;
FCol := 0;
FPageNo := 0;
FImageNo := 0;
end;
procedure TExtraDevice.EndJob;
var
I: Integer;
begin
MemStream.Free;
for I := 0 to ImageList.Count - 1 do begin
TImageCRC(ImageList[I]).Free;
end;
ImageList.Free;
inherited;
end;
procedure TExtraDevice.StartPage;
begin
Inc(FPageNo);
end;
procedure TExtraDevice.EndPage;
begin
end;
procedure TExtraDevice.StartBand;
begin
FCol := 0;
end;
procedure TExtraDevice.EndBand;
begin
Inc(FRow);
end;
procedure TExtraDevice.ProcessBand(Band: TReportBand);
begin
end;
procedure TExtraDevice.ReceivePage(aPage: TppPage);
begin
inherited;
Page := aPage;
{$IFDEF EXTRADEMO}
if FPageNo > 0 then begin
Exit;
end;
{$ENDIF}
if IsRequestedPage then begin
DisplayMessage(aPage);
if not IsMessagePage then begin
SavePageToFile(aPage);
end;
end;
end;
procedure TExtraDevice.Write(Buffer: String);
begin
if Length(Buffer) > 0 then begin
FileStream.Write(Buffer[1], Length(Buffer));
end;
end;
procedure TExtraDevice.Stream(Buffer: String);
begin
if Length(Buffer) > 0 then begin
MemStream.Write(Buffer[1], Length(Buffer));
end;
end;
procedure TExtraDevice.GetDrawCommands(Page: TppPage; Cmds: TStringList);
var
I, N, W, X, Y, Row, LastTop: Integer;
DrawCmd: TppDrawCommand;
Order: String;
Itm: TReportItem;
Txt: TppDrawText;
begin
N := Page.DrawCommandCount;
for I := 0 to N - 1 do begin
DrawCmd := Page.DrawCommands[I];
Order := ´´;
Itm := TReportItem.Create;
Itm.ItemType := riIgnore;
Itm.DrawCmd := DrawCmd;
Itm.Top := DrawCmd.Top;
Itm.Left := DrawCmd.Left;
Itm.Width := DrawCmd.Width;
Itm.Height := DrawCmd.Height;
Itm.ZOrder := I;
if DrawCmd is TppDrawLine then begin
if TppDrawLine(DrawCmd).Pen.Style <> psClear then begin
Itm.ItemType := riLine;
if TppDrawLine(DrawCmd).LineStyle = lsSingle then begin
X := 1;
end else begin
X := 3;
end;
if TppDrawLine(DrawCmd).Pen.Width = 0 then begin
W := VertPixelsToThousandths(1);
end else begin
W := VertPixelsToThousandths(Trunc(TppDrawLine(DrawCmd).Pen.Width));
end;
case TppDrawLine(DrawCmd).LinePosition of
lpTop: begin
Itm.Height := X * (W + 3);
end;
lpBottom: begin
Y := X * (W + 3);
Itm.Top := Itm.Top + Itm.Height - Y;
Itm.Height := Y;
end;
lpLeft: begin
Itm.Width := X * (W + 3);
end;
lpRight: begin
Y := X * (W + 3);
Itm.Left := Itm.Left + Itm.Width - Y;
Itm.Width := Y;
Itm.AdjWidth := Itm.Width;
end;
end;
end;
end;
if DrawCmd is TppDrawText then begin
Txt := TppDrawText(Itm.DrawCmd);
Itm.ItemType := riText;
if (UpperCase(Txt.Font.Name) = ´WINGDINGS´) and (Length(Txt.Text) = 1) then begin
if (Txt.Text[1] in [#168, 254, 252, 251, 253]) then begin
Itm.ItemType := riCheckBox;
end;
end;
TppDrawText(Itm.DrawCmd).Font.Size := Abs(TppDrawText(Itm.DrawCmd).Font.Size);
if ConvertFonts then begin
TppDrawText(Itm.DrawCmd).Font.Name := ConvertFont(TppDrawText(Itm.DrawCmd).Font.Name);
end;
end;
if DrawCmd is TppDrawRichText then begin
Itm.ItemType := riRTF;
end;
if DrawCmd is TppDrawImage then begin
if TppDrawImage(DrawCmd).Picture.Width <> 0 then begin
Itm.ItemType := riImage;
end;
end;
if DrawCmd is TppDrawShape then begin
if (TppDrawShape(DrawCmd).Pen.Style <> psClear) or (TppDrawShape(DrawCmd).Brush.Style <> bsClear) then begin
Itm.ItemType := riShape;
end;
end;
if DrawCmd is TppDrawBarCode then begin
if TppDrawBarCode(DrawCmd).Data <> ´´ then begin
CalcBarCodeSize(Itm);
Itm.ItemType := riBarCode;
end;
end;
CalcSize(Itm);
Order := FormatFloat(´00000000´, Itm.Top) + FormatFloat(´00000000´, Itm.Left);
Cmds.AddObject(Order, Itm);
end;
Cmds.Sort;
Row := 0;
I := 0;
while I < Cmds.Count do begin
Itm := TReportItem(Cmds.Objects[I]);
LastTop := Itm.Top + 2000;
while LastTop > Itm.Top do begin
Itm.Row := Row;
Cmds[I] := FormatFloat(´00000000´, Itm.Row) + FormatFloat(´00000000´, Itm.Left);
Inc(I);
if I >= Cmds.Count then begin
Break;
end else begin
Itm := TReportItem(Cmds.Objects[I]);
end;
end;
Inc(Row);
end;
Cmds.Sort;
end;
procedure TExtraDevice.CalcSize(Itm: TReportItem);
var
Bmp: TBitmap;
Cmd: TppDrawText;
Right, Center, Left, Width, Height: Integer;
begin
Itm.AdjLeft := Itm.Left;
Itm.AdjWidth := Itm.Width;
Itm.AdjHeight := Itm.Height;
if Itm.DrawCmd is TppDrawText then begin
Left := Itm.Left;
Width := Itm.Width;
Height := Itm.Height;
Center := Itm.Left + Itm.Width div 2;
Right := Itm.Left + Itm.Width;
Cmd := TppDrawText(Itm.DrawCmd);
Bmp := TBitmap.Create;
Bmp.Canvas.Font := Cmd.Font;
if Cmd.IsMemo then begin
end else begin
Width := Bmp.Canvas.TextWidth(Cmd.Text);
Width := Trunc(ppFromScreenPixels(Width, utMMThousandths, pprtHorizontal, Nil));
Height := Bmp.Canvas.TextHeight(Cmd.Text);
Height := Trunc(ppFromScreenPixels(Height, utMMThousandths, pprtVertical, Nil));
end;
if Cmd.TextAlignment = taRightJustified then begin
Left := Right - Width;
end;
if Cmd.TextAlignment = taCentered then begin
Left := Center - Width div 2;
end;
Bmp.Free;
if Cmd.AutoSize = True then begin
Itm.Left := Left;
Itm.Width := Width;
Itm.Height := Height;
end;
Itm.AdjLeft := Left;
Itm.AdjWidth := Width;
Itm.AdjHeight := Height;
end;
end;
procedure TExtraDevice.CalcBarCodeSize(Itm: TReportItem);
var
Bmp: TBitmap;
Bar: TppDrawBarCode;
begin
Bar := TppDrawBarCode(Itm.DrawCmd);
if Bar.AutoSize = True then begin
Bmp := TBitmap.Create;
Bar.CalcBarCodeSize(Bmp.Canvas);
if Bar.Orientation in [orLeftToRight, orRightToLeft] then begin
Itm.Width := HorzPixelsToThousandths(Bar.PortraitWidth);
Itm.Height := VertPixelsToThousandths(Bar.PortraitHeight);
end else begin
Itm.Width := HorzPixelsToThousandths(Bar.PortraitHeight);
Itm.Height := VertPixelsToThousandths(Bar.PortraitWidth);
end;
Bmp.Free;
end;
end;
function TExtraDevice.ConvertFont(FontName: String): String;
begin
Result := ´Times New Roman´;
if Pos(´COURIER´, UpperCase(FontName)) <> 0 then begin
Result := ´Courier´;
end;
if Pos(´ARIAL´, UpperCase(FontName)) <> 0 then begin
Result := ´Arial´;
end;
if Pos(´WINGDINGS´, UpperCase(FontName)) <> 0 then begin
Result := ´Wingdings´;
end;
if Pos(´TIMES´, UpperCase(FontName)) <> 0 then begin
Result := ´Times New Roman´;
end;
end;
procedure TExtraDevice.SavePageToFile(Page: TppPage);
var
I: Integer;
Cmds: TStringList;
RptItem: TReportItem;
LastRow: Integer;
Band: TReportBand;
begin
Cmds := TStringList.Create;
GetDrawCommands(Page, Cmds);
if Cmds.Count = 0 then begin
Cmds.Free;
Exit;
end;
StartPage;
// Process Commands
I := 0;
while I < Cmds.Count do begin
RptItem := TReportItem(Cmds.Objects[I]);
LastRow := RptItem.Row;
StartBand;
Band := TReportBand.Create;
while (not SeparateBands) or (LastRow = RptItem.Row) do begin
Band.Add(RptItem);
Inc(I);
if I >= Cmds.Count then begin
Break;
end else begin
RptItem := TReportItem(Cmds.Objects[I]);
end;
end;
ProcessBand(Band);
Band.Free;
EndBand;
end;
EndPage;
for I := 0 to Cmds.Count - 1 do begin
TReportItem(Cmds.Objects[I]).Free;
end;
Cmds.Free;
end;
procedure TExtraDevice.DrawLine(B: TCanvas; Lne: TppDrawLine; Bounds: TRect);
var
Width, Height, N, L, H, X, XOffset, YOffset: Integer;
begin
Width := Bounds.Right - Bounds.Left;
Height := Bounds.Bottom - Bounds.Top;
B.Pen.Assign(Lne.Pen);
B.Pen.Width := 1;
X := PointsToPixels(Lne.Weight);
if X = 0 then begin
X := 1;
end;
if Lne.LineStyle = lsSingle then begin
N := 1;
end else begin
N := 2;
end;
XOffset := Bounds.Left;
YOffset := Bounds.Top;
for L := 0 to N - 1 do begin
for H := 0 to X - 1 do begin
if Lne.LinePosition = lpTop then begin
B.MoveTo(XOffset, YOffset + H + (L * X * 2));
B.LineTo(XOffset + Width, YOffset + H + (L * X * 2));
end;
if Lne.LinePosition = lpBottom then begin
B.MoveTo(XOffset, YOffset + (Height - 1) - H - (L * X * 2));
B.LineTo(XOffset + Width, YOffset + (Height - 1) - H - (L * X * 2));
end;
if Lne.LinePosition = lpLeft then begin
B.MoveTo(XOffset + H + (L * X * 2), YOffset);
B.LineTo(XOffset + H + (L * X * 2), YOffset + Height);
end;
if Lne.LinePosition = lpRight then begin
B.MoveTo(XOffset + Width - H - (L * X * 2) - 1, YOffset);
B.LineTo(XOffset + Width - H - (L * X * 2) - 1, YOffset + Height);
end;
end;
end;
end;
procedure TExtraDevice.DrawShape(B: TCanvas; Shp: TppDrawShape; Bounds: TRect);
var
Top, Left, Width, Height, XCR, YCR: Integer;
begin
// Removed 4/9/00
// if Shp.Pen.Width <> 1 then begin
// InflateRect(Bounds, -Shp.Pen.Width, -Shp.Pen.Width);
// end;
Width := Bounds.Right - Bounds.Left;
Height := Bounds.Bottom - Bounds.Top;
B.Brush.Assign(Shp.Brush);
B.Pen.Assign(Shp.Pen);
if B.Pen.Width = 0 then begin
B.Pen.Width := 1;
end;
if Shp.ShapeType in [stCircle] then begin
if Width > Height then begin
Left := Bounds.Left + (Width - Height) div 2;
B.Ellipse(Left, Bounds.Top, Left + Height, Bounds.Bottom);
end else begin
Top := Bounds.Top + (Height - Width) div 2;
B.Ellipse(Bounds.Left, Top, Bounds.Right, Top + Width);
end;
end;
if Shp.ShapeType in [stEllipse] then begin
B.Ellipse(Bounds.Left, Bounds.Top, Bounds.Right, Bounds.Bottom);
end;
if Shp.ShapeType in [stSquare] then begin
if Width > Height then begin
Left := Bounds.Left + (Width - Height) div 2;
B.Rectangle(Left, Bounds.Top, Left + Height, Bounds.Bottom);
end else begin
Top := Bounds.Top + (Height - Width) div 2;
B.Rectangle(Bounds.Left, Top, Bounds.Right, Top + Width);
end;
end;
if Shp.ShapeType in [stRectangle] then begin
B.Rectangle(Bounds.Left, Bounds.Top, Bounds.Right, Bounds.Bottom);
end;
if Shp.ShapeType in [stRoundSquare] then begin
XCR := ppToScreenPixels(Shp.XCornerRound, utMMThousandths, pprtHorizontal, Nil);
YCR := ppToScreenPixels(Shp.YCornerRound, utMMThousandths, pprtVertical, Nil);
if Width > Height then begin
Left := Bounds.Left + (Width - Height) div 2;
B.RoundRect(Left, Bounds.Top, Left + Height, Bounds.Bottom, XCR, YCR);
end else begin
Top := Bounds.Top + (Height - Width) div 2;
B.RoundRect(Bounds.Left, Top, Bounds.Right, Top + Width, XCR, YCR);
end;
end;
if Shp.ShapeType in [stRoundRect] then begin
XCR := ppToScreenPixels(Shp.XCornerRound, utMMThousandths, pprtHorizontal, Nil);
YCR := ppToScreenPixels(Shp.YCornerRound, utMMThousandths, pprtVertical, Nil);
B.RoundRect(Bounds.Left, Bounds.Top, Bounds.Right, Bounds.Bottom, XCR, YCR);
end;
end;
procedure TExtraDevice.DrawBarCode(B: TCanvas; Bar: TppDrawBarCode; Bounds: TRect);
var
T: TBitmap;
P: TPoint;
begin
T := TBitmap.Create;
Bar.CalcBarCodeSize(T.Canvas);
if Bar.Orientation in [orLeftToRight, orRightToLeft] then begin
T.Width := Bar.PortraitWidth;
T.Height := Bar.PortraitHeight;
end else begin
T.Width := Bar.PortraitHeight;
T.Height := Bar.PortraitWidth;
end;
P := Point(Screen.PixelsPerInch, Screen.PixelsPerInch);
T.Canvas.Pen.Color := clBlack;
Bar.DrawBarCode(T.Canvas, 0, 0, P, True);
B.StretchDraw(Bounds, T);
T.Free;
end;
procedure TExtraDevice.DrawRichText(B: TBitmap; DRT: TppDrawRichText; Bounds: TRect);
var
MF: TMetaFile;
MC: TMetaFileCanvas;
Width, Height: Integer;
CharRange: TCharRange;
DC: hDC;
R: TRect;
RE: TCustomRichEdit;
begin
RE := ppGetRichEditClass.Create(ppParentWnd);
RE.Parent := ppParentWnd;
DRT.RichTextStream.Position := 0;
ppGetRichEditLines(RE).LoadFromStream(DRT.RichTextStream);
CharRange.cpMin := DRT.StartCharPos;
CharRange.cpMax := DRT.EndCharPos;
DC := GetDC(0);
Width := Bounds.Right - Bounds.Left;
Height := Bounds.Bottom - Bounds.Top;
R := Rect(0, 0, Width, Height);
MF := TMetaFile.Create;
MF.Width := Width;
MF.Height := Height;
MC := TMetaFileCanvas.Create(MF, DC);
if not DRT.Transparent then begin
MC.Brush.Style := bsSolid;
MC.Brush.Color := DRT.Color;
MC.FillRect(Bounds);
end;
ppGetRTFEngine(RE).DrawRichText(MC.Handle, DC, R, CharRange);
MC.Free;
ReleaseDC(0, DC);
B.Canvas.StretchDraw(Bounds, MF);
MF.Free;
RE.Free;
end;
procedure TExtraDevice.DrawImage(B: TBitmap; Itm: TReportItem; Bounds: TRect; AdjBitmap, IgnoreAttr, AdjImage: Boolean);
var
Scale: Extended;
R: TRect;
W: TBitmap;
Width, Height: Integer;
Img: TppDrawImage;
begin
Img := TppDrawImage(Itm.DrawCmd);
Width := Bounds.Right - Bounds.Left;
Height := Bounds.Bottom - Bounds.Top;
W := TBitmap.Create;
W.PixelFormat := B.PixelFormat;
if AdjImage then begin
W.Width := Img.Picture.Width;
W.Height := Img.Picture.Height;
end else begin
W.Width := Width;
W.Height := Height;
end;
if not IgnoreAttr then begin
if Img.Stretch and Img.MaintainAspectRatio then begin
R := Rect(0, 0, Width, Height);
Scale := ppCalcAspectRatio(Img.Picture.Width, Img.Picture.Height, Width, Height);
if Img.Center then begin
R.Left := R.Left + ((Width - Trunc(Img.Picture.Width * Scale)) div 2);
R.Top := R.Top + ((Height - Trunc(Img.Picture.Height * Scale)) div 2);
end;
R.Right := R.Left + Trunc(Img.Picture.Width * Scale);
R.Bottom := R.Top + Trunc(Img.Picture.Height * Scale);
end else if Img.Stretch then begin
R := Rect(0, 0, Width, Height);
end else if Img.Center then begin
R := Rect((Width - Img.Picture.Width) div 2, (Height - Img.Picture.Height) div 2, Img.Picture.Width, Img.Picture.Height)
end else begin
R := Rect(0, 0, Img.Picture.Width, Img.Picture.Height);
end;
end else begin
R := Rect(0, 0, Img.Picture.Width, Img.Picture.Height);
end;
if AdjBitmap then begin
B.Width := W.Width;
B.Height := W.Height;
B.PixelFormat := W.PixelFormat;
if Img.Picture.Graphic is TMetaFile then begin
B.Palette := Img.Picture.MetaFile.Palette;
end;
if Img.Picture.Graphic is TBitmap then begin
B.Palette := Img.Picture.Bitmap.Palette;
end;
end;
if AdjImage then begin
B.Canvas.Draw(0, 0, Img.Picture.Graphic);
end else begin
W.Canvas.StretchDraw(R, Img.Picture.Graphic);
B.Canvas.CopyMode := cmSrcCopy;
B.Canvas.CopyRect(Bounds, W.Canvas, Rect(0, 0, Width, Height));
end;
W.Free;
if AdjImage and (((R.Right - R.Left) < Img.Picture.Width) or ((R.Bottom - R.Top) < Img.Picture.Height)) then begin
Itm.Top := Itm.Top + VertPixelsToThousandths(R.Top);
Itm.Left := Itm.Left + HorzPixelsToThousandths(R.Left);
Itm.Width := HorzPixelsToThousandths(R.Right - R.Left);
Itm.Height := VertPixelsToThousandths(R.Bottom - R.Top);
end;
end;
procedure TExtraDevice.DrawCheckBox(B: TBitmap; Txt: TppDrawText; Bounds: TRect; AdjBitmap: Boolean; IgnoreAttr: Boolean);
var
Width, Height: Integer;
begin
B.Canvas.Font := Txt.Font;
B.Canvas.Font.Size := B.Canvas.Font.Size - Trunc(B.Canvas.Font.Size * 0.10);
B.Canvas.Brush.Color := clWhite;
Width := Bounds.Right - Bounds.Left;
Height := Bounds.Bottom - Bounds.Top;
if AdjBitmap then begin
B.Width := Width;
B.Height := Height;
B.PixelFormat := pf24bit;
end;
B.Canvas.TextOut(0, 1, Txt.Text);
end;
function TExtraDevice.WriteImage(B: TBitmap): String;
var
N: Integer;
J: TJPEGImage;
begin
Result := ´IMG´ + FormatFloat(´0000´, FImageNo) + ´.JPG´;
J := TJPEGImage.Create;
J.Assign(B);
N := ImageIndex(J, Result);
if N = -1 then begin
Inc(FImageNo);
try
J.SaveToFile(ExtractFilePath(FileName) + Result);
except
raise EPrintError.Create(´File Error: ´ + Result);
end;
end else begin
Result := TImageCRC(ImageList[N]).FileName;
end;
J.Free;
end;
function TExtraDevice.ImageIndex(J: TObject; FileName: String): Integer;
var
MS: TMemoryStream;
I: Integer;
N: Cardinal;
T: TImageCRC;
begin
MS := TMemoryStream.Create;
if J is TJPEGImage then begin
(J as TJPEGImage).SaveToStream(MS);
end else begin
(J as TBitmap).SaveToStream(MS);
end;
Result := -1;
N := CRC(MS);
for I := 0 to ImageList.Count - 1 do begin
if TImageCRC(ImageList[I]).CRC = N then begin
Result := I;
Break;
end;
end;
if Result = -1 then begin
T := TImageCRC.Create;
T.FileName := FileName;
T.CRC := N;
ImageList.Add(T);
end;
MS.Free;
end;
procedure TExtraDevice.InitCRCTable;
var
I, J: Integer;
begin
for I := 0 to 255 do begin
CRCTable[I] := I;
for J := 0 to 7 do begin
if Odd(CRCTable[I]) then begin
CRCTable[I] := CRCTable[I] shr 1;
CRCTable[I] := CRCTable[I] xor $EDB88320;
end else begin
CRCTable[I] := CRCTable[I] shr 1;
end;
end;
end;
end;
function TExtraDevice.CRC(MS: TMemoryStream): Cardinal;
var
I, J: Integer;
B: String;
begin
Result := 0;
MS.Position := 0;
B := ´ ´;
for I := 0 to MS.Size - 1 do begin
MS.Read(B[1], 1);
J := (Ord(B[1]) xor Result) and $000000FF;
Result := (Result shr 8) xor CRCTable[J];
end;
Result := not Result;
end;
{ WK1 Device }
class function TWK1Device.DeviceName: String;
begin
Result := ´LotusFile´;
end;
class function TWK1Device.DefaultExt: String;
begin
Result := ´WK1´;
end;
class function TWK1Device.DefaultExtFilter: String;
begin
Result := ´123 files|*.WK1|All files|*.*´;
end;
class function TWK1Device.DeviceDescription(aLanguageIndex: Longint): String;
begin
Result := ´Lotus File´;
end;
procedure TWK1Device.StartJob;
begin
inherited;
Write(CHR(0) + CHR(0) + CHR(2) + CHR(0) + CHR(6) + CHR(4));
end;
procedure TWK1Device.EndJob;
begin
if FileStream = Nil then begin
Exit;
end;
Write(CHR(1) + CHR(0) + CHR(0) + CHR(0));
inherited;
end;
procedure TWK1Device.ProcessBand(Band: TReportBand);
var
Text: String;
I, LastCol, Col: Integer;
Itm: TReportItem;
Txt: TppDrawText;
begin
inherited;
LastCol := -1;
for I := 0 to Band.Count - 1 do begin
Itm := TReportItem(Band[I]);
if Itm.ItemType = riText then begin
Txt := TppDrawText(Itm.DrawCmd);
Col := Trunc(Itm.Left / 16934);
if Col <= LastCol then begin
Col := LastCol + 1;
end;
LastCol := Col;
if Txt.DataType in [dtCurrency, dtDouble, dtExtended, dtInteger, dtLongInt, dtSingle] then begin
Write(LotWord(14) + LotWord(13) + CHR(128 + 2) + LotWord(Col) + LotWord(FRow) + TextToIEEE(Txt.Text));
end else begin
if Txt.IsMemo then begin
Text := Replace(Copy(Txt.WrappedText.Text, 1, 255), #13, ´ ´);
Text := Replace(Text, EOP, ´´);
end else begin
Text := Replace(Txt.Text, #13 + 10, ´ ´);;
end;
Write(LotWord(15) + LotWord(Length(Text) + 7) + CHR(255) + LotWord(Col) + LotWord(FRow) + 39 + Text + CHR(0));
end;
end;
if Itm.ItemType = riRTF then begin
Col := Trunc(Itm.Left / 16934);
if Col <= LastCol then begin
Col := LastCol + 1;
end;
LastCol := Col;
Text := RTFToPlainString(TppDrawRichText(Itm.DrawCmd));
Text := Replace(Copy(Text, 1, 255), 13 + 10, ´ ´);
Text := Replace(Text, EOP, ´´);
Write(LotWord(15) + LotWord(Length(Text) + 7) + CHR(255) + LotWord(Col) + LotWord(FRow) + 39 + Text + CHR(0));
end;
end;
end;
{ WQ1 Device }
class function TWQ1Device.DeviceName: String;
begin
Result := ´QuattroFile´;
end;
class function TWQ1Device.DefaultExt: String;
begin
Result := ´WQ1´;
end;
class function TWQ1Device.DefaultExtFilter: String;
begin
Result := ´Quattro files|*.WQ1|All files|*.*´;
end;
class function TWQ1Device.DeviceDescription(aLanguageIndex: Longint): String;
begin
Result := ´Quattro File´;
end;
procedure TWQ1Device.StartJob;
begin
inherited;
Write(CHR(0) + CHR(0) + CHR(2) + CHR(0) + CHR(32) + CHR(81));
end;
procedure TWQ1Device.EndJob;
begin
if FileStream = Nil then begin
Exit;
end;
Write(CHR(1) + CHR(0) + CHR(0) + CHR(0));
inherited;
end;
procedure TWQ1Device.ProcessBand(Band: TReportBand);
var
Text: String;
I, LastCol, Col: Integer;
Itm: TReportItem;
Txt: TppDrawText;
begin
inherited;
LastCol := -1;
for I := 0 to Band.Count - 1 do begin
Itm := TReportItem(Band[I]);
if Itm.ItemType = riText then begin
Col := Trunc(Itm.Left / 16934);
if Col <= LastCol then begin
Col := LastCol + 1;
end;
LastCol := Col;
Txt := TppDrawText(Itm.DrawCmd);
if Txt.DataType in [dtCurrency, dtDouble, dtExtended, dtInteger, dtLongInt, dtSingle] then begin
Write(LotWord(14) + LotWord(13) + CHR(128 + 2) + LotWord(Col) + LotWord(FRow) + TextToIEEE(Txt.Text));
end else begin
if Txt.IsMemo then begin
Text := Replace(Copy(Txt.WrappedText.Text, 1, 255), #13, ´ ´);
Text := Replace(Text, EOP, ´´);
end else begin
Text := Replace(Txt.Text, 13 + 10, ´ ´);
end;
Write(LotWord(15) + LotWord(Length(Text) + 7) + CHR(255) + LotWord(Col) + LotWord(FRow) + 39 + CHR(Length(Text)) + Text);
end;
end;
if Itm.ItemType = riRTF then begin
Col := Trunc(Itm.Left / 16934);
if Col <= LastCol then begin
Col := LastCol + 1;
end;
LastCol := Col;
Text := RTFToPlainString(TppDrawRichText(Itm.DrawCmd));
Text := Replace(Copy(Text, 1, 255), #13 + 10, ´ ´);
Text := Replace(Text, EOP, ´´);
Write(LotWord(15) + LotWord(Length(Text) + 7) + CHR(255) + LotWord(Col) + LotWord(FRow) + 39 + CHR(Length(Text)) + Text);
end;
end;
end;
{ XLS Device }
class function TXLSDevice.DeviceName: String;
begin
Result := ´ExcelFile´;
end;
class function TXLSDevice.DefaultExt: String;
begin
Result := ´XLS´;
end;
class function TXLSDevice.DefaultExtFilter: String;
begin
Result := ´Excel files|*.XLS|All files|*.*´;
end;
class function TXLSDevice.DeviceDescription(aLanguageIndex: Longint): String;
begin
Result := ´Excel File´;
end;
function TXLSDevice.FontIndex(Font: TFont): String;
var
I, S: Integer;
FontStr: String;
begin
S := 0;
if fsBold in Font.Style then begin
S := S + 1;
end;
if fsItalic in Font.Style then begin
S := S + 2;
end;
if fsUnderline in Font.Style then begin
S := S + 4;
end;
if fsStrikeOut in Font.Style then begin
S := S + 8;
end;
FontStr := LotWord(Font.Size * 20) + LotWord(S) + LotWord(0) + CHR(Length(Font.Name)) + Font.Name;
I := IndexOf(FontTbl, FontStr);
if I = -1 then begin
FontTbl.Add(FontStr);
I := FontTbl.Count - 1;
end;
if I > 3 then begin
Inc(I);
end;
Result := CHR(I);
end;
function TXLSDevice.FormatIndex(Format: String): String;
var
I: Integer;
FormatStr: String;
begin
FormatStr := Format;
I := IndexOf(FormatTbl, FormatStr);
if I = -1 then begin
FormatTbl.Add(FormatStr);
I := FormatTbl.Count - 1;
end;
Result := CHR(I);
end;
function TXLSDevice.XFIndex(Txt: TppDrawText; Numeric: Boolean): String;
var
I, Options: Integer;
XFStr: String;
begin
XFStr := FontIndex(Txt.Font);
if Numeric then begin
XFStr := XFStr + FormatIndex(´0.00´);
end else begin
XFStr := XFStr + FormatIndex(´General´);
end;
XFStr := XFStr + CHR($00) + CHR($00); // XF Index
Options := 0;
case Txt.TextAlignment of
taLeftJustified: Options := 1;
taCentered: Options := 2;
taRightJustified: Options := 3;
end;
// if Wrap then begin
// Options := Options + 8;
// end;
XFStr := XFStr + LotWord(Options);
XFStr := XFStr + LotWord(0); // Color & Fill
XFStr := XFStr + LotWord(0); // Frame
XFStr := XFStr + LotWord(0); // Frame Type
I := IndexOf(XFTbl, XFStr);
if I = -1 then begin
XFTbl.Add(XFStr);
I := XFTbl.Count - 1;
end;
Result := LotWord(I + 20); // 20 Standard + Custom
end;
procedure TXLSDevice.WriteFontTbl;
var
I: Integer;
begin
for I := 0 to FontTbl.Count - 1 do begin
Write(CHR($31) + CHR($02) + LotWord(Length(FontTbl[I])) + FontTbl[I]);
end;
end;
procedure TXLSDevice.WriteFormatTbl;
var
I: Integer;
begin
for I := 0 to FormatTbl.Count - 1 do begin
Write(CHR($1E) + CHR($00) + LotWord(1 + Length(FormatTbl[I])) + CHR(Length(FormatTbl[I])) + FormatTbl[I]);
end;
end;
procedure TXLSDevice.WriteXFT
Thiagopedro
Curtir tópico
+ 0
Responder
Posts
07/04/2005
Thiagopedro
colegas vou continuar nessas linhas abaixo pq tudo q postei anteriormente não foi o necessário.
o código anterior da unit prossegue tudo certinho o erro está na linha do comando:
RE.Parent := ppParentWnd;
erro: Undeclared Indentifier ppParentWnd
ppGetRTFEngine(RE).DrawRichText(MC.Handle, DC, R, CharRange);
erro: Undeclared Indentifier ppGetRTFEngine
o código anterior da unit prossegue tudo certinho o erro está na linha do comando:
RE.Parent := ppParentWnd;
erro: Undeclared Indentifier ppParentWnd
ppGetRTFEngine(RE).DrawRichText(MC.Handle, DC, R, CharRange);
erro: Undeclared Indentifier ppGetRTFEngine
Responder
Gostei + 0
Clique aqui para fazer login e interagir na Comunidade :)