//
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 Units
Description: 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 Index
procedure 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 Index
procedure 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. //