unit ads_RBXtraDev;
{Copyright(c)2016 Advanced Delphi Systems
Richard Maley
Advanced Delphi Systems
12613 Maidens Bower Drive
Potomac, MD 20854 USA
phone 301-840-1554
dickmaley@advdelphisys.com
The code herein can be used or modified by anyone. Please retain references
to Richard Maley at Advanced Delphi Systems. If you make improvements to the
code please send your improvements to dickmaley@advdelphisys.com so that the
entire Delphi community can benefit. All comments are welcome.
}
(*UnitIndex Master Index Implementation Section Download UnitsDescription: ads_RBXtraDev.pas This unit contains the following routines.
TExtraDevice_ads.CalcSize TExtraDevice_ads.CRC TExtraDevice_ads.DrawBarCode TExtraDevice_ads.DrawCheckBox TExtraDevice_ads.DrawImage TExtraDevice_ads.DrawLine TExtraDevice_ads.DrawRichText TExtraDevice_ads.DrawShape TExtraDevice_ads.EndBand TExtraDevice_ads.EndJob TExtraDevice_ads.EndPage TExtraDevice_ads.GetDrawCommands TExtraDevice_ads.ImageIndex TExtraDevice_ads.InitCRCTable TExtraDevice_ads.ProcessBand TExtraDevice_ads.ReceivePage TExtraDevice_ads.SavePageToFile TExtraDevice_ads.StartBand TExtraDevice_ads.StartJob TExtraDevice_ads.StartPage TExtraDevice_ads.Stream TExtraDevice_ads.Write TExtraDevice_ads.WriteImage
*)
interface
uses
Windows,
Classes,
Graphics,
ppFilDev,
ppDevice,
ppDrwCmd,
TXtraDev
;
Type
//TExtraDevice_ads = class(TExtraDevice)
TExtraDevice_ads = class(TppFileDevice)
protected
CRCTable : array[0..255] of Cardinal;
FCol : Integer;
FImageNo : Integer;
FPageNo : Integer;
FRow : Integer;
ImageList : TList;
MemStream : TMemoryStream;
Page : TppPage;
SeparateBands: Boolean;
function CRC(MS: TMemoryStream): Cardinal;
function ImageIndex(J: TObject; FileName: String): Integer;
function WriteImage(B: TBitmap): String;
procedure CalcSize(Itm: TReportItem);
procedure DrawBarCode(B: TCanvas; Bar: TppDrawBarCode; Bounds: TRect);
procedure DrawCheckBox(B: TBitmap; Txt: TppDrawText; Bounds: TRect; AdjBitmap: Boolean; IgnoreAttr: Boolean);
procedure DrawImage(B: TBitmap; Img: TppDrawImage; Bounds: TRect; AdjBitmap: Boolean; IgnoreAttr: Boolean);
procedure DrawLine(B: TCanvas; Lne: TppDrawLine; Bounds: TRect);
procedure DrawRichText(B: TBitmap; DRT: TppDrawRichText; Bounds: TRect);
procedure DrawShape(B: TCanvas; Shp: TppDrawShape; Bounds: TRect);
procedure EndBand; virtual;
procedure EndPage; virtual;
procedure GetDrawCommands(Page: TppPage; Cmds: TStringList);
procedure InitCRCTable;
procedure ProcessBand(Band: TReportBand); virtual;
procedure SavePageToFile(Page: TppPage);
procedure StartBand; virtual;
procedure StartPage; virtual;
procedure Stream(Buffer: String);
procedure Write(Buffer: String); virtual;
public
constructor Create(aOwner: TComponent); override;
destructor Destroy; override;
procedure EndJob; override;
procedure ReceivePage(aPage: TppPage); override;
procedure StartJob; override;
end;
implementation
Uses
ads_RBTXtraDevUtils,
ComCtrls,
ExtCtrls,
Forms,
Jpeg,
ppTypes,
ppUtils,
RichEdit,
SysUtils
;
constructor TExtraDevice_ads.Create(aOwner: TComponent);
begin
inherited;
MemStream := TMemoryStream.Create;
SeparateBands := True;
InitCRCTable;
ImageList := TList.Create;
end;
destructor TExtraDevice_ads.Destroy;
var
I: Integer;
begin
MemStream.Free;
for I := 0 to ImageList.Count - 1 do begin
TImageCRC(ImageList[I]).Free;
end;
ImageList.Free;
inherited;
end;
//Unit Description UnitIndex Master Indexprocedure TExtraDevice_ads.StartJob; begin inherited; FRow := 0; FCol := 0; FPageNo := 0; FImageNo := 0; end; //Unit Description UnitIndex Master Index
procedure TExtraDevice_ads.EndJob; begin inherited; end; //Unit Description UnitIndex Master Index
procedure TExtraDevice_ads.ReceivePage(aPage: TppPage);
begin
inherited;
Page := aPage;
if IsRequestedPage then begin
DisplayMessage(aPage);
if not IsMessagePage then begin
SavePageToFile(aPage);
end;
end;
end;
//Unit Description UnitIndex Master Index
procedure TExtraDevice_ads.GetDrawCommands(Page: TppPage; Cmds: TStringList);
var
I, N, 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;
CalcSize(Itm);
if DrawCmd is TppDrawLine then begin
Itm.ItemType := riLine;
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);
end;
if DrawCmd is TppDrawRichText then begin
Itm.ItemType := riRTF;
end;
if DrawCmd is TppDrawImage then begin
Itm.ItemType := riImage;
end;
if DrawCmd is TppDrawShape then begin
Itm.ItemType := riShape;
end;
if DrawCmd is TppDrawBarCode then begin
Itm.ItemType := riBarCode;
end;
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;
//Unit Description UnitIndex Master Index
procedure TExtraDevice_ads.Write(Buffer: String);
begin
if Length(Buffer) > 0 then begin
FileStream.Write(Buffer[1], Length(Buffer));
end;
end;
//Unit Description UnitIndex Master Index
procedure TExtraDevice_ads.Stream(Buffer: String);
begin
if Length(Buffer) > 0 then begin
MemStream.Write(Buffer[1], Length(Buffer));
end;
end;
//Unit Description UnitIndex Master Index
procedure TExtraDevice_ads.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.Alignment = taRightJustify then begin
Left := Right - Width; // - 2000; {1/8/00} Removed
end;
if Cmd.Alignment = taCenter 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;
//Unit Description UnitIndex Master Index
procedure TExtraDevice_ads.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;
//Unit Description UnitIndex Master Index
procedure TExtraDevice_ads.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 + 1, YOffset + H + (L * X * 2));
B.LineTo(XOffset + Width - 1, YOffset + H + (L * X * 2));
end;
if Lne.LinePosition = lpBottom then begin
B.MoveTo(XOffset + 1, YOffset + Height - H - (L * X * 2));
B.LineTo(XOffset + Width - 1, YOffset + Height - H - (L * X * 2));
end;
if Lne.LinePosition = lpLeft then begin
B.MoveTo(XOffset + 1 + H + (L * X * 2), YOffset);
B.LineTo(XOffset + 1 + H + (L * X * 2), YOffset + Height - 1);
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 - 1);
end;
end;
end;
end;
//Unit Description UnitIndex Master Index
procedure TExtraDevice_ads.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 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;
//Unit Description UnitIndex Master Index
procedure TExtraDevice_ads.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;
//Unit Description UnitIndex Master Index
procedure TExtraDevice_ads.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;
//Unit Description UnitIndex Master Index
procedure TExtraDevice_ads.DrawImage(B: TBitmap; Img: TppDrawImage; Bounds: TRect; AdjBitmap: Boolean; IgnoreAttr: Boolean);
var
Scale: Extended;
R: TRect;
W: TBitmap;
Width, Height: Integer;
begin
Width := Bounds.Right - Bounds.Left;
Height := Bounds.Bottom - Bounds.Top;
W := TBitmap.Create;
W.Width := Width;
W.Height := Height;
W.PixelFormat := B.PixelFormat;
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 := Width;
B.Height := 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;
W.Canvas.StretchDraw(R, Img.Picture.Graphic);
B.Canvas.CopyMode := cmSrcCopy;
B.Canvas.CopyRect(Bounds, W.Canvas, Rect(0, 0, Width, Height));
W.Free;
end;
//Unit Description UnitIndex Master Index
procedure TExtraDevice_ads.DrawCheckBox(B: TBitmap; Txt: TppDrawText; Bounds: TRect; AdjBitmap: Boolean; IgnoreAttr: Boolean);
var
Width, Height: Integer;
DC: HDC;
TM: TTextMetric;
SaveFont: HFont;
begin
DC := GetDC(0);
SaveFont := SelectObject(DC, Txt.Font.Handle);
GetTextMetrics(DC, TM);
//Height := TM.tmAscent - TM.tmInternalLeading;
SelectObject(DC, SaveFont);
ReleaseDC(0, DC);
Width := Bounds.Right - Bounds.Left;
Height := Bounds.Bottom - Bounds.Top;
B.Canvas.Font := Txt.Font;
if AdjBitmap then begin
B.Width := Width;
B.Height := Height;
B.PixelFormat := pf24bit;
end;
B.Canvas.TextOut(0, 0, Txt.Text);
end;
//Unit Description UnitIndex Master Index
function TExtraDevice_ads.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;
//Unit Description UnitIndex Master Index
function TExtraDevice_ads.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;
//Unit Description UnitIndex Master Index
procedure TExtraDevice_ads.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;
//Unit Description UnitIndex Master Index
function TExtraDevice_ads.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;
//Unit Description UnitIndex Master Indexprocedure TExtraDevice_ads.StartPage; begin Inc(FPageNo); end; //Unit Description UnitIndex Master Index
procedure TExtraDevice_ads.EndPage; begin end; //Unit Description UnitIndex Master Index
procedure TExtraDevice_ads.StartBand; begin FCol := 0; end; //Unit Description UnitIndex Master Index
procedure TExtraDevice_ads.EndBand; begin Inc(FRow); end; //Unit Description UnitIndex Master Index
procedure TExtraDevice_ads.ProcessBand(Band: TReportBand); begin end; end. //