unit DrawEngine; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, Printers, ExtCtrls,math,PCTypesUtils,RichEdit,ComCtrls,RichEdit2,olectnrs,ActiveX, U_Common_Classes, Parser10,rrEllipses,OpenGL {Tolik--27-05-2017--},GDIPlus, GDIPAPI, GDIPOBJ; type TPoint = Windows.TPoint; TRect = Windows.TRect; TSize = Windows.TSize; const INCHES_PER_MILIMETER: Real = 0.04; { ExtPenStyles: array[TPenStyle] of Word = (PS_SOLID, PS_DASH, PS_DOT, PS_DASHDOT, PS_DASHDOTDOT, PS_NULL, PS_INSIDEFRAME); //01.11.2011} ExtPenStyles: array[TPenStyle] of TPenStyle = (psSolid, psDash, psDot, psDashDot, psDashDotDot, psClear, psInsideFrame, psUserStyle, psAlternate); type TOffset = record X, Y: Integer; end; TExtPen = class(TObject) FhPen: HPEN; end; TPCDrawEngine = class(TObject) private FCanvas: TCanvas; comp: TBitmap; protected FCachePen: Boolean; //01.11.2011 FPens: TStringList; Procedure SetCanvas(value: TCanvas); procedure drawlinePix(x1,y1,x2,y2,color,aWidth,style,row: integer);overload; procedure drawlinePix(p1,p2:TPoint; row: Integer);overload; procedure drawlinePixD(x1,y1,x2,y2: Double;color,aWidth,style,row: integer); function ExtCreatePenMy(aCanva: TCanvas): HPEN; public ConvertPoint: ConvertXYProc; ConvertLen : ConvertDimProc; DeConvertPoint: ConvertXYProc; DeConvertLen : ConvertDimProc; PrintBmp: TBitmap; isPrinting: Boolean; Tag: Integer; Isometric: Boolean; ClipRgn : HRGN; ExClip: HRGN; FPrinting: Boolean; //01.11.2011 property CachePen: Boolean read FCachePen write FCachePen; //01.11.2011 // procedure PenCh(aObject: TObject); Procedure ConvertCoord (var X,Y,Z: Double); function ConvertCoordToPt(const pt: TDoublePoint): TPoint; //31.10.2011 Procedure ConvertDim (var Dim: Double); Procedure DeConvertCoord (var X,Y,Z: Double); Procedure DeConvertDim (var Dim: Double); Function GetVertDirection:Integer; Function GetHorzDirection:Integer; Procedure CalcRowPoints(x1, y1, x2, y2: Double; hl, hh: double; var r1, r2, r3: TDoublePoint); Procedure drawrow(x1,y1,x2,y2: Double; solid: Boolean;hl:double=5;hh:double=3);overload; Procedure drawrow(x1,y1,x2,y2: Double; solid: Boolean;var reg:HRGN;hl:double=5;hh:double=3);overload; Procedure drawrowpix(x1,y1,x2,y2,h,w: integer; solid: Boolean); Procedure drawrow(xp1,xp2: TDoublePoint; solid: Boolean;var rgn:HRGN;hl:double=5;hh:double=3);overload; Procedure MoveTo(p:TDoublePoint); Procedure LineTo(p:TDoublePoint); Procedure MoveToPix(x1,y1:Double); Procedure LineToPix(x1,y1:Double); Procedure BezierTo(cx1,cy1,cx2,cy2,ex,ey:Double); Procedure Polygon(const p: TDoublePointArr;var RegHandle: HRGN; ADrawPoints: Pointer=nil); Procedure WPolygon(const p:array of TPoint;var RegHandle: HRGN; ADrawPoints: Pointer=nil); Procedure WPolyline(const p:array of TPoint); Function PolygonRegion(const p: TDoublePointArr):HRGN;overload; Function PolygonRegion(p1,p2,p3,p4: TDoublePoint):HRGN;overload; Function PolygonRegion(p1,p2,p3,p4: TPoint):HRGN;overload; Function PolygonRegion(p: TPointArr):HRGN;overload; Procedure Polyline(p: TDoublePointArr); Procedure RectanglePix(x1,y1,x2,y2:Double); Procedure EllipsePix(x1,y1,x2,y2:Double); Procedure DrawVane(p1,p2:TDoublePoint; pColor,bColor:TColor; Dim,Mar:Double; HasFlans: Boolean; var RegHandle:HRGN;kortapa:Boolean;Covered:Boolean; SeloDist:Double;st:Integer;penS:Integer=0); Procedure DrawCover(p1,p2,p3,p4:TDoublePoint;aColor:TColor;dConvert:Boolean); Procedure DrawFlansh(p1,p2:TDoublePoint; pColor,bColor:TColor; Dim,Mar,Len:Double; var RegHandle:HRGN;st:Integer); Procedure DrawFiltre(p1,p2:TDoublePoint; pColor,bColor:TColor; Dim,Mar,Len:Double; var RegHandle:HRGN;st:Integer); Procedure DrawToprak(p1,p2:TDoublePoint; pColor,bColor:TColor; Dim,Mar:Double; var RegHandle:HRGN;st:Integer;pos:Integer); Procedure DrawKatod(p1,p2: TDoublePoint; Color: TColor; var RegHandle: HRGN); Procedure DrawRegulator(p1,p2:TDoublePoint; pColor,bColor,npColor:TColor; Dim,Mar:Double; var RegHandle:HRGN;covered:Boolean;st:Integer); Procedure DrawIsoKombi(p1,p2:TDoublePoint; pColor,bColor:TColor; rad1,rad2:Double; var RegHandle:HRGN;covered:Boolean;st:Integer); Procedure DrawIsoSofben(p1,p2:TDoublePoint; pColor,bColor:TColor; rad1:Double; var RegHandle:HRGN;st:Integer); Procedure DrawIsoOcak(p1,p2:TDoublePoint; pColor,bColor:TColor; size:Double; var RegHandle:HRGN;st:Integer); Procedure DrawIsoGnCihaz(p1,p2:TDoublePoint; pColor,bColor:TColor; size:Double; var RegHandle:HRGN;st:Integer); Procedure DrawIsoSoba(p1,p2:TDoublePoint; pColor,bColor:TColor; w,h:Double; var RegHandle:HRGN;st:Integer); procedure drawline(x1,y1,x2,y2:Double;color,awidth,style,row: integer; rowL:Double=3.5;rowH:Double=1.2;rowWhite:Boolean=False);overload; procedure drawline(p1,p2:TDoublePoint;color,awidth,style,row: integer; rowL:Double=3.5;rowH:Double=1.2;rowWhite:Boolean=False);overload; procedure DrawPatternLine(p1, p2: TDoublePoint; color, awidth,style: integer;Pattern:TObject); procedure drawline(p1,p2:TDoublePoint);overload; procedure drawDashLine(p1,p2:TDoublePoint); Procedure SetCanvasValues(PenColor,BrushColor:TColor; PenWidth : Integer; PenStyle : TPenStyle; BrushStyle:TBrushStyle; PenMode: TPenMode);overload; Procedure SetCanvasValues(PenColor,BrushColor:TColor; PenWidth : Integer; PenStyle : TPenStyle; BrushStyle:TBrushStyle);overload; Procedure SetCanvasValues(PenColor,BrushColor:TColor; PenWidth , PenStyle , BrushStyle: Integer; PenMode: TPenMode);overload; Function LineRegion(p1,p2:TDoublePoint;w:Double):HRGN; Procedure drawpolyline(points: TDoublePointArr; color,awidth,style,row: integer);overload; Procedure drawpolyline(points:TDoublePointArr; Closed: Boolean);overload; procedure drawrect(x1,y1,x2,y2:Double;color,awidth,style,bc,bs: integer);overload; Procedure DrawRect(p1:TDoublePoint;rw,rh:Double;color,awidth,style,bc,bs: integer;var rgn:HRGN);overload; procedure drawrect(p1,p2:TDoublePoint;color,awidth,style,bc,bs: integer);overload; procedure drawrect(p1,p2,p3,p4:TDoublePoint;color,awidth,style,bc,bs: integer;var rgn:HRGN);overload; procedure drawpolygon(const points: TDoublePointArr; color,awidth,style,bc,bs: integer; var rgn: HRGN;brsBmp:TBitmap=nil; ADrawPoints: Pointer=nil);overload; procedure drawpolygon(p1,p2,p3,p4:TDoublePoint; color,awidth,style,bc,bs: integer);overload; procedure drawpolygon(p1,p2,p3,p4:TDoublePoint; color,awidth,style,bc,bs: integer;var rgn: HRGN);overload; Procedure FillRgn(rgn:HRGN;bc,bs:Integer); // Tolik -- 31/05/2017 -- //procedure DrawPie(x1, y1, x2, y2 : double; bc, bs, CutStyle: Integer; var rgn:HRGN; cp:TDoublePoint; Fangle, SAngle, Radius, aCutRadius: Double); procedure DrawPie(bc, bs, CutStyle: Integer; var rgn:HRGN; cp:TDoublePoint; Fangle, SAngle, Radius, aCutRadius: Double); procedure DrawPieRGB(x1, y1, x2, y2, x3, y3, x4, y4 : double; bc, bs: Integer; var rgn:HRGN;cp, ap2, ap3:TDoublePoint; Fangle, SAngle, Rad: Double); procedure DrawPieShadow(ap1: TDoublePoint; Radius, Sangle, Fangle, cutRadius: Double; cutStyle: integer); // // Tolik 26/05/2017 -- //Procedure FillRect(rect:TDoubleRect;bc,bs:Integer); Procedure FillRect(rect:TDoubleRect; bc,bs:Integer; aTransparency: Integer = 0); // //Tolik 24/11/2019 -- //Function CreateArcRegion(cx,cy,rad,a1,a2:Double):Integer; Function CreateArcRegion(cx,cy,rad,a1,a2:Double): HRGN; //Function CreateDoubleArcRegion(cx,cy,rad1,rad2,a1,a2,a3,a4:Double):Integer; Function CreateDoubleArcRegion(cx,cy,rad1,rad2,a1,a2,a3,a4:Double):HRGN; // Procedure AddBezArcPoints(var dPoints:TDoublePointArr; cp:TDoublePoint;rad,a1,a2:Double;dirPoint:TDoublePoint); //Tolik 24/11/2019 -- Function BezierRegion(bPoints:TDoublePointArr): HRGN; // Procedure drawbezarc(cx,cy,rad,a1,a2:Double;color,awidth,style,bc,bs,arcstyle: integer; var rgn:HRGN; var p1,p2: TDoublePoint;inCombined:Boolean;row:Integer; rowL:double=3.5;rowH:double=1.2); Procedure drawbezelparc(cx,cy,radA,radB,a1,a2,angle:Double;color,awidth,style,bc,bs,arcstyle: integer; var rgn:HRGN; var p1,p2: TDoublePoint;inCombined:Boolean;row:Integer); Procedure drawbezierellipse(cx,cy,radA,radB,angle:Double;color,awidth,style,bc,bs:Integer; var rgn:HRGN; inCombined:Boolean); procedure DrawCircle(cx,cy,rad: Double;color,awidth,style,bc,bs: integer;var rgn:HRGN;inCombined:Boolean;Hatched:Boolean=False);overload; procedure DrawCircle(cp:TDoublePoint;rad:Double;color,awidth,style,bc,bs: integer;var rgn:HRGN;Hatched:Boolean=False);overload; // Tolik -- 19/08/2017 -- Procedure DrawOverLappedCircle(ap1x, ap1y, ap2x, ap2y, radius, CutRadius: Double; acolor, aawidth, style, bcolor, GDIbrs: Integer;var RegHandle:Hrgn; InCombined: Boolean; Hatched: Boolean = False); Procedure DrawOverLappedEllipse(ap1x, ap1y, ap2x, ap2y, radius, radius1, CutRadius, CutRadius1: Double; acolor, aawidth,style,bcolor,GDIbrs: integer;var RegHandle: HRGN); // Procedure DrawCross(p:TdoublePoint;color,awidth,style:Integer;dim:Double;Rotated:Boolean=True); procedure DrawCircle(p1: TDoublePoint;rad: Double);overload; procedure DrawPoint(p1: TDoublePoint);overload; procedure DrawPoint(p1: TDoublePoint;color:TColor);overload; procedure DrawCirclePix(cx,cy,rad,color,awidth,style,bc,bs: integer;var rgn:HRGN);overload; procedure drawbezier(points:TDoublePointArr; nbrPoint,color,awidth,style,brc,brs:integer;Filled,InCombined:Boolean; pattern:Tobject;var RegHandle:HRGN;row:Integer;rowL,rowH:Double;brsBmp:TBitmap=nil);overload; procedure drawbezier(points:TDoublePointArr; color,awidth,style:integer);overload; procedure drawpatbezier(points:TDoublePointArr; nbrPoint,color,awidth,style,brc,brs:integer;Filled:Boolean; pattern:Tobject); procedure drawbezier(p1,p2,p3,p4: TDoublePoint);overload; procedure drawCurve(points: TDoublePointArr; color,awidth,style: integer); procedure drawcurvesegment(p1,p2:TDoublepoint); Procedure TraceText(p1: TDoublePoint;Color:TColor;Text,FontName:String;FontSize:Integer); Procedure DrawCenteredText(p1: TDoublePoint;Color:TColor;Text,FontName:String;FontSize:Integer;Angle:Double);overload; Procedure DrawCenteredText(p1: TDoublePoint;Color:TColor;Text,FontName:String;FontSize:Double;Angle:Double);overload; Procedure DrawCenteredText(p1: TPoint;Color:TColor;Text,FontName:String;FontSize:Double;Angle:Double);overload; Procedure DrawCenteredText(p1: TDoublePoint;Color:TColor;Text,FontName:String;FontSize:Double);overload; Procedure DrawLabel(r1,r2:TDoublePoint;aText: String; afont: Tfont; aheight:Double;pcolor,awidth,style,bc,bs: integer;var rgn:HRGN); Procedure GetTextLens(var TextLen,TextH:Double;atext: string; afont: Tfont;aheight,CWidth,CSpace: double); Function SetCanvasFont(FName:String;FHeight,CWidth,CSpace,Angle:Double; Styles: TFontStyles;Charset:Byte;FColor:TColor):TFont; Procedure ResetCanvasFont(oldFont:TFont); Procedure GDIDrawText(r1,r2,r3,r4:TDoublePoint;Text:String;vAlign:TTextVAlign;hAlign:TTextHAlign); Procedure Drawtext(ap1,ap2,ap3,a4: TDoublePoint;angle:Double; atext: string; afont: Tfont; aheight,CWidth,CSpace: double; var nH,nl:Integer);overload; Procedure Drawtext(ap1,ap2,ap3,a4: TDoublePoint;angle:Double; atext: string; fontName: String;aColor:TColor; aheight,CWidth,CSpace: double; var nH,nl:Integer);overload; Procedure Drawtext(ap1,ap2,ap3,a4: TPoint;angle:Double; atext: string; fontName: String;aColor:TColor; aheight: double);overload; procedure Drawtext(ap1: TDoublePoint; angle: Double; atext,afontName: String; Styles:TFontStyles;aColor:TColor;aheight: double; marx:double = 0;mary:double=0);overload; procedure Drawtext(ap1: TDoublePoint; atext:TstringList; afontName: String;Styles:TFontStyles;aColor:TColor;aheight: double; marx:double = 0;mary:double=0);overload; procedure Drawtext(ap1: TDoublePoint; atext:TstringList; afontName: String;Styles:TFontStyles;aColor:TColor;aheight: double;var Region:HRGN; var tw,th: Double; marx:double = 0;mary:double=0);overload; procedure DrawMtextToCanvas(ap1: TPoint;atext: TstringList; afontName:String; Styles: TFontStyles;aColor: TColor; aSize,aHeight,marX,marY,limitH: Integer; var Region: HRGN; var tw,th: Integer; FCanvas: TCanvas); Procedure TextToRect(p1,p2,p3,p4: TDoublePoint; aText: String; aFont: TFont; CSpace:Double; var w,h: Double); Procedure DrawAlignedText(xp1,xp2: TDoublePoint; atext: string; fontName: TFontName; aColor: integer;aheight: double); Procedure DrawHDim(ap1,ap2,ap3:TDoublepoint; dLabel: String; fontName: TFontName; Styles:TFontStyles;aColor,TextColor: integer; aheight:Double; LStyle:THDimLabelStyle;TextPos:TDimTextPos;et: TEndType; var Reghandle: HRGN); Procedure DrawVDim(ap1,ap2,ap3:TDoublepoint; dLabel: String; fontName: TFontName; Styles:TFontStyles;aColor,TextColor: integer; aheight: Double; LStyle:TVDimLabelStyle;TextPos:TDimTextPos;et:TEndType; var Reghandle: HRGN); Procedure DrawAlignedDim(ap1,ap2,ap3:TDoublepoint; dLabel: String; fontName: TFontName; Styles:TFontStyles;aColor,TextColor: integer; aheight: Double; LStyle:TADimLabelStyle;TextPos:TDimTextPos;et: TEndType; tHorz: Boolean;var Reghandle: HRGN); Procedure DrawCircleDim(ap1,ap2:TDoublepoint; dLabel: String; fontName: TFontName; Styles:TFontStyles;aColor,TextColor: integer; aheight: Double; LStyle:TCDimLabelStyle;TextPos:TDimTextPos;et: TEndType; tHorz: Boolean; DrawOuterGuide,DrawInnerGuide:Boolean; var Reghandle: HRGN); Procedure DrawArcDim(ap1: TDoublePoint;Radius,SAngle,FAngle:Double;dLabel: String; fontName: TFontName; Styles:TFontStyles;aColor,TextColor: integer; aheight,GuideLen: Double; LStyle:TArcDimLabelStyle;var Reghandle: HRGN;var p1,p2: TDoublePoint); Function CreateRectRegion(x1,y1,x2,y2:Double):HRGN; Procedure DrawRTF(re: TRichEdit98; x1,y1,x2,y2: integer); Procedure DrawRTFToCanvas(re: TRichEdit98; x1,y1,x2,y2: Double; xCanvas: Tcanvas; Convert: Boolean); Procedure DrawOLEToCanvas(ole: TOleContainer; x1,y1,x2,y2: Double; xCanvas: Tcanvas; Convert: Boolean); Procedure DrawMetafile(p1,p2,p3,p4: TDoublepoint;color,awidth,style: Integer; metafile: TMetafile; stretch:Boolean;var RegHandle:HRGN); Procedure DrawTransparentMetafile(p1,p2,p3,p4: TDoublepoint;color,awidth,style:Integer; metafile: TMetafile; var RegHandle: HRGN); Procedure DrawMathGraph(cRect:TDoubleRect;cx,cy:Double;color,awidth,style,ScaleColor:Integer; OneUnit:double;Source:String;DrawTick,DrawNumbers,isPolar:Boolean;NumStep:Double); procedure drawselectionpoint(x,y,z: Double; pType: TPointType; dim :double; col : TColor; isXOR:Boolean = False); procedure drawellipse(x,y,a,b,xangle: Double;lines: integer;color,awidth,style,bc,bs: integer; var Reghandle: HRGN; var BoundRect: TDoubleRect);overload; procedure drawEllipse(p1: TDoublePoint;ax,bx: Double;angle:Double);overload; Procedure DrawEllipticArc(x,y,a,b,xangle: Double; startangle: Double; drawangle: Double;lines:integer;color,awidth,style,bc,bs,arcStyle: integer; var lp1,lp2: TPoint;var regHandle: HRGN;var BoundRect: TDoublerect); Procedure DrawFigureIcon(fRect: TDoubleRect; ix,iy: Double;vpos: TIconVertPos;hPos: TIconHorzPos; Icon: Tbitmap); //Tolik 20/10/2021 -- { Procedure DrawPicture(ap1,ap2,ap3,ap4: TDoublepoint;color,awidth,style: integer; isTransparent: Boolean; var Modified: Boolean; Picture : TBitmap; Var Image: TBitmap; var aImageEdited: Boolean; // Tolik 20/04/20108 -- DoFlip:Boolean; isDeformed: Boolean;var RegHandle: HRGN;Tiled:Boolean=False); } Procedure DrawPicture(ap1,ap2,ap3,ap4: TDoublepoint;color,awidth,style: integer; isTransparent: Boolean; var Modified: Boolean; Picture : TBitmap; Var Image: TBitmap; var aImageEdited: Boolean; // Tolik 20/04/20108 -- DoFlip:Boolean; isDeformed: Boolean;var RegHandle: HRGN;Tiled:Boolean=False; GrayColor: TColor = -1); // Procedure DrawBitmap(p1,p2,p3,p4: TDoublepoint;color,awidth,style: integer; isTransparent: Boolean; Bitmap : TBitmap); //Tolik 20/10/2021 -- //Function MakeBitmap(p1,p2,p3,p4: TPoint; pic: TBitmap; var ResultBmp: TBitmap;isTrans:Boolean): Boolean; Function MakeBitmap(p1,p2,p3,p4: TPoint; pic: TBitmap; var ResultBmp: TBitmap;isTrans:Boolean; GrColor: TColor = -1): Boolean; // Function SkewBitmap(p1,p2,p3,p4: TPoint; pic: TBitmap; var ResultBmp: TBitmap;isTrans:Boolean): Boolean; Procedure RotateBitmap(var BitmapOriginal,BitmapRotated: TBitmap; Teta: Double; isTrans: Boolean); Function isRotated(p1,p2,p3,p4: TPoint):Boolean; constructor create; destructor Destroy; override; Procedure Clip(clpRgn:HRGN); Procedure ClipBack; Procedure ClipAnd(clpRgn:HRGN); Procedure SetUpOpenGL(Wnd:HWND); Procedure GLInit; Procedure GLPaint; procedure ClearPens; procedure DefinePrinting; function ExtractExtPenByCanvas: HPEN; //01.11.2011 function IsPointInRegion(aReg: Integer; pt: PDoublePoint): Boolean; Property Canvas:TCanvas read FCanvas write setCanvas; end; procedure PrintBitmap(Canvas: TCanvas; DestRect: TRect; Bitmap: TBitmap; ROP: Integer); procedure stretchDrawGraphics(ACanvas : TCanvas; R : TRect; Graphic: TGraphic; transparent : boolean); Function ProcessRichRecord(DC:HDC; HT:PHandleTable; rec:PEnhMetaRecord; count:integer; param: pointer): integer;stdcall; var psCustomDash : Byte = 7; FDeviceName: string; {Имя устройства} FPageHeightPixel, FPageWidthPixel: Integer; {Высота и ширина страницы} FOrientation: TPrinterOrientation; {Ориентация} FPrintOffsetPixels: TOffset; FPixelsPerMMX, FPixelsPerMMY: Real; MMSize, FPageHeightMM: Integer; TheReport, TheHead, HeadLine, RecordLine, TFname, TLname: string; implementation Uses DrawObjects, U_BaseCommon, U_Layers; var FirstEMRText: Boolean; Constructor TPCDrawEngine.create; begin inherited create; FCanvas := TCanvas.Create; comp := TBitmap.Create; Tag := 0; Isometric:= False; ClipRgn := 0; FPrinting := false; //01.11.2011 FCachePen := false; //01.11.2011 FPens := TStringList.Create; //01.11.2011 FPens.Sorted := true; end; destructor TPCDrawEngine.Destroy; begin ClearPens; FPens.Free; if ClipRgn <> 0 then DeleteObject(ClipRgn); if ExClip <> 0 then DeleteObject(ExClip); // Tolik if Assigned(Comp) then Comp.free; // inherited; end; procedure DrawAlphaAPI(Source: TBitmap; Destination: TCanvas; const X, Y: Integer; const Opacity: Byte = 255); var BlendFunc: TBlendFunction; begin BlendFunc.BlendOp := AC_SRC_OVER; BlendFunc.BlendFlags := 0; BlendFunc.SourceConstantAlpha := Opacity; if Source.PixelFormat = pf32bit then BlendFunc.AlphaFormat := AC_SRC_ALPHA else BlendFunc.AlphaFormat := 0; Windows.AlphaBlend(Destination.Handle, X, Y, Source.Width, Source.Height, Source.Canvas.Handle, 0, 0, Source.Width, Source.Height, BlendFunc); end; // 06/11/2017 Tolik -- если не юзать GDI, то из-за использования BMP-файла может при достижении определенного размера ебнуться, // из-за ограничения винды на размер BMP-файла .... -- старая закомменчена -- смотри ниже procedure DrawOpacityBrush(ACanvas: TCanvas; aRect: TRect; X, Y: Integer; AColor: TColor; Opacity: Byte); var ColorRgb: Integer; ColorR, ColorG, ColorB: Byte; GDIBrush : TGPSolidBrush; Grap : TGPGraphics; //SemiTransBrush : TGPSolidBrush; begin ColorRgb := ColorToRGB(AColor); ColorR := GetRValue(ColorRgb); ColorG := GetGValue(ColorRgb); ColorB := GetBValue(ColorRgb); GDiBrush := TGPSolidBrush.Create(GdiPapi.MakeColor(Opacity, ColorR, ColorG, ColorB)); Grap := TGPGraphics.Create(ACanvas.Handle); Grap.FillRectangle(GDIBrush, GdiPapi.MakeRect(aRect.Left,aRect.Top,(aRect.Right - aRect.Left), (aRect.Bottom - aRect.Top) )); grap.Free; GDIBrush.Free; end; Procedure TPCDrawEngine.setCanvas(value: TCanvas); Begin if value <> FCanvas then EmptyProcedure; FCanvas:= value; // FCanvas.Pen.OnChange := PenCh; {$ifndef designtime} // TExtPen(FCanvas.Pen).Geometric := True; {$endif designtime} End; Procedure TPCDrawEngine.ConvertCoord (var X,Y,Z: Double); begin if assigned(ConvertPoint) then ConvertPoint(x,y,z); end; function TPCDrawEngine.ConvertCoordToPt(const pt: TDoublePoint): TPoint; var xp: TDoublePoint; begin xp.x := pt.X; xp.Y := pt.y; xp.Z := 0; ConvertCoord(xp.x, xp.y, xp.z); Result := Point(Round(xp.x), Round(xp.y)); end; Procedure TPCDrawEngine.ConvertDim (var Dim: Double); begin if assigned(ConvertLen) then ConvertLen(Dim); end; Procedure TPCDrawEngine.DeConvertCoord (var X,Y,Z: Double); begin if assigned(DeConvertPoint) then DeConvertPoint(x,y,z); end; Procedure TPCDrawEngine.DeConvertDim (var Dim: Double); begin if assigned(DeConvertLen) then DeConvertLen(Dim); end; Function TPCDrawEngine.GetVertDirection:Integer; var x1,y1,x2,y2,z: Double; begin x1 := 100; y1 := 100; x2 := 200; y2 := 200; z := 0; ConvertCoord(x1,y1,z); ConvertCoord(x2,y2,z); result := Round((y2-y1)/ abs(y2-y1)); end; Function TPCDrawEngine.GetHorzDirection:Integer; var x1,y1,x2,y2,z: Double; begin x1 := 100; y1 := 100; x2 := 200; y2 := 200; z := 0; ConvertCoord(x1,y1,z); ConvertCoord(x2,y2,z); result := Round((x2-x1)/ abs(x2-x1)); end; Procedure TPCDrawEngine.MoveTo(p:TDoublePoint); begin ConvertCoord(p.x,p.y,p.z); MoveToPix(p.x,p.y); end; Procedure TPCDrawEngine.LineTo(p:TDoublePoint); begin ConvertCoord(p.x,p.y,p.z); LineToPix(p.x,p.y); end; Procedure TPCDrawEngine.MoveToPix(x1,y1:Double); var hPenOld: HPEN; hPen1: HPEN; begin if (FCanvas.Pen.Mode <> pmXor) and (FCanvas.Pen.width > 1) then begin hPen1 := ExtCreatePenMy(FCanvas); hPenOld := SelectObject(FCanvas.Handle, hPen1);//связываем перо с контекстом FCanvas.moveto(Round(x1),Round(y1)); SelectObject(FCanvas.Handle, hPenOld); //восстанавливаем предыдущее состояние if Not FCachePen then //01.11.2011 DeleteObject(hPen1);//удаляем перо end else FCanvas.moveto(Round(x1),Round(y1)); end; Procedure TPCDrawEngine.LineToPix(x1,y1:Double); var hPenOld: HPEN; hPen1: HPEN; begin if (FCanvas.Pen.Mode <> pmXor) and (FCanvas.Pen.width > 1) then begin hPen1 := ExtCreatePenMy(FCanvas); hPenOld := SelectObject(FCanvas.Handle, hPen1);//связываем перо с контекстом FCanvas.LineTo(Round(x1),Round(y1)); SelectObject(FCanvas.Handle, hPenOld); //восстанавливаем предыдущее состояние if Not FCachePen then //01.11.2011 DeleteObject(hPen1);//удаляем перо end else FCanvas.LineTo(Round(x1),Round(y1)); end; Procedure TPCDrawEngine.BezierTo(cx1,cy1,cx2,cy2,ex,ey:Double); var Points: array [0..2] of Windows.Tpoint; z: Double; hPenOld: HPEN; hPen1: HPEN; begin z := 0; ConvertCoord(cx1,cy1,z); ConvertCoord(cx2,cy2,z); ConvertCoord(ex ,ey,z); Points[0] := DP2P(cx1,cy1); Points[1] := DP2P(cx2,cy2); Points[2] := DP2P(ex,ey); if (FCanvas.Pen.Mode <> pmXor) and (FCanvas.Pen.width > 1) then begin hPen1 := ExtCreatePenMy(FCanvas); hPenOld := SelectObject(FCanvas.Handle, hPen1);//связываем перо с контекстом FCanvas.PolyBezierTo(Points); SelectObject(FCanvas.Handle, hPenOld); //восстанавливаем предыдущее состояние if Not FCachePen then //01.11.2011 DeleteObject(hPen1);//удаляем перо end else begin FCanvas.PolyBezierTo(Points); end; end; type PPoints = ^TPoints; TPoints = array[0..0] of TPoint; Function TPCDrawEngine.PolygonRegion(const p: TDoublePointArr):HRGN; var ip: Pointer; i,size: Integer; xp: TdoublePoint; z: Double; begin size := Length(p); GetMem(ip,size*8); for i := 0 to size -1 do begin xp := p[i]; z := 0; ConvertCoord(xp.x,xp.y,z); // Tolik 23/04/2019 -- //PInt(PChar(ip)+i*8+0)^:= Round(xp.x); //PInt(PChar(ip)+i*8+4)^:= Round(xp.y); PInt(PAnsiChar(ip)+i*8+0)^:= Round(xp.x); PInt(PAnsiChar(ip)+i*8+4)^:= Round(xp.y); // end; Result := CreatePolygonRgn(PPoints(ip)^,size,ALTERNATE); FreeMem(ip,size*8); end; Function TPCDrawEngine.PolygonRegion(p1,p2,p3,p4: TDoublePoint):HRGN; var pArr: TDoublePointArr; begin SetLength(pArr,4); pArr[0] := p1; pArr[1] := p2; pArr[2] := p3; pArr[3] := p4; result := PolygonRegion(pArr); end; Function TPCDrawEngine.PolygonRegion(p: TPointArr):HRGN; var ip: Pointer; i,size: Integer; xp:TPoint; begin size := Length(p); GetMem(ip,size*8); for i := 0 to size -1 do begin xp := p[i]; //Tolik 23/04/2019 - - //PInt(PChar(ip)+i*8+0)^:= xp.x; //PInt(PChar(ip)+i*8+4)^:= xp.y; PInt(PAnsiChar(ip)+i*8+0)^:= xp.x; PInt(PAnsiChar(ip)+i*8+4)^:= xp.y; // end; Result := CreatePolygonRgn(PPoints(ip)^,size,ALTERNATE); FreeMem(ip,size*8); end; Procedure TPCDrawEngine.Polygon(const p:TDoublePointArr;var regHandle: HRGN; ADrawPoints: Pointer=nil); var ip: Pointer; i,size: Integer; xp: TDoublePoint; z: Double; px: array of TPoint; begin if ADrawPoints = nil then begin size := Length(p); SetLength(px,size); for i := 0 to size -1 do begin xp := p[i]; ConvertCoord(xp.x,xp.y,xp.z); px[i] := Point(Round(xp.x), Round(xp.y)); end; end; WPolygon(px,regHandle, ADrawPoints); { if RegHandle <> 0 then DeleteObject(regHandle);} end; Procedure TPCDrawEngine.Polyline(p:TDoublePointArr); var ip: Array of Windows.TPoint; i,size: Integer; hPenOld: HPEN; hPen1: HPEN; begin size := Length(p); SetLength(ip,Size); for i := 0 to size -1 do begin ConvertCoord(p[i].x,p[i].y,p[i].z); ip[i] := DP2P(p[i]); end; if (FCanvas.Pen.Mode <> pmXor) and (FCanvas.Pen.width > 1) then begin hPen1 := ExtCreatePenMy(FCanvas); hPenOld := SelectObject(FCanvas.Handle, hPen1);//связываем перо с контекстом FCanvas.Polyline(ip); SelectObject(FCanvas.Handle, hPenOld); //восстанавливаем предыдущее состояние if Not FCachePen then //01.11.2011 DeleteObject(hPen1);//удаляем перо end else begin FCanvas.Polyline(ip); end; end; Procedure TPCDrawEngine.EllipsePix(x1,y1,x2,y2:Double); var hPenOld: HPEN; hPen1: HPEN; begin if (FCanvas.Pen.Mode <> pmXor) and (FCanvas.Pen.width > 1) then begin hPen1 := ExtCreatePenMy(FCanvas); hPenOld := SelectObject(FCanvas.Handle, hPen1);//связываем перо с контекстом FCanvas.Ellipse(DR2R(x1,y1,x2,y2)); SelectObject(FCanvas.Handle, hPenOld); //восстанавливаем предыдущее состояние if Not FCachePen then //01.11.2011 DeleteObject(hPen1);//удаляем перо end else begin FCanvas.Ellipse(DR2R(x1,y1,x2,y2)); end; end; Procedure TPCDrawEngine.RectanglePix(x1,y1,x2,y2:Double); var hPenOld: HPEN; hPen1: HPEN; begin if (FCanvas.Pen.Mode <> pmXor) and (FCanvas.Pen.width > 1) then begin hPen1 := ExtCreatePenMy(FCanvas); hPenOld := SelectObject(FCanvas.Handle, hPen1);//связываем перо с контекстом FCanvas.Rectangle(DR2R(x1,y1,x2,y2)); SelectObject(FCanvas.Handle, hPenOld); //восстанавливаем предыдущее состояние if Not FCachePen then //01.11.2011 DeleteObject(hPen1);//удаляем перо end else begin FCanvas.Rectangle(DR2R(x1,y1,x2,y2)); end; end; procedure TPCDrawEngine.drawline(p1,p2:TDoublePoint;color,awidth,style,row: integer; rowL:Double=3.5;rowH:Double=1.2;rowWhite:Boolean=False); begin FCanvas.pen.color := color; FCanvas.pen.width := awidth; FCanvas.Pen.Style := psSolid; FCanvas.Brush.Style := BSSolid; if rowWhite then begin FCanvas.Brush.Color := clWhite; end else begin FCanvas.Brush.Color := color; end; if row = 1 then drawrow(p1.x,p1.y,p2.x,p2.y,true,rowL,rowH) else if row = 2 then drawrow(p2.x,p2.y,p1.x,p1.y,true,rowL,rowH) else if row = 3 then begin drawrow(p2.x,p2.y,p1.x,p1.y,true,rowL,rowH); drawrow(p1.x,p1.y,p2.x,p2.y,true,rowL,rowH) end else if row = 4 then drawrow(p1.x,p1.y,p2.x,p2.y,false,rowL,rowH) else if row = 5 then drawrow(p2.x,p2.y,p1.x,p1.y,false,rowL,rowH) else if row = 6 then begin drawrow(p2.x,p2.y,p1.x,p1.y,false,rowL,rowH); drawrow(p1.x,p1.y,p2.x,p2.y,false,rowL,rowH) end; FCanvas.brush.color := clNone; FCanvas.brush.style := bsClear; if style = psCustomDash then begin FCanvas.pen.style := psSolid; drawdashline(p1,p2); end else begin FCanvas.pen.style := penstyles[style]; drawline(p1,p2); end; end; Procedure TPCDrawEngine.drawline(x1, y1, x2, y2: Double; color, aWidth, style, row: integer; rowL: Double = 3.5; rowH: Double = 1.2; rowWhite: Boolean = False); begin FCanvas.pen.color := color; FCanvas.pen.width := awidth; FCanvas.brush.color := clNone; FCanvas.brush.style := bsClear; FCanvas.pen.style := penstyles[style]; MoveTo(DoublePoint(x1, y1)); LineTo(DoublePoint(x2, y2)); FCanvas.Pen.Style := psSolid; FCanvas.Brush.Style := BSSolid; if rowWhite then begin FCanvas.Brush.Color := clWhite; end else begin FCanvas.Brush.Color := color; end; if row = 1 then drawrow(x1, y1, x2, y2, true, rowL, rowH) else if row = 2 then drawrow(x2, y2, x1, y1, true, rowL, rowH) else if row = 3 then begin drawrow(x2,y2,x1,y1,true,rowL,rowH); drawrow(x1,y1,x2,y2,true,rowL,rowH) end else if row = 4 then drawrow(x1,y1,x2,y2,false,rowL,rowH) else if row = 5 then drawrow(x2,y2,x1,y1,false) else if row = 6 then begin drawrow(x2,y2,x1,y1,false,rowL,rowH); drawrow(x1,y1,x2,y2,false,rowL,rowH) end; end; Procedure TPCDrawEngine.drawlinePixD(x1,y1,x2,y2: Double;color,aWidth,style,row: integer); begin drawlinePix(Round(x1),Round(y1),Round(x2),Round(y2),color,aWidth,style,row); end; Procedure TPCDrawEngine.drawlinePix(x1,y1,x2,y2,color,aWidth,style,row: integer); var rw,rh: Double; hPenOld: HPEN; hPen1: HPEN; begin FCanvas.pen.color := color; FCanvas.pen.width := awidth; FCanvas.Brush.Style := BSSolid; FCanvas.Brush.Color := color; rw := 3.5; rh := 1.2; ConvertDim(rw); ConvertDim(rh); if row = 1 then drawrowpix(x1,y1,x2,y2,Round(rh),Round(rw),true) else if row = 2 then drawrowPix(x2,y2,x1,y1,Round(rh),Round(rw),true) else if row = 3 then begin drawrowPix(x2,y2,x1,y1,Round(rh),Round(rw),true); drawrowPix(x1,y1,x2,y2,Round(rh),Round(rw),true) end else if row = 4 then drawrowPix(x1,y1,x2,y2,Round(rh),Round(rw),false) else if row = 5 then drawrowPix(x2,y2,x1,y1,Round(rh),Round(rw),false) else if row = 6 then begin drawrowPix(x2,y2,x1,y1,Round(rh),Round(rw),false); drawrowPix(x1,y1,x2,y2,Round(rh),Round(rw),false) end; FCanvas.brush.color := clNone; FCanvas.brush.style := bsClear; FCanvas.pen.style := penstyles[style]; if (FCanvas.Pen.Mode <> pmXor) and (FCanvas.Pen.width > 1) then begin hPen1 := ExtCreatePenMy(FCanvas); hPenOld := SelectObject(FCanvas.Handle, hPen1);//связываем перо с контекстом FCanvas.moveto(x1,y1); FCanvas.lineto(x2,y2); SelectObject(FCanvas.Handle, hPenOld); //восстанавливаем предыдущее состояние if Not FCachePen then //01.11.2011 DeleteObject(hPen1);//удаляем перо end else begin FCanvas.moveto(x1,y1); FCanvas.lineto(x2,y2); end; end; Procedure TPCDrawEngine.drawrow(x1,y1,x2,y2: Double; solid: Boolean;hl:double=5;hh:double=3); var pt : TDoublePointArr; r:HRGN; begin r := 1; SetLength(pt,3); CalcRowPoints(x1,y1,x2,y2,hl,hh,pt[0],pt[1],pt[2]); if solid then Polygon(pt,r) else PolyLine(pt); end; Procedure TPCDrawEngine.drawrowPix(x1,y1,x2,y2,h,w: integer; solid: Boolean); VAR xLineDelta : INTEGER; yLineDelta : INTEGER; pt : array [0..2] of Windows.TPoint; p1,p2,p3 : Windows.TPoint; a,Angle : integer; begin try xLineDelta := x2 - x1; yLineDelta := y2 - y1; if (xLineDelta = 0) and (yLineDelta = 0) then exit; if (h = 0) or (w=0) then exit; p1.x := x2; p1.y := y2; if (xLineDelta < 0) and (yLineDelta = 0) then begin p2.x := p1.x + w; p3.x := p2.x; p2.y := p1.y - h; p3.y := p1.y + h; end else if (xLineDelta > 0) and (yLineDelta = 0) then begin p2.x := p1.x - w; p3.x := p2.x; p2.y := p1.y - h; p3.y := p1.y + h; end else if (xLineDelta = 0) and (yLineDelta > 0) then begin p2.x := p1.x - h; p3.x := p1.x + h; p2.y := p1.y - w; p3.y := p1.y - w; end else if (xLineDelta = 0) and (yLineDelta < 0) then begin p2.x := p1.x - h; p3.x := p1.x + h; p2.y := p1.y + w; p3.y := p1.y + w; end else if (xLineDelta > 0) and (yLineDelta > 0) then begin p2.x := p1.x - w; p3.x := p2.x; p2.y := p1.y - h; p3.y := p1.y + h; //rotate Angle := Round(ArcTan( abs(yLineDelta) / abs(xLineDelta) )* (180/ PI)* 10); p2 := getrelativepointbyangle(-angle,p1,p2); p3 := getrelativepointbyangle(-angle,p1,p3); end else if (xLineDelta < 0) and (yLineDelta > 0) then begin p2.x := p1.x - h; p3.x := p1.x + h; p2.y := p1.y - w; p3.y := p1.y - w; // rotate Angle := 900 - Round(ArcTan( abs(yLineDelta) / abs(xLineDelta) )* (180/ PI)* 10); p2 := getrelativepointbyangle(-angle,p1,p2); p3 := getrelativepointbyangle(-angle,p1,p3); end else if (xLineDelta < 0) and (yLineDelta < 0) then begin p2.x := p1.x + w; p3.x := p2.x; p2.y := p1.y - h; p3.y := p1.y + h; // rotate Angle := Round(ArcTan( abs(yLineDelta) / abs(xLineDelta) )* (180/ PI)* 10); p2 := getrelativepointbyangle(-angle,p1,p2); p3 := getrelativepointbyangle(-angle,p1,p3); end else if (xLineDelta > 0) and (yLineDelta < 0) then begin p2.x := p1.x - h; p3.x := p1.x + h; p2.y := p1.y + w; p3.y := p1.y + w; // rotate Angle := 900 - Round(ArcTan( abs(yLineDelta) / abs(xLineDelta) )* (180/ PI)* 10); p2 := getrelativepointbyangle(-angle,p1,p2); p3 := getrelativepointbyangle(-angle,p1,p3); end ; pt[0] := p2; pt[1] := p1; pt[2] := p3; if solid then FCanvas.Polygon(pt) else FCanvas.PolyLine(pt); except end; end; Procedure TPCDrawEngine.Drawpolyline(points: TDoublePointArr;Closed: Boolean); var r:HRGN; begin r := 1; if closed then polygon(points,r) else polyLine(points); end; Procedure TPCDrawEngine.drawpolyline(points: TDoublePointArr; color,awidth,style,row: integer); var a: integer; xx,yy,y2:glnarray; nbrPoint:Integer; begin nbrPoint := Length(Points); FCanvas.pen.color := color; FCanvas.pen.width := awidth; if row = 1 then drawrow(points[nbrPoint-2].x,points[nbrPoint-2].y,points[nbrPoint-1].x,points[nbrPoint-1].y,true) else if row = 2 then drawrow(points[1].x,points[1].y,points[0].x,points[0].y,true) else if row = 3 then begin drawrow(points[nbrPoint-2].x,points[nbrPoint-2].y,points[nbrPoint-1].x,points[nbrPoint-1].y,true); drawrow(points[1].x,points[1].y,points[0].x,points[0].y,true) end else if row = 4 then drawrow(points[nbrPoint-2].x,points[nbrPoint-2].y,points[nbrPoint-1].x,points[nbrPoint-1].y,false) else if row = 5 then drawrow(points[1].x,points[1].y,points[0].x,points[0].y,false) else if row = 6 then begin drawrow(points[nbrPoint-2].x,points[nbrPoint-2].y,points[nbrPoint-1].x,points[nbrPoint-1].y,false); drawrow(points[1].x,points[1].y,points[0].x,points[0].y,false) end; FCanvas.brush.color := clNone; FCanvas.brush.style := bsClear; FCanvas.pen.color := color; FCanvas.pen.width := awidth; FCanvas.pen.style := penstyles[style]; PolyLine(points); end; procedure TPCDrawEngine.drawrect(x1,y1,x2,y2: Double;color,awidth,style,bc,bs: integer); var p1,p2,p3,p4: TDoublePoint; rgn: HRGN; begin rgn := 1; p1 := DoublePoint(x1,y1); p2 := DoublePoint(x2,y1); p3 := DoublePoint(x2,y2); p4 := DoublePoint(x1,y2); drawrect(p1,p2,p3,p4,color,aWidth,style,bc,bs,rgn) end; procedure TPCDrawEngine.drawrect(p1,p2:TDoublePoint;color,awidth,style,bc,bs: integer); var xp1,xp2: TDoublePoint; rgn: HRGN; begin rgn := 1; xp1 := DoublePoint(p2.x,p1.y); xp2 := DoublePoint(p1.x,p2.y); drawrect(p1,xp1,p2,xp2,color,aWidth,style,bc,bs,rgn) end; procedure TPCDrawEngine.drawrect(p1,p2,p3,p4:TDoublePoint;color,awidth,style,bc,bs: integer;var rgn:HRGN); var points: TDoublePointArr; begin SetLength(points,4); points[0] := p1; points[1] := p2; points[2] := p3; points[3] := p4; DrawPolygon(points,color,awidth,style,bc,bs,rgn); end; Procedure TPCDrawEngine.DrawMathGraph(cRect:TDoubleRect;cx,cy:Double; color,awidth,style,ScaleColor:Integer; OneUnit:double;Source:String; DrawTick,DrawNumbers,isPolar:Boolean;NumStep:Double); var x1,x2,y1,y2,b,w: Double; a: Integer; v: double; parser: TParser; ClpRgn : HRGN; xx,yy: double; tx,px,py,pz : Double; d1,d2 : Integer; TM : TTextMetric; FontRecord : TLogFont; aFont,oldFont : TFont; aHeight,tLen,tStep: Double; Numtext: string; z: Double; begin FCanvas.pen.color := color; FCanvas.pen.width := awidth; FCanvas.pen.style := penstyles[style]; x1 := cRect.left; x2 := cRect.right; y1 := crect.top; y2 := crect.bottom; z := 0; ConvertCoord(x1,y1,z); ConvertCoord(x2,y2,z); ConvertCoord(cx,cy,z); ConvertDim(OneUnit); if x1 > x2 then begin tx := x1; x1 := x2; x2 := tx; end; if y1 > y2 then begin tx := y1; y1 := y2; y2 := tx; end; parser := Tparser.Create(nil); parser.Expression := Source; w := abs(x2-x1); if w = 0 then exit; d1 := Round(x1-cx); d2 := Round(x2-cx); try parser.X := d1/OneUnit; v := parser.Value; except end; px := x1; py := cy - round(v*OneUnit); ClpRgn := CreateRectRgn(Round(x1),Round(y1),Round(x2),Round(y2)); SelectClipRgn(FCanvas.handle,clpRgn); FCanvas.MoveTo(Round(px),Round(py)); for a := d1 to d2 do begin xx := a/OneUnit; try parser.X := xx; v := parser.Value; except end; px := x1 + (a-d1); py := cy - round(v*OneUnit); FCanvas.LineTo(Round(px),Round(py)); end; FCanvas.pen.color := ScaleColor; oldFont := nil; //#From Oleg# //20.09.2010 aFont := nil; //#From Oleg# //20.09.2010 if DrawNumbers then begin oldFont := Fcanvas.font; aFont := Tfont.Create; aFont.Name := 'Tahoma'; aFont.Style := []; aFont.Color := ScaleColor; aFont.Charset := 161; FCanvas.Font := aFont; // Get Font Record GetObject(FCanvas.Font.Handle,sizeof(FontRecord),Addr(FontRecord)); // Set Font Height aHeight := 4; ConvertDim(aHeight); FontRecord.lfHeight := Round(aHeight); // Create Modified Font FCanvas.Font.handle := CreateFontIndirect(FontRecord); end; if NumStep < 1 then NumStep := 1; if DrawTick or DrawNumbers then begin for a := 0 to Round((cy-y1)) do begin if (a mod Round(OneUnit)) = 0 then begin if DrawTick then begin FCanvas.MoveTo(Round(cx)-2,Round(cy)-a); FCanvas.LineTo(Round(cx)+2,Round(cy)-a); end; end; if (a mod Round(OneUnit*NumStep)) = 0 then begin if DrawNumbers and (a<>0) then begin NumText := inttostr(a div Round(OneUnit)); FCanvas.TextOut(Round(cx)+4,Round(cy)-a-Trunc(aHeight/2),NumText); end; end; end; for a := 0 to Round(y2-cy) do begin if (a mod Round(OneUnit)) = 0 then begin if DrawTick then begin FCanvas.MoveTo(Round(cx)-2,Round(cy)+a); FCanvas.LineTo(Round(cx)+2,Round(cy)+a); end; end; if (a mod Round(OneUnit*NumStep)) = 0 then begin if DrawNumbers and (a<>0) then begin NumText := inttostr(-a div Round(OneUnit)); FCanvas.TextOut(Round(cx)+4,Round(cy)+a-Trunc(aHeight / 2),NumText); end; end; end; if IsPolar then begin tStep := round(oneUnit * (pi/2)); NumStep := NumStep * 2; end else tStep := oneUnit; for a := 0 to Round(x2-cx) do begin if (a mod Round(tStep)) = 0 then begin if DrawTick then begin FCanvas.MoveTo(Round(cx)+a,Round(cy)-2); FCanvas.LineTo(Round(cx)+a,Round(cy)+2); end; end; if (a mod Round(tStep*NumStep)) = 0 then begin if DrawNumbers and (a <> 0) then begin if IsPolar then //NumText := inttostr(a div Round(tStep*2))+chr(240) NumText := String(inttostr(a div Round(tStep*2)) + AnsiChar(240)) // Tolik 27/03/2019 -- else NumText := inttostr(a div Round(tStep)); tLen := fCanvas.TextWidth(NumText); FCanvas.TextOut(Round(cx)+a-(Round(tLen) div 2),Round(cy)+2,NumText); end; end; end; for a := 0 to Round(cx-x1) do begin if (a mod Round(tStep)) = 0 then begin if DrawTick then begin FCanvas.MoveTo(Round(cx)-a,Round(cy)-2); FCanvas.LineTo(Round(cx)-a,Round(cy)+2); end; end; if (a mod Round(tStep*NumStep)) = 0 then begin if DrawNumbers and (a <> 0) then begin if IsPolar then //NumText := inttostr(-a div Round(tStep*2))+chr(240) NumText := String(inttostr(-a div Round(tStep*2))+ AnsiChar(240)) else NumText := inttostr(-a div Round(tStep)); tLen := fCanvas.TextWidth(NumText); FCanvas.TextOut(Round(cx)-a-(Round(tLen) div 2),Round(cy)+2,NumText); end; end; end; end; if DrawNumbers then begin Fcanvas.Font := oldFont; afont.Free; end; SelectClipRgn(FCanvas.handle,0); DeleteObject(ClpRgn); end; procedure TPCDrawEngine.drawpolygon(p1,p2,p3,p4:TDoublePoint; color,awidth,style,bc,bs: integer;var rgn: HRGN); var points: TdoublePointArr; begin SetLength(points,4); points[0] := p1; points[1] := p2; points[2] := p3; points[3] := p4; DrawPolygon(points,Color,aWidth,Style,bc,bs,rgn); end; procedure TPCDrawEngine.drawpolygon(p1,p2,p3,p4:TDoublePoint; color,awidth,style,bc,bs: integer); var points: TdoublePointArr; rgn:HRGN; begin rgn := 1; SetLength(points,4); points[0] := p1; points[1] := p2; points[2] := p3; points[3] := p4; DrawPolygon(points,Color,aWidth,Style,bc,bs,rgn); end; Procedure TPCDrawEngine.FillRgn(rgn:HRGN;bc,bs:Integer); var cRgn: HRGN; begin FCanvas.brush.color := bc; FCanvas.brush.style := TBrushStyle(bs); Windows.FillRgn(FCanvas.Handle,rgn,FCanvas.Brush.Handle); end; //procedure TPCDrawEngine.DrawPie(x1, y1, x2, y2 : double; bc, bs, CutStyle: Integer; var rgn:HRGN; cp:TDoublePoint; Fangle, SAngle, Radius, aCutRadius: Double); procedure TPCDrawEngine.DrawPie(bc, bs, CutStyle: Integer; var rgn:HRGN; cp:TDoublePoint; Fangle, SAngle, Radius, aCutRadius: Double); Var p1, p2, p3, p4, cPoint : TDoublePoint; z: Double; pp1, pp2 : TDoublePoint; points: array of TDoublePoint; ipoints: array of TPoint; angle1, angle2: Integer; ArrayLength: Integer; PointToRotate: TDoublePoint; rgn1: HRGN; LeftTopPoint, RightBottomPoint: TDoublePoint; // Tolik 24/12/2019 -- старая закомменчена, см. ниже, здесь попытка сразу выделить всю необходимую память // под смассив точек, а не в цикле, потому что могут быть выебоны Procedure GetPiePoints; var i, cutArrayLength: Integer; cutRadius: double; cutArray: Array of TDoublePoint; p1: TDoublePoint; CanDropAngle: Boolean; begin ArrayLength := 0; SetLength(Points, 0); Angle1 := Round((180/pi)*Sangle); Angle2 := Round((180/pi)*Fangle); if (Angle1 = 0) and (Angle2 = 360) then CanDRopAngle := False else CanDropAngle := True; if CanDropAngle then begin if Angle1 < Angle2 then ArrayLength := Angle2 - Angle1 else begin ArrayLength := (360 - Angle1) + Angle2; end; end else ArrayLength := 360; { if Angle1 = 360 then Angle1 := 0; if Angle2 = 360 then Angle2 := 0;} // Buid PolyLine // big arc SetLength(Points, ArrayLength + 1); ArrayLength := 0; while Angle1 <> Angle2 do begin p1.x := cp.x + Radius; p1.y := cp.y; p1.z := 0; p1 := RotatePoint(cp, p1, (Angle1/180)*PI); inc(ArrayLength); //SetLength(Points, ArrayLength); try Points[ArrayLength - 1].x := p1.x; except On E: Exception do ShowMessage(inttostr(ArrayLength)); end; Points[ArrayLength - 1].y := p1.y; angle1 := angle1 + 1; if CanDropAngle then if angle1 = 360 then if Angle2 <> 360 then angle1 := 0; end; // Last arc Point p1.x := cp.x + Radius; p1.y := cp.y; p1.z := 0; p1 := RotatePoint(cp, p1, Fangle); { if ((CompareValue(p1.x, Points[ArrayLength - 1].x) <> 0) or (CompareValue(p1.y, Points[ArrayLength - 1].y) <> 0)) then begin} inc(ArrayLength); //SetLength(Points, ArrayLength); Points[ArrayLength - 1].x := p1.x; Points[ArrayLength - 1].y := p1.y; // end; // cutting PIESHADOW if aCutRadius = 0 then // no cut -- add center Point begin inc(ArrayLength); SetLength(Points, ArrayLength); Points[ArrayLength - 1].x := cp.x; Points[ArrayLength - 1].y := cp.y; end else begin if CutStyle = 0 then // Linear Cutting begin //p1.x := cp.x + acutRadius; p1.x := cp.x + ABS(acutRadius/cos(2*PI - ABS(((FAngle-SAngle)/2)))); p1.y := cp.y; p1.z := 0; p1 := RotatePoint(cp, p1, FAngle); inc(ArrayLength); SetLength(Points, ArrayLength); Points[ArrayLength - 1].x := p1.x; Points[ArrayLength - 1].y := p1.y; //p1.x := cp.x + acutRadius; //p1.x := cp.x + ABS(acutRadius/cos(ABS(((FAngle-SAngle)/180)/PI))); p1.x := cp.x + ABS(acutRadius/cos(2*PI - ABS(((FAngle-SAngle)/2)))); p1.y := cp.y; p1.z := 0; p1 := RotatePoint(cp, p1, SAngle); inc(ArrayLength); SetLength(Points, ArrayLength); Points[ArrayLength - 1].x := p1.x; Points[ArrayLength - 1].y := p1.y; // to close PolyLine { begin inc(ArrayLength); SetLength(Points, ArrayLength); Points[ArrayLength - 1].x := Points[0].x; Points[ArrayLength - 1].y := Points[0].y; end; } end else if CutStyle = 1 then // arc cutting begin // angles Angle1 := Round((180/pi)*Sangle); Angle2 := Round((180/pi)*Fangle); { if Angle1 = 360 then Angle1 := 0; if Angle2 = 360 then Angle2 := 0;} if (Angle1 = 0) and (Angle2 = 360) then CanDropAngle := False else CanDropAngle := True; if CanDropAngle then begin if Angle1 < Angle2 then cutArrayLength := Angle2 - Angle1 else cutArrayLength := (360 - Angle1) + Angle2; end else cutArrayLength := 360; //cutArrayLength := 0; SetLength(cutArray,cutArrayLength + 1); cutArrayLength := 0; while Angle1 <> Angle2 do begin p1 := DoublePoint(CP.x + acutRadius, CP.y, 0); p1 := RotatePoint(CP,p1,(Angle1/180)*PI); inc(cutArrayLength); //SetLength(cutArray, cutArrayLength); cutArray[cutArrayLength - 1].x := p1.x; cutArray[cutArrayLength - 1].y := p1.y; angle1 := angle1 + 1; if CanDropAngle then if angle1 = 360 then if Angle2 <> 360 then angle1 := 0; end; if CutArrayLength > 0 then begin // Last arc Point p1.x := cp.x + aCutRadius; p1.y := cp.y; p1.z := 0; p1 := RotatePoint(cp, p1, Fangle); { if ((CompareValue(p1.x, cutArray[CutArrayLength - 1].x) <> 0) or (CompareValue(p1.y, cutArray[CutArrayLength - 1].y) <> 0)) then begin} inc(CutArrayLength); SetLength(cutArray, ArrayLength); cutArray[CutArrayLength - 1].x := p1.x; cutArray[CutArrayLength - 1].y := p1.y; // end; SetLength(Points, ArrayLength + cutArrayLength); for i := cutArrayLength - 1 downto 0 do begin inc(ArrayLength); //SetLength(Points, ArrayLength); Points[ArrayLength - 1].x := cutArray[i].x; Points[ArrayLength - 1].y := cutArray[i].y; end; SetLength(cutArray, 0); // free mem end; // to close PolyLine {begin inc(ArrayLength); SetLength(Points, ArrayLength); Points[ArrayLength - 1].x := Points[0].x; Points[ArrayLength - 1].y := Points[0].y; end; } end; end; for i := 0 to ArrayLength - 1 do begin ConvertCoord(Points[i].x,Points[i].y,z); end; end; (* Procedure GetPiePoints; var i, cutArrayLength: Integer; cutRadius: double; cutArray: Array of TDoublePoint; p1: TDoublePoint; CanDropAngle: Boolean; begin ArrayLength := 0; SetLength(Points, 0); Angle1 := Round((180/pi)*Sangle); Angle2 := Round((180/pi)*Fangle); if (Angle1 = 0) and (Angle2 = 360) then CanDRopAngle := False else CanDropAngle := True; { if Angle1 = 360 then Angle1 := 0; if Angle2 = 360 then Angle2 := 0;} // Buid PolyLine // big arc while Angle1 <> Angle2 do begin p1.x := cp.x + Radius; p1.y := cp.y; p1.z := 0; p1 := RotatePoint(cp, p1, (Angle1/180)*PI); inc(ArrayLength); SetLength(Points, ArrayLength); Points[ArrayLength - 1].x := p1.x; Points[ArrayLength - 1].y := p1.y; angle1 := angle1 + 1; if CanDropAngle then if angle1 = 360 then angle1 := 0; end; // Last arc Point p1.x := cp.x + Radius; p1.y := cp.y; p1.z := 0; p1 := RotatePoint(cp, p1, Fangle); { if ((CompareValue(p1.x, Points[ArrayLength - 1].x) <> 0) or (CompareValue(p1.y, Points[ArrayLength - 1].y) <> 0)) then begin} inc(ArrayLength); SetLength(Points, ArrayLength); Points[ArrayLength - 1].x := p1.x; Points[ArrayLength - 1].y := p1.y; // end; // cutting PIESHADOW if aCutRadius = 0 then // no cut -- add center Point begin inc(ArrayLength); SetLength(Points, ArrayLength); Points[ArrayLength - 1].x := cp.x; Points[ArrayLength - 1].y := cp.y; end else begin if CutStyle = 0 then // Linear Cutting begin //p1.x := cp.x + acutRadius; p1.x := cp.x + ABS(acutRadius/cos(2*PI - ABS(((FAngle-SAngle)/2)))); p1.y := cp.y; p1.z := 0; p1 := RotatePoint(cp, p1, FAngle); inc(ArrayLength); SetLength(Points, ArrayLength); Points[ArrayLength - 1].x := p1.x; Points[ArrayLength - 1].y := p1.y; //p1.x := cp.x + acutRadius; //p1.x := cp.x + ABS(acutRadius/cos(ABS(((FAngle-SAngle)/180)/PI))); p1.x := cp.x + ABS(acutRadius/cos(2*PI - ABS(((FAngle-SAngle)/2)))); p1.y := cp.y; p1.z := 0; p1 := RotatePoint(cp, p1, SAngle); inc(ArrayLength); SetLength(Points, ArrayLength); Points[ArrayLength - 1].x := p1.x; Points[ArrayLength - 1].y := p1.y; // to close PolyLine { begin inc(ArrayLength); SetLength(Points, ArrayLength); Points[ArrayLength - 1].x := Points[0].x; Points[ArrayLength - 1].y := Points[0].y; end; } end else if CutStyle = 1 then // arc cutting begin // angles Angle1 := Round((180/pi)*Sangle); Angle2 := Round((180/pi)*Fangle); { if Angle1 = 360 then Angle1 := 0; if Angle2 = 360 then Angle2 := 0;} if (Angle1 = 0) and (Angle2 = 360) then CanDropAngle := False else CanDropAngle := True; cutArrayLength := 0; SetLength(cutArray,0); while Angle1 <> Angle2 do begin p1 := DoublePoint(CP.x + acutRadius, CP.y, 0); p1 := RotatePoint(CP,p1,(Angle1/180)*PI); inc(cutArrayLength); SetLength(cutArray, cutArrayLength); cutArray[cutArrayLength - 1].x := p1.x; cutArray[cutArrayLength - 1].y := p1.y; angle1 := angle1 + 1; if CanDropAngle then if angle1 = 360 then angle1 := 0; end; if CutArrayLength > 0 then begin // Last arc Point p1.x := cp.x + aCutRadius; p1.y := cp.y; p1.z := 0; p1 := RotatePoint(cp, p1, Fangle); { if ((CompareValue(p1.x, cutArray[CutArrayLength - 1].x) <> 0) or (CompareValue(p1.y, cutArray[CutArrayLength - 1].y) <> 0)) then begin} inc(CutArrayLength); SetLength(cutArray, ArrayLength); cutArray[CutArrayLength - 1].x := p1.x; cutArray[CutArrayLength - 1].y := p1.y; // end; for i := cutArrayLength - 1 downto 0 do begin inc(ArrayLength); SetLength(Points, ArrayLength); Points[ArrayLength - 1].x := cutArray[i].x; Points[ArrayLength - 1].y := cutArray[i].y; end; SetLength(cutArray, 0); // free mem end; // to close PolyLine {begin inc(ArrayLength); SetLength(Points, ArrayLength); Points[ArrayLength - 1].x := Points[0].x; Points[ArrayLength - 1].y := Points[0].y; end; } end; end; for i := 0 to ArrayLength - 1 do begin ConvertCoord(Points[i].x,Points[i].y,z); end; end; *) Procedure GetPieBounds; var i : Integer; begin if ArrayLength > 0 then begin LeftTopPoint.x := points[0].x; LeftTopPoint.y := points[0].y; RightBottomPoint.x := points[0].x; RightBottomPoint.y := points[0].y; for i := 1 to ArrayLength - 1 do begin if Comparevalue(LeftTopPoint.x, points[i].x) = 1 then LeftTopPoint.x := points[i].x; if Comparevalue(LeftTopPoint.y, points[i].y) = 1 then LeftTopPoint.y := points[i].y; if Comparevalue(RightBottomPoint.x, points[i].x) = -1 then RightBottomPoint.x := points[i].x; if Comparevalue(RightBottomPoint.y, points[i].y) = -1 then RightBottomPoint.y := points[i].y; end; end; end; Procedure GetCattedPieRegion; var tReg: HRGN; convRad,z: Double; a: integer; begin SetLength(IPoints, ArrayLength); for a := 0 to arrayLength - 1 do ipoints[a] := DP2P(points[a]); tReg := CreatePolygonRgn(ipoints[0],ArrayLength,WINDING); SetLength(points, 0); SetLength(ipoints, 0); //CombineRgn(Rgn,Rgn,treg,RGN_OR); CombineRgn(Rgn,Rgn,treg,RGN_AND); DeleteObject(tReg); end; begin z := 0; FCanvas.brush.color := bc ; // brushColor FCanvas.brush.style := TBrushStyle(bs); // brushStyle cPoint.x := cp.x; cPoint.y := cp.y; if rgn = 0 then begin // прямоугольный регион z := 0; Angle1 := Round((180/pi)*Sangle); Angle2 := Round((180/pi)*Fangle); if (Angle1 = 0) and (Angle2 = 360) then // это если рисовать круги ... begin pp1.x := cp.x - radius; pp1.y := cp.y - radius; pp1.z := 0; pp2.x := cp.x + radius; pp2.y := cp.y + radius; pp2.z := 0; ConvertCoord(pp1.x,pp1.y,pp1.z); ConvertCoord(pp2.x,pp2.y,pp2.z); Rgn := CreateEllipticRgn(Round(pp1.x), Round(pp1.y), Round(pp2.x), Round(pp2.y)); if aCutRadius <> 0 then begin pp1.x := cp.x - aCutRadius; pp1.y := cp.y - aCutRadius; pp1.z := 0; pp2.x := cp.x + aCutRadius; pp2.y := cp.y + aCutRadius; pp2.z := 0; ConvertCoord(pp1.x,pp1.y,pp1.z); ConvertCoord(pp2.x,pp2.y,pp2.z); rgn1 := CreateEllipticRgn(Round(pp1.x), Round(pp1.y), Round(pp2.x), Round(pp2.y)); CombineRgn(Rgn, Rgn, Rgn1, RGN_XOR); DeleteObject(Rgn1); // Tolik 14/01/2025 -- end; end else begin // здесь круг неполный .... GetPiePoints; // точки GetPieBounds; // границы Rgn := CreateRectRgn(Round(LeftTopPoint.x), Round(LeftTopPoint.y), Round(RightBottomPoint.x), Round(RightBottomPoint.y)); // вырезаем сектор GetCattedPieRegion; end; end; end; procedure TPCDrawEngine.DrawPieRGB(x1, y1, x2, y2, x3, y3, x4, y4 : double; bc, bs: Integer; var rgn:HRGN;cp,ap2,ap3:TDoublePoint;FAngle, SAngle, Rad: Double); Var p1, p2, p3, p4, cPoint : TDoublePoint; z: Double; pp1, pp2 : TDoublePoint; points: array of TDoublePoint; ipoints: array of TPoint; angle1, angle2, Angle3: Integer; ArrayLength: Integer; PointToRotate: TDoublePoint; LeftTopPoint, RightBottomPoint: TDoublePoint; Procedure GetPiePoints(aRad: Double); var a: Integer; begin Angle1 := Round((180/pi)*Sangle); Angle2 := Round((180/pi)*Fangle); ArrayLength := 1; SetLength(Points, 1); points[0] := cP; // centerPoint z := 0; while Angle1 <> Angle2 do begin PointToRotate := DoublePoint(CP.x + aRad, CP.y, 0); PointToRotate := RotatePoint(CP,PointToRotate,(Angle1/180)*PI); inc(ArrayLength); SetLength(Points, ArrayLength); Points[ArrayLength - 1 ].x := PointtoRotate.x; Points[ArrayLength - 1 ].y := PointtoRotate.y; Points[ArrayLength - 1 ].z := 0; if angle1 = 360 then angle1 := 0; angle1 := angle1 + 1; end; for a := 0 to ArrayLength - 1 do begin ConvertCoord(Points[a].x,Points[a].y,z); end; end; Procedure GetPieBounds; var i : Integer; begin if ArrayLength > 0 then begin LeftTopPoint.x := points[0].x; LeftTopPoint.y := points[0].y; RightBottomPoint.x := points[0].x; RightBottomPoint.y := points[0].y; for i := 1 to ArrayLength - 1 do begin if Comparevalue(LeftTopPoint.x, points[i].x) = 1 then LeftTopPoint.x := points[i].x; if Comparevalue(LeftTopPoint.y, points[i].y) = 1 then LeftTopPoint.y := points[i].y; if Comparevalue(RightBottomPoint.x, points[i].x) = -1 then RightBottomPoint.x := points[i].x; if Comparevalue(RightBottomPoint.y, points[i].y) = -1 then RightBottomPoint.y := points[i].y; end; end; end; Procedure GetCattedPieRegion; var tReg, tReg1, tReg2: HRGN; convRad,z: Double; a: integer; begin SetLength(IPoints, ArrayLength); for a := 0 to arrayLength - 1 do ipoints[a] := DP2P(points[a]); tReg := CreatePolygonRgn(ipoints[0],ArrayLength,WINDING); // Big Pie to cut fillRgn(FCanvas.Handle, treg, clBlue); // one big SetLength(points, 0); SetLength(ipoints, 0); CombineRgn(Rgn,Rgn,treg,RGN_AND); DeleteObject(tReg); //CombineRgn(TReg,Rgn,treg,RGN_OR); //fillRgn(Rgn, clBlue); // one big GetPiePoints(Rad*0.5); // точки GetPieBounds; // границы SetLength(IPoints, ArrayLength); for a := 0 to arrayLength - 1 do ipoints[a] := DP2P(points[a]); tReg1 := CreatePolygonRgn(ipoints[0],ArrayLength,WINDING); // Little Pie to cut FillRgn(FCanvas.Handle,tReg1, clRed); GetPiePoints(Rad*0.75); // точки GetPieBounds; // границы SetLength(IPoints, ArrayLength); for a := 0 to arrayLength - 1 do ipoints[a] := DP2P(points[a]); tReg2 := CreatePolygonRgn(ipoints[0],ArrayLength,WINDING); // Middle Pie to cut FillRgn(FCanvas.Handle, tReg2, clGreen); CombineRgn(treg,Rgn,treg2,Rgn_Diff); // big part CombineRgn(treg2, treg2, treg1, RGN_Diff); // middle part CombineRgn(Rgn, treg1, treg2, RGN_OR); CombineRgn(Rgn, Rgn, treg, RGN_OR); DeleteObject(tReg); DeleteObject(tReg1); DeleteObject(tReg2); end; begin z := 0; FCanvas.brush.color := clskyBlue;//bc; //FCanvas.brush.style := TBrushStyle(bs); FCanvas.brush.style := bssolid;//bsClear; p1.x := x1; p1.y := y1; p2.x := x2; p2.y := y2; p3.x := x3; p3.y := y3; p4.x := x4; p4.y := y4; cPoint.x := cp.x; cPoint.y := cp.y; if rgn = 0 then begin // прямоугольный регион z := 0; GetPiePoints(Rad); // точки GetPieBounds; // границы Rgn := CreateRectRgn(Round(LeftTopPoint.x), Round(LeftTopPoint.y), Round(RightBottomPoint.x), Round(RightBottomPoint.y)); // вырезаем сектор GetCattedPieRegion; end; end; procedure TPCDrawEngine.DrawPieShadow(ap1: TDoublePoint; Radius, Sangle, Fangle, cutRadius: Double; cutStyle: integer); var Points: TDoublePointArr; ArrayLength: Integer; i: Integer; z: double; p1: TDoublePoint; procedure CalcPoints; var i, Angle1, Angle2, cutArrayLength: Integer; p1: TDoublePoint; cutArray: array of TDoublePoint; onePoint, twoPoints : boolean; begin ArrayLength := 0; SetLength(Points, 0); Angle1 := Round((180/pi)*Sangle); Angle2 := Round((180/pi)*Fangle); if Angle1 = 360 then Angle1 := 0; if Angle2 = 360 then Angle2 := 0; OnePoint := False; TwoPoints := False; if (Comparevalue(Fangle, Sangle) = 0) and (Radius = 0) then OnePoint := True; if not OnePoint then if ((CompareValue(Fangle, Sangle) = 0) and (Radius <> 0)) then // if two points TwoPoints := True; if OnePoint then begin ArrayLength := 1; SetLength(Points, 1); // center Point to draw point Points[0].x := ap1.x; Points[0].y := ap1.y; exit; end; if TwoPoints then begin ArrayLength := 2; SetLength(Points, 2); // center Point Points[0].x := ap1.x; Points[0].y := ap1.y; // Next point to draw Line p1.x := AP1.x + Radius; p1.y := ap1.y; p1 := RotatePoint(ap1, p1,Fangle); // does not mean (Fangle = Sangle) Points[1].x := p1.x; Points[1].y := p1.y; exit; end; // else buid PolyLine // big arc while Angle1 <> Angle2 do begin p1.x := AP1.x + Radius; p1.y := ap1.y; p1 := RotatePoint(AP1, p1, (Angle1/180)*PI); inc(ArrayLength); SetLength(Points, ArrayLength); Points[ArrayLength - 1].x := p1.x; Points[ArrayLength - 1].y := p1.y; angle1 := angle1 + 1; if angle1 = 360 then angle1 := 0; end; // Last arc Point p1.x := AP1.x + Radius; p1.y := ap1.y; p1 := RotatePoint(AP1, p1, Fangle); {if ((CompareValue(p1.x, Points[ArrayLength - 1].x) <> 0) or (CompareValue(p1.y, Points[ArrayLength - 1].y) <> 0)) then begin} inc(ArrayLength); SetLength(Points, ArrayLength); Points[ArrayLength - 1].x := p1.x; Points[ArrayLength - 1].y := p1.y; {end;} // cutting PIESHADOW if CutRadius = 0 then // no cut -- add center Point begin inc(ArrayLength); SetLength(Points, ArrayLength); Points[ArrayLength - 1].x := ap1.x; Points[ArrayLength - 1].y := ap1.y; end else begin if CutStyle = 0 then // Linear Cutting begin p1.x := ap1.x + cutRadius; p1.y := ap1.y; p1 := RotatePoint(ap1, p1, FAngle); inc(ArrayLength); SetLength(Points, ArrayLength); Points[ArrayLength - 1].x := p1.x; Points[ArrayLength - 1].y := p1.y; p1.x := ap1.x + cutRadius; p1.y := ap1.y; p1 := RotatePoint(ap1, p1, SAngle); inc(ArrayLength); SetLength(Points, ArrayLength); Points[ArrayLength - 1].x := p1.x; Points[ArrayLength - 1].y := p1.y; // to close PolyLine { begin inc(ArrayLength); SetLength(Points, ArrayLength); Points[ArrayLength - 1].x := Points[0].x; Points[ArrayLength - 1].y := Points[0].y; end; } end else if CutStyle = 1 then // arc cutting begin // angles Angle1 := Round((180/pi)*Sangle); Angle2 := Round((180/pi)*Fangle); if Angle1 = 360 then Angle1 := 0; if Angle2 = 360 then Angle2 := 0; cutArrayLength := 0; SetLength(cutArray,0); while Angle1 <> Angle2 do begin p1 := DoublePoint(ap1.x + cutRadius, ap1.y, 0); p1 := RotatePoint(ap1,p1,(Angle1/180)*PI); inc(cutArrayLength); SetLength(cutArray, cutArrayLength); cutArray[cutArrayLength - 1].x := p1.x; cutArray[cutArrayLength - 1].y := p1.y; angle1 := angle1 + 1; if angle1 = 360 then angle1 := 0; end; if CutArrayLength > 0 then begin // Last arc Point p1.x := AP1.x + CutRadius; p1.y := ap1.y; p1 := RotatePoint(AP1, p1, Fangle); { if ((CompareValue(p1.x, cutArray[CutArrayLength - 1].x) <> 0) or (CompareValue(p1.y, cutArray[CutArrayLength - 1].y) <> 0)) then begin} inc(CutArrayLength); SetLength(cutArray, ArrayLength); cutArray[CutArrayLength - 1].x := p1.x; cutArray[CutArrayLength - 1].y := p1.y; // end; for i := cutArrayLength - 1 downto 0 do begin inc(ArrayLength); SetLength(Points, ArrayLength); Points[ArrayLength - 1].x := cutArray[i].x; Points[ArrayLength - 1].y := cutArray[i].y; end; SetLength(cutArray, 0); // free mem end; // to close PolyLine {begin inc(ArrayLength); SetLength(Points, ArrayLength); Points[ArrayLength - 1].x := Points[0].x; Points[ArrayLength - 1].y := Points[0].y; end; } end; end; end; begin CalcPoints; if ArrayLength > 0 then begin FCanvas.Pen.Style := psDash; FCanvas.Pen.Width := 1; FCanvas.Pen.Color := ClLime; if ArrayLength = 1 then DrawPoint(Points[0], clLime) else if ArrayLength = 2 then begin FCanvas.Pen.Style := psDash; FCanvas.Pen.Width := 1; FCanvas.Pen.Color := ClLime; z := 0; DrawLine(Points[0], Points[1]); end else if ArrayLength > 2 then begin FCanvas.Pen.Style := psDash; FCanvas.Pen.Width := 1; FCanvas.Pen.Color := ClLime; //drawpolyline(points, False); drawpolyline(points, True); end; end; SetLength(Points,0); end; procedure TPCDrawEngine.drawpolygon(Const points:TDoublePointArr; color,awidth,style,bc,bs: integer;var rgn: HRGN;brsBmp:TBitmap=nil; ADrawPoints: Pointer=nil); var a: integer; hbr,oldbr: HBRUSH; Begin FCanvas.pen.color := color; FCanvas.pen.width := awidth; FCanvas.pen.style := penstyles[style]; FCanvas.brush.color := bc; FCanvas.brush.style := TBrushStyle(bs); hbr := 0; oldBr := 0; if assigned(brsBmp) then begin hbr := CreatePatternBrush(brsBmp.Handle); oldBr := SelectObject(FCanvas.Handle,hBr); end; PolyGon(points,rgn, ADrawPoints); if assigned(brsBmp) then begin SelectObject(FCanvas.Handle,oldBr); DeleteObject(hbr); end; End; procedure TPCDrawEngine.drawCurve(points: TDoublePointArr;color,awidth,style: integer); var i,size: Integer; Begin FCanvas.pen.color := color; FCanvas.pen.width := awidth; FCanvas.pen.style := penstyles[style]; FCanvas.brush.style := bsClear; size := Length(points); for i := 0 to size -2 do DrawCurveSegment(points[i],points[i+1]); End; procedure TPCDrawEngine.DrawCircle(cx,cy,rad:Double;color,awidth,style,bc,bs: integer;var rgn:HRGN;inCombined:Boolean;hatched:Boolean=False); begin DrawCircle(DoublePOint(cx,cy),rad,color,awidth,style,bc,bs,rgn,Hatched); end; procedure TPCDrawEngine.DrawCircle(cp:TDoublePoint;rad:Double;color,awidth,style,bc,bs: integer;var rgn:HRGN;Hatched:Boolean=False); var cx,cy,cz: Double; done: Boolean; p1,p2,xp1,xp2: TDoublePoint; xrad: Double; icnt: Integer; hPenOld: HPEN; hPen1: HPEN; begin With FCanvas do begin Pen.Style := TPenStyle(style); Pen.Width := aWidth; Pen.Color := color; FCanvas.Brush.Color := bc; FCanvas.Brush.Style:= TBrushStyle(bs); cx := cp.x; cy := cp.y; cz := cp.z; ConvertCoord(cx,cy,cz); xRad := rad; ConvertDim(xrad); if (FCanvas.Pen.Mode <> pmXor) and (FCanvas.Pen.width > 1) then begin hPen1 := ExtCreatePenMy(FCanvas); hPenOld := SelectObject(FCanvas.Handle, hPen1);//связываем перо с контекстом Ellipse(Round(cx-xrad),Round(cy-xrad),Round(cx+xrad),Round(cy+xrad)); SelectObject(FCanvas.Handle, hPenOld); //восстанавливаем предыдущее состояние if Not FCachePen then //01.11.2011 DeleteObject(hPen1);//удаляем перо end else begin Ellipse(Round(cx-xrad),Round(cy-xrad),Round(cx+xrad),Round(cy+xrad)); end; if rgn = 0 then begin rgn := CreateEllipticRgn(Round(cx-xrad),Round(cy-xrad),Round(cx+xrad),Round(cy+xrad)); end; if (hatched) and (rgn <> 1) and (rgn <> 0) then begin SelectClipRgn(Fcanvas.Handle,rgn); p1 := MOvePoint(cp,-rad,-rad); p2 := MOvePoint(cp,rad,-rad); repeat xp1 := p1; xp2 := p2; xp1 := RotatePoint(cp,xp1,pi/4); xp2 := RotatePoint(cp,xp2,pi/4); ExtendLine(xp1,xp2,10); GetLineCircleIntersection(xp1,xp2,cp,rad,xp1,xp2,icnt,true); if icnt = 2 then begin DrawLine(xp1,xp2,color,1,ord(psSolid),0); ShrinkLine(xp1,xp2,0.4); end; p1 := MovePoint(p1,0,1.2); p2 := MovePoint(p2,0,1.2); until p2.y > (cp.y+rad+1.2); SelectClipRgn(Fcanvas.Handle,0); end; end; end; Procedure TPCDrawEngine.DrawOverLappedCircle(ap1x, ap1y, ap2x, ap2y, radius, CutRadius: Double; acolor, aawidth, style, bcolor, GDIbrs: Integer;var RegHandle:Hrgn; InCombined: Boolean; Hatched: Boolean = False); var treg: HRGN; begin FCanvas.Brush.Style := TBrushStyle(1); FCanvas.Brush.Color := bcolor; RegHandle := CreateEllipticRgn(Round(ap1x - radius), Round(ap1y - radius), Round(ap1x + radius), Round(ap1y + radius)); if CutRadius > 0 then if CompareValue(CutRadius, radius) = -1 then begin treg := CreateEllipticRgn(Round(ap2x - Cutradius), Round(ap2y - Cutradius), Round(ap2x + Cutradius), Round(ap2y + Cutradius)); CombineRgn(RegHandle, RegHandle,treg,RGN_XOR); DeleteObject(Treg); Windows.FillRgn(FCanvas.Handle,RegHandle, FCanvas.Brush.Handle); end; end; Procedure TPCDrawEngine.DrawOverLappedEllipse(ap1x, ap1y, ap2x, ap2y, radius,radius1, CutRadius,CutRadius1: Double; acolor, aawidth,style,bcolor,GDIbrs: integer;var RegHandle: HRGN); var treg: HRGN; cp: TDoublePoint; LPoint, RPoint: TDoublePoint; z: Double; begin FCanvas.Brush.Style := TBrushStyle(1); FCanvas.Brush.Color := bcolor; cp.x := ap1x; cp.y := ap1y; z := 0; LPoint.x := Round(ap1x - radius); LPoint.y := Round(ap1y - radius1); RPoint.x := Round(ap1x + radius); RPoint.y := Round(ap1y + radius1); ConvertCoord(LPoint.x,LPoint.y,z); ConvertCoord(RPoint.x,RPoint.y,z); RegHandle := CreateEllipticRgn(Round(LPoint.x), Round(LPoint.y), Round(RPoint.x), Round(RPoint.y)); if CutRadius > 0 then if CutRadius1 > 0 then if CompareValue(CutRadius, radius) = -1 then if CompareValue(CutRadius1, radius1) = -1 then begin cp.x := ap2x; cp.y := ap2y; LPoint.x := Round(ap2x - CutRadius); LPoint.y := Round(ap2y - CutRadius1); RPoint.x := Round(ap2x + CutRadius); RPoint.y := Round(ap2y + CutRadius1); ConvertCoord(LPoint.x,LPoint.y,z); ConvertCoord(RPoint.x,RPoint.y,z); treg := CreateEllipticRgn(Round(LPoint.x), Round(LPoint.y), Round(RPoint.x), Round(RPoint.y)); CombineRgn(RegHandle, RegHandle,treg,RGN_XOR); DeleteObject(Treg); end; Windows.FillRgn(FCanvas.Handle,RegHandle, FCanvas.Brush.Handle); end; procedure TPCDrawEngine.DrawCircle(p1: TDoublePoint;rad: Double); var cx,cy,z: Double; hPenOld: HPEN; hPen1: HPEN; begin cx := p1.x; cy := p1.y; z :=p1.z; ConvertCoord(cx,cy,z); ConvertDim(rad); if (FCanvas.Pen.Mode <> pmXor) and (FCanvas.Pen.width > 1) then begin hPen1 := ExtCreatePenMy(FCanvas); hPenOld := SelectObject(FCanvas.Handle, hPen1);//связываем перо с контекстом FCanvas.Ellipse(Round(cx-rad),Round(cy-rad),Round(cx+rad),Round(cy+rad)); SelectObject(FCanvas.Handle, hPenOld); //восстанавливаем предыдущее состояние if Not FCachePen then //01.11.2011 DeleteObject(hPen1);//удаляем перо end else begin FCanvas.Ellipse(Round(cx-rad),Round(cy-rad),Round(cx+rad),Round(cy+rad)); end; end; Procedure TPCDrawEngine.DrawCross(p:TdoublePoint;color,awidth,style:Integer;Dim:Double;Rotated:Boolean=True); var ap1,ap2: TDoublePoint; begin ap1 := DoublePOint(p.x,p.y-Dim); ap2 := DoublePOint(p.x,p.y+Dim); if rotated then ap1 := RotatePoint(p,ap1,pi/4); if rotated then ap2 := RotatePoint(p,ap2,pi/4); DrawLine(ap1,ap2,color,aWidth,style,0); ap1 := DoublePOint(p.x-Dim,p.y); ap2 := DoublePOint(p.x+Dim,p.y); if rotated then ap1 := RotatePoint(p,ap1,pi/4); if rotated then ap2 := RotatePoint(p,ap2,pi/4); DrawLine(ap1,ap2,color,aWidth,style,0); end; procedure TPCDrawEngine.DrawPoint(p1: TDoublePoint); var cx,cy,z: Double; begin cx := p1.x; cy := p1.y; z:= 0; ConvertCoord(cx,cy,z); FCanvas.Ellipse(Round(cx-1),Round(cy-1),Round(cx+1),round(cy+1)); end; procedure TPCDrawEngine.DrawPoint(p1: TDoublePoint;color:TColor); begin Fcanvas.Pen.Color := color; Fcanvas.Brush.Color := color; Fcanvas.Brush.Style := bsSolid; Fcanvas.Pen.Style := psSolid; DrawPoint(p1); end; procedure TPCDrawEngine.DrawCirclePix(cx,cy,rad,color,awidth,style,bc,bs: integer;var rgn:HRGN); begin FCanvas.pen.color := color; FCanvas.pen.width := awidth; FCanvas.pen.style := penstyles[style]; FCanvas.brush.color := bc; FCanvas.brush.style := TBrushStyle(bs); FCanvas.Ellipse(cx-rad,cy-rad,cx+rad,cy+rad); if rgn = 0 then begin rgn := CreateEllipticRgn(cx-rad,cy-rad,cx+rad,cy+rad); end; end; Procedure TPCDrawEngine.drawbezierellipse(cx,cy,radA,radB,angle:Double;color,awidth,style,bc,bs:Integer; var rgn:HRGN; inCombined:Boolean); var Points: T2DPointArray; P: TDoublePointArr; I: integer; cnt : integer; r: Integer; xRect:TDoubleRect; closed: Boolean; hPenOld: HPEN; hPen1: HPEN; begin FCanvas.pen.color := color; FCanvas.pen.width := awidth; FCanvas.pen.style := penstyles[style]; FCanvas.brush.color := clNone; FCanvas.brush.style := bsClear; if (FCanvas.Pen.Mode <> pmXor) and (FCanvas.Pen.width > 1) then begin hPen1 := ExtCreatePenMy(FCanvas); hPenOld := SelectObject(FCanvas.Handle, hPen1);//связываем перо с контекстом BezierElpArcPoints(Points,cx,cy,Rada,Radb,angle,0,2*pi); cnt := Length(Points); SetLength(p,cnt); for I := 0 to cnt-1 do begin P[I].X := Points[I].X; P[I].Y := Points[I].Y; end; DrawBezier(P,cnt,color,awidth,style,bc,bs,True,inCombined,nil,Rgn,0,0,0); SelectObject(FCanvas.Handle, hPenOld); //восстанавливаем предыдущее состояние if Not FCachePen then //01.11.2011 DeleteObject(hPen1);//удаляем перо end else begin BezierElpArcPoints(Points,cx,cy,Rada,Radb,angle,0,2*pi); cnt := Length(Points); SetLength(p,cnt); for I := 0 to cnt-1 do begin P[I].X := Points[I].X; P[I].Y := Points[I].Y; end; DrawBezier(P,cnt,color,awidth,style,bc,bs,True,inCombined,nil,Rgn,0,0,0); end; end; Procedure TPCDrawEngine.drawBezElpArc(cx,cy,radA,radB,a1,a2,angle:Double;color,awidth,style,bc,bs,arcstyle: integer; var rgn:HRGN; var p1,p2: TDoublePoint;inCombined:Boolean;row:Integer); var Points: T2DPointArray; P: TDoublePointArr; I: integer; cnt,cntA : integer; r: Integer; xRect:TDoubleRect; closed: Boolean; hPenOld: HPEN; hPen1: HPEN; begin FCanvas.pen.color := color; FCanvas.pen.width := awidth; FCanvas.pen.style := penstyles[style]; FCanvas.brush.color := clNone; FCanvas.brush.style := bsClear; Closed := (a1 = a2) or (abs(a2-a1) = 2*pi) or (arcStyle <> 0); if (FCanvas.Pen.Mode <> pmXor) and (FCanvas.Pen.width > 1) then begin hPen1 := ExtCreatePenMy(FCanvas); hPenOld := SelectObject(FCanvas.Handle, hPen1);//связываем перо с контекстом BezierElpArcPoints(Points,cx,cy,Rada,Radb,angle,a1,a2); cnt := Length(Points); cntA := 0; if arcStyle = 1 then cntA := 6 else if ArcStyle = 2 then cntA := 3; SetLength(p,cnt+cntA); for I := 0 to cnt-1 do begin P[I].X := Points[I].X; P[I].Y := Points[I].Y; end; if arcStyle = 1 then begin P[cnt-1+1] := P[cnt-1]; P[cnt-1+2] := DoublePoint(cx,cy); P[cnt-1+3] := DoublePoint(cx,cy); P[cnt-1+4] := DoublePoint(cx,cy); P[cnt-1+5] := P[0]; P[cnt-1+6] := P[0]; cntA := 6; end else if ArcStyle = 2 then begin P[cnt-1+1] := P[cnt-1]; P[cnt-1+2] := P[0]; P[cnt-1+3] := P[0]; cntA := 3; end; p1 := DoublePoint(p[0].x,p[0].y); p2 := DoublePoint(p[cnt-1].x,p[cnt-1].y); DrawBezier(P,cnt+cntA,color,awidth,style,bc,bs,True,inCombined,nil,Rgn,row,3.5,1.2); SelectObject(FCanvas.Handle, hPenOld); //восстанавливаем предыдущее состояние if Not FCachePen then //01.11.2011 DeleteObject(hPen1);//удаляем перо end else begin BezierElpArcPoints(Points,cx,cy,Rada,Radb,angle,a1,a2); cnt := Length(Points); cntA := 0; if arcStyle = 1 then cntA := 6 else if ArcStyle = 2 then cntA := 3; SetLength(p,cnt+cntA); for I := 0 to cnt-1 do begin P[I].X := Points[I].X; P[I].Y := Points[I].Y; end; if arcStyle = 1 then begin P[cnt-1+1] := P[cnt-1]; P[cnt-1+2] := DoublePoint(cx,cy); P[cnt-1+3] := DoublePoint(cx,cy); P[cnt-1+4] := DoublePoint(cx,cy); P[cnt-1+5] := P[0]; P[cnt-1+6] := P[0]; cntA := 6; end else if ArcStyle = 2 then begin P[cnt-1+1] := P[cnt-1]; P[cnt-1+2] := P[0]; P[cnt-1+3] := P[0]; cntA := 3; end; p1 := DoublePoint(p[0].x,p[0].y); p2 := DoublePoint(p[cnt-1].x,p[cnt-1].y); DrawBezier(P,cnt+cntA,color,awidth,style,bc,bs,True,inCombined,nil,Rgn,row,3.5,1.2); end; end; // Tolik 24/11/2019 -- //Function TPCDrawEngine.BezierRegion(bPoints:TDoublePointArr):Integer; Function TPCDrawEngine.BezierRegion(bPoints:TDoublePointArr): HRGN; // var I,a: integer; cnt: Integer; x,y,z: Double; iPoints: Array of TPoint; begin cnt := Length(bPoints); z := 0; SetLength(iPoints,cnt); for a := 0 to cnt-1 do begin x := bPoints[a].x;y := bPoints[a].y; ConvertCoord(x,y,z); iPoints[a] := DP2P(x,y); end; BeginPath(FCanvas.Handle); FCanvas.PolyBezier(iPoints); EndPath(FCanvas.Handle); Result := PathToRegion(FCanvas.Handle); end; // Tolik 24/11/2019 -- //Function TPCDrawEngine.CreateDoubleArcRegion(cx,cy,rad1,rad2,a1,a2,a3,a4:Double):Integer; Function TPCDrawEngine.CreateDoubleArcRegion(cx,cy,rad1,rad2,a1,a2,a3,a4:Double):HRGN; // var Points: T2DPointArray; P: TDoublePointArr; I,a: integer; cnt,pcnt : integer; r: Integer; x,y,z: Double; iPoints: Array of TPoint; begin BezierArcPoints(Points,cx,cy,Rad1,a1,a2); cnt := Length(Points); SetLength(p,cnt); for I := 0 to cnt-1 do begin P[I].X := Points[I].X; P[I].Y := Points[I].Y; end; BezierArcPoints(Points,cx,cy,Rad2,a3,a4); pcnt := Length(Points); SetLength(p,cnt+2); P[Cnt-2+2] := P[Cnt-1]; P[Cnt-1+2] := DoublePoint(Points[pcnt-1].x,Points[pcnt-1].y); cnt := cnt+2; SetLength(p,cnt+pcnt); for I := 0 to pcnt-1 do begin P[cnt+I].X := Points[pcnt-1-I].X; P[cnt+I].Y := Points[pcnt-1-I].Y; end; cnt := cnt+pCnt; SetLength(p,cnt+3); P[Cnt-3+3] := P[Cnt-1]; P[Cnt-2+3] := P[0]; P[Cnt-1+3] := P[0]; cnt := cnt+3; SetLength(iPoints,cnt); for a := 0 to cnt-1 do begin x := p[a].x;y := p[a].y; z := 0; ConvertCoord(x,y,z); iPoints[a] := DP2P(x,y); end; //FCanvas.Pen.Color := clRed; //FCanvas.Pen.Style := psSolid; //Fcanvas.Pen.Mode := pmCopy; //FCanvas.PolyBezier(iPoints); //FCanvas.Polygon(iPoints); BeginPath(FCanvas.Handle); FCanvas.PolyBezier(iPoints); EndPath(FCanvas.Handle); Result := PathToRegion(FCanvas.Handle); end; Procedure TPCDrawEngine.AddBezArcPoints(var dPoints:TDoublePointArr; cp:TDoublePoint;rad,a1,a2:Double; dirPoint:TDoublePoint); var cnt,bcnt,i,index: Integer; Points: T2DPointArray; inverted : Boolean; d1,d2: Double; begin cnt := Length(dPoints); BezierArcPoints(Points,cp.x,cp.y,Rad,a1,a2); inverted := false; bcnt := Length(Points); if (bcnt > 1) then begin d1 := GetLineLenght(dirPoint,DoublePOint(points[0].x,points[0].y)); d2 := GetLineLenght(dirPoint,DoublePOint(points[bcnt-1].x,points[bcnt-1].y)); if d2 > d1 then inverted := true; end; SetLength(dPoints,cnt+bcnt); for i:= 0 to bcnt-1 do begin index := i; if inverted then index := bcnt-1-i; dPoints[cnt+i] := DoublePOint(Points[index].X,Points[index].Y); end; end; // Tolik 24/11/2019 -- //Function TPCDrawEngine.CreateArcRegion(cx,cy,rad,a1,a2:Double):Integer; Function TPCDrawEngine.CreateArcRegion(cx,cy,rad,a1,a2:Double): HRGN; // var Points: T2DPointArray; P: TDoublePointArr; I,a: integer; cnt : integer; r: Integer; x,y,z: Double; iPoints: Array of TPoint; begin BezierArcPoints(Points,cx,cy,Rad,a1,a2); cnt := Length(Points); SetLength(p,cnt+6); for I := 0 to cnt-1 do begin P[I].X := Points[I].X; P[I].Y := Points[I].Y; end; P[cnt-1+1] := P[cnt-1]; P[cnt-1+2] := DoublePoint(cx,cy); P[cnt-1+3] := DoublePoint(cx,cy); P[cnt-1+4] := DoublePoint(cx,cy); P[cnt-1+5] := P[0]; P[cnt-1+6] := P[0]; cnt := cnt+6; SetLength(iPoints,cnt); for a := 0 to cnt-1 do begin x := p[a].x;y := p[a].y; z := 0; ConvertCoord(x,y,z); iPoints[a] := DP2P(x,y); end; BeginPath(FCanvas.Handle); FCanvas.PolyBezier(iPoints); EndPath(FCanvas.Handle); Result := PathToRegion(FCanvas.Handle); end; Procedure TPCDrawEngine.drawbezarc(cx,cy,rad,a1,a2:Double;color,awidth,style,bc,bs,arcstyle: integer; var rgn:HRGN; var p1,p2: TDoublePoint; Incombined:Boolean;row:Integer; rowL:double=3.5;rowH:double=1.2); var Points: T2DPointArray; P: TDoublePointArr; I: integer; cnt,cntA : integer; r: Integer; hPenOld: HPEN; hPen1: HPEN; // Tolik 05/09/2017 -- CanvasPenColor, CanvasBrushColor: Integer; // begin // Tolik 05/09/2017 -- CanvasPenColor := FCanvas.pen.color; CanvasBrushColor := FCanvas.brush.color; // FCanvas.pen.color := color; FCanvas.pen.width := awidth; FCanvas.pen.style := penstyles[style]; FCanvas.brush.color := clNone; FCanvas.brush.style := bsClear; if (FCanvas.Pen.Mode <> pmXor) and (FCanvas.Pen.width > 1) then begin hPen1 := ExtCreatePenMy(FCanvas); hPenOld := SelectObject(FCanvas.Handle, hPen1);//связываем перо с контекстом BezierArcPoints(Points,cx,cy,Rad,a1,a2); cnt := Length(Points); cntA := 0; if arcStyle = 1 then cntA := 6 else if ArcStyle = 2 then cntA := 3; SetLength(p,cnt+cntA); for I := 0 to cnt-1 do begin P[I].X := Points[I].X; P[I].Y := Points[I].Y; end; if arcStyle = 1 then begin P[cnt-1+1] := P[cnt-1]; P[cnt-1+2] := DoublePoint(cx,cy); P[cnt-1+3] := DoublePoint(cx,cy); P[cnt-1+4] := DoublePoint(cx,cy); P[cnt-1+5] := P[0]; P[cnt-1+6] := P[0]; cntA := 6; end else if ArcStyle = 2 then begin P[cnt-1+1] := P[cnt-1]; P[cnt-1+2] := P[0]; P[cnt-1+3] := P[0]; cntA := 3; end; p1 := DoublePoint(p[0].x,p[0].y); p2 := DoublePoint(p[cnt-1].x,p[cnt-1].y); DrawBezier(P,cnt+cntA,color,awidth,style,bc,bs,True,inCombined,nil,Rgn,row,rowL,rowH); SelectObject(FCanvas.Handle, hPenOld); //восстанавливаем предыдущее состояние if Not FCachePen then //01.11.2011 DeleteObject(hPen1);//удаляем перо end else begin BezierArcPoints(Points,cx,cy,Rad,a1,a2); cnt := Length(Points); cntA := 0; if arcStyle = 1 then cntA := 6 else if ArcStyle = 2 then cntA := 3; SetLength(p,cnt+cntA); for I := 0 to cnt-1 do begin P[I].X := Points[I].X; P[I].Y := Points[I].Y; end; if arcStyle = 1 then begin P[cnt-1+1] := P[cnt-1]; P[cnt-1+2] := DoublePoint(cx,cy); P[cnt-1+3] := DoublePoint(cx,cy); P[cnt-1+4] := DoublePoint(cx,cy); P[cnt-1+5] := P[0]; P[cnt-1+6] := P[0]; cntA := 6; end else if ArcStyle = 2 then begin P[cnt-1+1] := P[cnt-1]; P[cnt-1+2] := P[0]; P[cnt-1+3] := P[0]; cntA := 3; end; try p1 := DoublePoint(p[0].x,p[0].y); p2 := DoublePoint(p[cnt-1].x,p[cnt-1].y); except end; try //07.10.2011 DrawBezier(P,cnt+cntA,color,awidth,style,bc,bs,True,inCombined,nil,Rgn,row,rowL,rowH); except on E: Exception do AddExceptionToLogEx('TPCDrawEngine.drawbezarc', E.Message); end; end; // Tolik -- 05/09/2017 -- //FCanvas.pen.color := CanvasPenColor; //FCanvas.brush.color := CanvasBrushColor; // end; Procedure TPCDrawEngine.DrawEllipse(x,y, // center a,b, // axis length xangle: Double; // rotation angle in radiant lines: integer; // number of lines color,awidth,style,bc,bs: integer; var regHandle: HRGN; var BoundRect: TDoubleRect); var sinAngle : real; cosAngle : real; theta : real; xp,yp : real; xr, yr : Double; li : integer; points : TDoublePointArr; z: Double; hPenOld: HPEN; hPen1: HPEN; begin sinAngle := sin (xangle); cosAngle := cos (xangle); FCanvas.pen.color := color; FCanvas.pen.width := awidth; FCanvas.pen.style := penstyles[style]; FCanvas.brush.color := bc; FCanvas.brush.style := TBrushStyle(bs); if xangle = 0 then begin BoundRect := DoubleRect(x-a,y-b,x+a,y+b); end; if xangle = 0 then begin z := 0; ConvertCoord(x,y,z);ConvertDim(a);ConvertDim(b); if (FCanvas.Pen.Mode <> pmXor) and (FCanvas.Pen.width > 1) then begin hPen1 := ExtCreatePenMy(FCanvas); hPenOld := SelectObject(FCanvas.Handle, hPen1);//связываем перо с контекстом FCanvas.Ellipse(Round(x-a),Round(y-b),round(x+a),Round(y+b)); SelectObject(FCanvas.Handle, hPenOld); //восстанавливаем предыдущее состояние if Not FCachePen then //01.11.2011 DeleteObject(hPen1);//удаляем перо end else begin FCanvas.Ellipse(Round(x-a),Round(y-b),round(x+a),Round(y+b)); end; if RegHandle = 0 then RegHandle := CreateEllipticRgn(Round(x-a),Round(y-b),round(x+a),Round(y+b)); end else begin BoundRect.Left := x; BoundRect.Right := x; BoundRect.Top := y; BoundRect.Bottom := y; SetLength(points,lines+1); for li := 0 to lines do begin theta := (li/lines) * 2*PI; // angle step xp := a * cos(theta); // ellipse point yp := b * sin(theta); // rotate ellipse point around center xr := (x - xp * cosAngle + yp * sinAngle); yr := (y + xp * sinAngle + yp * cosAngle); points[li].x := xr; points[li].y := yr; if xr > BoundRect.Right then BoundRect.Right := xr else if xr< BoundRect.Left then BoundRect.Left := xr; if yr > BoundRect.Bottom then BoundRect.Bottom := yr else if yr < BoundRect.Top then BoundRect.Top := yr; end; Polygon(points,RegHandle); end; end; Procedure TPCDrawEngine.DrawFigureIcon(fRect: TDoubleRect; ix,iy: Double;vpos: TIconVertPos;hPos: TIconHorzPos; Icon: Tbitmap); var x,y,xx,yy,z: Double; mRect: Trect; sx,sy,pw,ph: Integer; begin z := 0; x := fRect.Left; y := fRect.Top; ConvertCoord(x,y,z); xx := fRect.Right; yy := fRect.Bottom; ConvertCoord(xx,yy,z); ConvertDim(ix);ConvertDim(iy); pw := Icon.Width; ph := Icon.Height; if x > xx then begin mRect.Left := Round(xx); mRect.Right := Round(x); end else begin mRect.Right := Round(xx); mRect.Left := Round(x); end; if y > yy then begin mRect.Top := Round(yy); mRect.Bottom := Round(y); end else begin mRect.Bottom := Round(yy); mRect.Top := Round(y); end; case vPos of vposTop : sy := mRect.Top+Round(iy); vposBottom: sy := mRect.Bottom-ph-Round(iy); vposMiddle: sy := (mRect.Bottom+mRect.Top) div 2 - (ph div 2) - Round(iy); end; case hPos of hposLeft : sx := mRect.Left+Round(ix); hposRight : sx := mRect.Right-pw-Round(ix); hposMiddle: sx := (mRect.Right+mRect.Left) div 2 - (pw div 2) - Round(ix); end; Fcanvas.Draw(sx,sy,Icon); end; Procedure TPCDrawEngine.DrawEllipticArc( x,y, // center a,b, // axis length xangle: Double; // rotation angle in radiant startangle : Double; drawangle : double; lines: integer; // number of lines color,awidth,style,bc,bs,arcstyle: integer; var lp1,lp2: TPoint; var regHandle: HRGN; var BoundRect: TDoubleRect); var sinAngle : real; cosAngle : real; tanAngle : real; angle : real; theta : real; xp,yp : real; xr, yr : Double; li : integer; stpoint,enpoint: Tpoint; points : TDoublePointArr; begin FCanvas.pen.color := color; FCanvas.pen.width := awidth; FCanvas.pen.style := penstyles[style]; if arcstyle <> 0 then begin FCanvas.Brush.Color := bc; FCanvas.Brush.Style := TBrushStyle(bs); end; sinAngle := sin (angle); cosAngle := cos (angle); tanAngle := tan (angle); If arcstyle = 1 then SetLength(points,lines+1) else SetLength(points,lines); for li := 0 to lines-1 do begin theta := ((li/(lines-1)) * ((DrawAngle)*(PI/1800))) + (StartAngle+1800)* (PI/1800); // angle step xp := a * cos(theta); // ellipse point yp := b * sin(theta); // rotate ellipse point around center xr := x - xp * cosAngle + yp * sinAngle; yr := y + xp * sinAngle + yp * cosAngle; if li = 0 then BoundRect := DoubleRect(xr,yr,xr,yr); points[li].x := xr; points[li].y := yr; if xr > BoundRect.Right then BoundRect.Right := xr else if xr< BoundRect.Left then BoundRect.Left := xr; if yr > BoundRect.Bottom then BoundRect.Bottom := yr else if yr < BoundRect.Top then BoundRect.Top := yr; end; If arcstyle = 1 then begin points[lines].x := x; points[lines].y := y; if x > BoundRect.Right then BoundRect.Right := x else if x< BoundRect.Left then BoundRect.Left := x; if y > BoundRect.Bottom then BoundRect.Bottom := y else if y < BoundRect.Top then BoundRect.Top := y; PolyGon(points,RegHandle); end else if arcstyle = 2 then Polygon(points,regHandle) else if arcstyle = 0 then PolyLine(points); end; procedure TPCDrawEngine.drawpatbezier(points:TDoublePointArr; nbrPoint,color,awidth,style,brc,brs:integer;Filled:Boolean; pattern:Tobject); var a: integer; tx,px,py : real; t : array[1..4] of real; mcol,mrow: integer; pntx,pnty: array[1..4] of integer; rDist,difDist,pDist: Double; x,y,i,k,b: Integer; sPoint: Tpoint; cPoints: array of TPoint; conP:Tpoint; p1,p2,p3,p4: TDoublePoint; li,pi,pf:TDoublePoint; LastIndex : Integer; xPattern: Tpattern; pa,pb: TDoublePoint; ang: real; r:Integer; pCnt,xCnt: Integer; res: Integer; iPoints: Array of TPoint; rem,lLen,cWidth,gw,pw: Double; isLine: Boolean; procedure FlushLine(isObjects:Boolean); var n: Integer;Scale:Double; pwOld: Double; begin pwOld := pW; lLen := GetLineLenght(p1,p4); xCnt := Trunc((lLen+gw) / pDist); if xcnt = 0 then begin pw := lLen; xcnt := 1; end else begin rem := lLen - (xCnt*pw) - ((xcnt-1)*gw); pW := pw + (rem / xCnt); end; pi := p1; cWidth := 0; Scale := pw/pwOld; for n := 1 to xCnt do begin rDist := GetLinePatch(p1,p4,pw+gw,cWidth,pi,pf); if isObjects then xPattern.DrawObjects(Self,pi,pf,Scale) else xPattern.Draw(Self,pi,pf,Scale); pi := pf; end; end; procedure FlushBezier(isObjects:Boolean); begin LastIndex := 0; xCnt := 0; pCnt := 0; repeat rDist := GetBezierPatch(p1,p2,p3,p4,pDist,LastIndex,pi,pf,false,res); pCnt := pCnt +1; Until LastIndex = res; if (pCnt > 1) and (rDist < (pdist * 0.9)) then begin pCnt := pCnt -1; if rDist < (pdist / 2) then begin pDist := pDist + round(rDist/pCnt); end else begin pDist := ((pDist * pCnt)+rDist) / (pcnt+1); pCnt := pCnt+1; end; end; LastIndex := 0; xCnt := 0; repeat xCnt := xCnt +1; if xCnt = pCnt then rDist := GetBezierPatch(p1,p2,p3,p4,pDist,LastIndex,pi,pf,True,res) else rDist := GetBezierPatch(p1,p2,p3,p4,pDist,LastIndex,pi,pf,False,res); if isObjects then xPattern.DrawObjects(Self,pi,pf,rDist/pDist) else xPattern.Draw(Self,pi,pf,rDist/pDist); Until LastIndex = res; end; begin res := 500; xPattern := Tpattern(pattern); FCanvas.pen.style := psSolid; pDist := xPattern.pWidth+xPattern.Gap; if pDist > 0 then begin if xPattern.Vector.Segments.Count > 0 then begin a := 0; xPattern.StartDraw(Self,Points[0]); repeat p1 := Points[a];inc(a);p2 := Points[a];inc(a);p3 := Points[a];inc(a); p4 := Points[a]; gw := xPattern.Gap; pw := xPattern.pWidth; if (p1.x = p2.x) and (p1.y = p2.y) and (p3.x = p4.x) and (p3.y = p4.y) then FlushLine(false) else FlushBezier(false); until a >= nbrPoint-1; end; if xPattern.Vector.Objects.Count > 0 then begin a := 0; xPattern.StartDraw(Self,Points[0]); repeat p1 := Points[a];inc(a);p2 := Points[a];inc(a);p3 := Points[a];inc(a); p4 := Points[a]; gw := xPattern.Gap; pw := xPattern.pWidth; if (p1.x = p2.x) and (p1.y = p2.y) and (p3.x = p4.x) and (p3.y = p4.y) then FlushLine(true) else FlushBezier(true); until a >= nbrPoint-1; end; end; end; procedure TPCDrawEngine.drawbezier(points:TDoublePointArr; color,awidth,style:integer); var rgn: HRGN; begin rgn := 1; DrawBezier(Points,Length(Points),color,aWidth,style,0,ord(bsClear),False,False,nil,rgn,0,0,0); end; procedure TPCDrawEngine.drawbezier(points:TDoublePointArr; nbrPoint,color,awidth,style,brc,brs:integer;Filled,InCombined:Boolean; pattern:Tobject;var RegHandle:HRGN; row:Integer;rowL,rowH:Double;brsBmp:TBitmap=nil); var a: integer; iPoints: Array of TPoint; x,y,z: Double; usepath: Boolean; p: TDoublePoint; rt: Integer; oldbr,hbr: HBRUSH; begin //usepath := filled and (not inCombined); usepath := (not inCombined); hbr := 0; if filled and assigned(brsBmp) then begin hbr := CreatePatternBrush(brsBmp.Handle); end; FCanvas.pen.color := color; FCanvas.pen.width := awidth; FCanvas.Brush.Style := bsClear; SetLength(iPoints,nbrPoint); for a := 0 to nbrPoint-1 do begin x := points[a].x;y := points[a].y;z := 0; ConvertCoord(x,y,z); iPoints[a] := DP2P(x,y); end; if usepath then BeginPath(FCanvas.Handle); rt := 0; if row in [1,2,3] then rt := 1 else if row in [4,5,6] then rt := 4; if row in [2,3,5,6] then begin p:= GetBezierBegin(points[0],points[1],points[2],points[3],5,500); DrawLine(p.x,p.y,points[0].x,points[0].y,color,1,ord(psDot),rt,rowL,rowH); end; if row in [1,3,4,6] then begin p:= GetBezierEnd(points[nbrPoint-4],points[nbrPoint-3],points[nbrPoint-2],points[nbrPoint-1],5,500); DrawLine(p.x,p.y,points[nbrPoint-1].x,points[nbrPoint-1].y,color,1,ord(psDot),rt,rowL,rowH); end; if Pattern = nil then begin FCanvas.pen.style := penstyles[style]; FCanvas.PolyBezier(iPoints); end else begin drawpatbezier(points,nbrPoint,color,awidth,style,brc,brs,Filled, pattern); end; if (usepath) then begin EndPath(FCanvas.Handle); FCanvas.pen.color := color; FCanvas.pen.width := awidth; FCanvas.Brush.Color := brc; FCanvas.Brush.Style := TBrushStyle(brs); if hbr <> 0 then begin oldBr := SelectObject(FCanvas.Handle,hbr); end; if FCanvas.Brush.Style = bsClear then begin StrokePath(FCanvas.Handle); end else begin StrokeAndFillPath(FCanvas.Handle); end; if hbr <> 0 then begin SelectObject(FCanvas.Handle,oldBr); DeleteObject(hbr); end; end; if usepath and (RegHandle = 0) then begin BeginPath(FCanvas.Handle); FCanvas.PolyBezier(iPoints); EndPath(FCanvas.Handle); RegHandle := PathToRegion(FCanvas.Handle); end; end; Procedure TPCDrawEngine.DrawTransparentMetafile(p1,p2,p3,p4: TDoublepoint; color,awidth,style: Integer; metafile: TMetafile;var RegHandle: HRGN); Var xmax,ymax,xmin,ymin: Double; tP,pn: TDoublePoint; ang: real; flipMode:TFlipModes; xRect:Trect; ptr: Pointer; iPoints: Array [0..4] of TPoint; x,y,z: Double; Begin flipMode := []; FCanvas.pen.style := penstyles[style]; FCanvas.Pen.Mode := pmCopy; FCanvas.pen.width := awidth; FCanvas.pen.color := color; FCanvas.brush.color := clNone; FCanvas.Brush.Style := bsClear; if p1.x > p2.x then begin tp := p1; p1 := p2; p2 := tp; //////// tp := p3; p3 := p4; p4 := tp; flipMode := flipMode + [fmHorz]; end; if p1.y > p4.y then begin tp := p1; p1 := p4; p4 := tp; //////// tp := p3; p3 := p2; p2 := tp; flipMode := flipMode + [fmVert]; end; if RegHandle = 0 then begin z := 0; x := p1.x; y := p1.y; ConvertCoord(x,y,z); iPoints[0] := DP2P(x,y); x := p2.x; y := p2.y; ConvertCoord(x,y,z); iPoints[1] := DP2P(x,y); x := p3.x; y := p3.y; ConvertCoord(x,y,z); iPoints[2] := DP2P(x,y); x := p4.x; y := p4.y; ConvertCoord(x,y,z); iPoints[3] := DP2P(x,y); RegHandle := CreatePolyGonRgn(iPoints,4,1); end; ConvertCoord(p1.x,p1.y,z); ConvertCoord(p2.x,p2.y,z); ConvertCoord(p3.x,p3.y,z); ConvertCoord(p4.x,p4.y,z); ang := getRadOfLine(p1,p2); if ang <> 0 then begin RotateCanvas(FCanvas.handle,ang); p1 := RotatePoint(DoublePoint(0,0),DoublePoint(p1.x,p1.y),-1*ang); p2 := RotatePoint(DoublePoint(0,0),DoublePoint(p2.x,p2.y),-1*ang); p3 := RotatePoint(DoublePoint(0,0),DoublePoint(p3.x,p3.y),-1*ang); p4 := RotatePoint(DoublePoint(0,0),DoublePoint(p4.x,p4.y),-1*ang); end; xmax := MaxValue([p1.x,p2.x,p3.x,p4.x]); ymax := MaxValue([p1.y,p2.y,p3.y,p4.y]); xmin := MinValue([p1.x,p2.x,p3.x,p4.x]); ymin := MinValue([p1.y,p2.y,p3.y,p4.y]); //if flipMode = [fmHorz] then // xrect := DR2R(xmax,ymin,xmin,ymax) //else if flipMode = [fmVert] then // xrect := DR2R(xmin,ymax,xmax,ymin) //else if flipMode = [fmVert,fmHorz] then // xrect := DR2R(xmax,ymax,xmin,ymin) //else xrect := Dr2R(xmin,ymin,xmax,ymax); FirstEMRText := False; EnumEnhMetafile(FCanvas.Handle,Metafile.handle,@ProcessRichRecord,ptr,xRect); if ang <> 0 then begin ResetCanvas(FCanvas.handle) end; End; Procedure TPCDrawEngine.DrawMetafile(p1, p2, p3, p4: TDoublepoint; color,awidth, style: integer; metafile: TMetafile; stretch: Boolean; var RegHandle: HRGN); Var xmax,ymax,xmin,ymin:Double; tP,pn: TDoublePoint; ang: real; flipMode:TFlipModes; xRect:TRect; iPoints: Array [0..4] of TPoint; x,y,z: Double; Begin flipMode := []; FCanvas.pen.style := penstyles[style]; FCanvas.Pen.Mode := pmCopy; FCanvas.pen.width := awidth; FCanvas.pen.color := color; FCanvas.brush.color := clNone; FCanvas.Brush.Style := bsClear; ConvertCoord(p1.x, p1.y, z); ConvertCoord(p2.x, p2.y, z); ConvertCoord(p3.x, p3.y, z); ConvertCoord(p4.x, p4.y, z); // IGOR -- 19/12/2018 -- приводит к перевороту подписи, если углы примерно 90(180, 270, 0, 360...) и разница между координатами может быть очень маленькая // НО! Она все же будет, поэтому, чтобы отсечь "мелкие" значение, которые приводят к перевороту границ текста, увеличена константа для разницы координат //if (p1.x - p2.x) > 0.0001 then if (p1.x - p2.x) > 0.01 then begin tp := p1; p1 := p2; p2 := tp; //////// tp := p3; p3 := p4; p4 := tp; flipMode := flipMode + [fmHorz]; end; // IGOR -- 19/12/2018 -- приводит к перевороту подписи, если углы примерно 90(180, 270, 0, 360...) и разница между координатами может быть очень маленькая // НО! Она все же будет, поэтому, чтобы отсечь "мелкие" значение, которые приводят к перевороту границ текста, увеличена константа для разницы координат //if (p1.y - p4.y) > 0.0001 then if (p1.y - p4.y) > 0.01 then begin tp := p1; p1 := p4; p4 := tp; //////// tp := p3; p3 := p2; p2 := tp; flipMode := flipMode + [fmVert]; end; if RegHandle = 0 then begin iPoints[0] := DP2P(p1); iPoints[1] := DP2P(p2); iPoints[2] := DP2P(p3); iPoints[3] := DP2P(p4); RegHandle := CreatePolyGonRgn(iPoints, 4, 1); end; // flipMode := []; ang := getRadOfLine(p1,p2); if ang <> 0 then begin RotateCanvas(FCanvas.handle,ang); p1 := RotatePoint(DoublePoint(0,0), p1, -ang); p2 := RotatePoint(DoublePoint(0,0), p2, -ang); p3 := RotatePoint(DoublePoint(0,0), p3, -ang); p4 := RotatePoint(DoublePoint(0,0), p4, -ang); end; xmax := MaxValue([p1.x, p2.x, p3.x, p4.x]); ymax := MaxValue([p1.y, p2.y, p3.y, p4.y]); xmin := MinValue([p1.x, p2.x, p3.x, p4.x]); ymin := MinValue([p1.y, p2.y, p3.y, p4.y]); if flipMode = [fmHorz] then xrect := DR2R(xmax,ymin,xmin,ymax) else if flipMode = [fmVert] then xrect := DR2R(xmin,ymax,xmax,ymin) else if flipMode = [fmVert,fmHorz] then xrect := DR2R(xmax,ymax,xmin,ymin) else xrect := Dr2R(xmin,ymin,xmax,ymax); xrect.right :=xRect.right + 2; xrect.Bottom :=xRect.Bottom + 2; if stretch then begin FCanvas.StretchDraw(xRect, Metafile); // Metafile.SaveToFile('C:\Projects\СКС\!WmfTest\megagovno.wmf'); end else FCanvas.Draw(Round(xmin), Round(ymin), Metafile); if ang <> 0 then begin ResetCanvas(FCanvas.handle); end; End; Procedure TPCDrawEngine.DrawBitmap(p1,p2,p3,p4: TDoublepoint;color,awidth,style: integer; isTransparent: Boolean; Bitmap : TBitmap); var xRect: TRect; z: Double; Begin z := 0; ConvertCoord(p1.x,p1.y,z); ConvertCoord(p2.x,p2.y,z); ConvertCoord(p3.x,p3.y,z); ConvertCoord(p4.x,p4.y,z); xRect := DR2R(p1.x,p1.y,p3.x,p3.y); Bitmap.Transparent := isTransparent; if isPrinting then begin if isTransparent then begin comp.Width := Bitmap.width; comp.Height := Bitmap.height; BitBlt(comp.canvas.handle,0,0,comp.width,comp.height,PrintBmp.canvas.handle,0,0,SRCCOPY); comp.canvas.StretchDraw(Rect(0,0,comp.width,comp.height),bitmap); PrintBitmap(FCanvas,xRect,comp,SRCCOPY); end else begin PrintBitmap(FCanvas,xRect,Bitmap,SRCCOPY); end; end else begin FCanvas.StretchDraw(xRect,Bitmap); end; end; //Tolik 20/10/2021 -- { Procedure TPCDrawEngine.DrawPicture(ap1,ap2,ap3,ap4: TDoublepoint; color,awidth,style: integer; isTransparent: Boolean; var Modified: Boolean; Picture : TBitmap; Var Image: TBitmap; var aImageEdited: Boolean; // Tolik 20/04/20108 -- doFlip: Boolean;isDeformed: Boolean; var RegHandle: HRGN;Tiled:Boolean=False); } Procedure TPCDrawEngine.DrawPicture(ap1,ap2,ap3,ap4: TDoublepoint; color,awidth,style: integer; isTransparent: Boolean; var Modified: Boolean; Picture : TBitmap; Var Image: TBitmap; var aImageEdited: Boolean; // Tolik 20/04/20108 -- doFlip: Boolean;isDeformed: Boolean; var RegHandle: HRGN;Tiled:Boolean=False; GrayColor: TColor = -1); // Var p1,p2,p3,p4: TPoint; xmax,ymax,xmin,ymin,rop: integer; cRect: TRect; NB,NG,NR: Integer; RowOriginal : pRGBArray; bitmap: TBitmap; tP: TPoint; clpcreated :Boolean; UseImage,rotated: Boolean; parr: Array [0..3] of Tpoint; z: Double; xRect: Trect; rad: Double; xp1,xp2,xp3,xp4: TDoublePoint; outofscr : Boolean; tmpImg: TBitmap; useimg: TBitmap; xw,xh: Integer; r: Double; iw,ih,dx,dy: Integer; ixmin,ixmax,iymin,iymax: Integer; oxmin,oymin,oxmax,oymax: Integer; clprgn:HRGN; Begin z := 0; Rotated := False; // Tolik 17/11/2017 -- ConvertCoord(ap1.x,ap1.y,z); ConvertCoord(ap2.x,ap2.y,z); ConvertCoord(ap3.x,ap3.y,z); ConvertCoord(ap4.x,ap4.y,z); p1 := DP2P(ap1); p2 := DP2P(ap2); p3 := DP2P(ap3); p4 := DP2P(ap4); // Tolik 17/11/2017 -- if p1.x >= p2.x then Rotated := true; // if p1.x > p2.x then begin tp := p1; p1 := p2; p2 := tp; //////// tp := p3; p3 := p4; p4 := tp; end; if p1.y > p4.y then begin tp := p1; p1 := p4; p4 := tp; //////// tp := p3; p3 := p2; p2 := tp; end; clpcreated := false; parr[0] := p1; parr[1] := p2; parr[2] := p3; parr[3] := p4; if RegHandle = 0 then RegHandle := CreatePolygonRgn(parr,4,ALTERNATE); clprgn := CreatePolygonRgn(parr,4,ALTERNATE); if (Picture = nil) then exit; // Tolik 20/12/2019 -- //FCanvas.pen.style := penstyles[style]; if Style = -1 then FCanvas.pen.style := penstyles[0] else if ((Style > -1) and (Style > (Length(Penstyles) - 1))) then FCanvas.pen.style := penstyles[0] else FCanvas.pen.style := penstyles[style]; // FCanvas.Pen.Mode := pmCopy; FCanvas.pen.width := awidth; FCanvas.pen.color := color; FCanvas.brush.color := clNone; FCanvas.Brush.Style := bsClear; Picture.Transparent := False; UseImage := False; // Tolik 17/11/2017 -- if not Rotated then // Rotated := IsRotated(p1,p2,p3,p4); if isDeformed then begin If modified then begin SkewBitmap(p1,p2,p3,p4,Picture,Image,isTransParent); image.Transparent := isTransparent; end; end else //Tolik 20/10/2021 -- //if Rotated then begin // If modified then // -- Tolik 17/11/2017 -- if aImageEdited then // Tolik 20/04/2018 -- begin //Tolik 17/11/2017 -- // MakeBitmap(p1,p2,p3,p4,Picture,Image,isTransParent); MakeBitmap(DP2P(ap1),DP2P(ap2),DP2P(ap3),DP2P(ap4),Picture,Image,isTransParent, GrayColor); // image.Transparent := isTransparent; aImageEdited := False; // Tolik 20/04/2018 -- end; end; //Tolik 20/10/2021 -- //UseImage := Rotated or isDeformed; UseImage := Rotated or isDeformed or (GrayColor <> -1); // if not useImage then Picture.Transparent := isTransparent; xmax := MaxIntValue([p1.x,p2.x,p3.x,p4.x]); ymax := MaxIntValue([p1.y,p2.y,p3.y,p4.y]); xmin := MinIntValue([p1.x,p2.x,p3.x,p4.x]); ymin := MinIntValue([p1.y,p2.y,p3.y,p4.y]); outofscr := false; xRect := FCanvas.ClipRect; if ((xMin < 0) and (xMax < 0)) or ((xmin > xRect.right) and (xMax > xRect.right)) or ((yMin < 0) and (yMax < 0)) or ((yMin > xRect.bottom) and (yMax > xRect.bottom)) then outofscr := true; if useImage then useimg := image else useimg := picture; tmpimg := nil; if (not outofscr) and ((xMin < 0) or (xMax > xRect.Right) or (yMin < 0) or (yMax > xRect.Bottom)) then begin xw := xMax - xMin; xh := yMax - yMin; tmpimg := TBitmap.Create; tmpimg.Assign(useimg); oxmin := xmin; oymin := ymin; oymax := ymax; oxmax := xmax; if xMin < 0 then xMin := 0; if xMax > xRect.Right then xMax := xRect.Right; if yMin < 0 then yMin := 0; if yMax > xRect.Bottom then yMax := xRect.Bottom; dx := xmin-oxmin; r := dx/xw; ixmin := 0+ round(useimg.width * r); dx := oxmax-xmax; r := dx/xw; ixmax := useimg.width-round(useimg.width * r); dy := ymin-oymin; r := dy/xh; iymin := 0+ round(useimg.height * r); dy := oymax-ymax; r := dy/xh; iymax := useimg.height-round(useimg.height * r); r := (xmax-xmin)/xw; tmpimg.Width := round(tmpimg.Width *r); r := (ymax-ymin)/xh; tmpimg.height := round(tmpimg.height *r); tmpimg.Canvas.CopyRect(Rect(0,0,tmpimg.Width,tmpimg.Height),useimg.Canvas,Rect(ixmin,iymin,ixmax,iymax)); useimg := tmpimg; end; if not outofscr then begin ClipAnd(ClpRgn); //SelectClipRgn(FCanvas.handle,clprgn); if isPrinting then begin if isTransparent then begin comp.Width := useimg.width; comp.Height := useimg.height; BitBlt(comp.canvas.handle,0,0,comp.width,comp.height,PrintBmp.canvas.handle,0,0,SRCCOPY); comp.canvas.StretchDraw(Rect(0,0,comp.width,comp.height),useimg); PrintBitmap(FCanvas,Rect(xmin,ymin,xmax,ymax),comp,SRCCOPY); end else begin PrintBitmap(FCanvas,Rect(xmin,ymin,xmax,ymax),useimg,SRCCOPY); end; end else begin FCanvas.StretchDraw(Rect(xmin,ymin,xmax,ymax),useimg); end; ClipBack; //SelectClipRgn(FCanvas.handle,0); end; if assigned(tmpImg) then tmpImg.Free; DeleteObject(clprgn); FCanvas.PolyLine([p1,p2,p3,p4,p1]); if modified then modified := false; End; Function TPCDrawEngine.isRotated(p1,p2,p3,p4: TPoint):Boolean; Begin if p2.y = p1.y then isRotated := False else isRotated := True; end; Procedure TPCDrawEngine.Clip(clpRgn:HRGN); begin ClipRgn := clpRgn; SelectClipRgn(FCanvas.Handle,clpRgn); end; Procedure TPCDrawEngine.SetUpOpenGL(Wnd:HWND); var DC:HDC; RC:HGLRC; begin //dc := GetDc(Wnd); //SetupPixelFormat(DC); //RC:=wglCreateContext(DC); //makes OpenGL window out of DC //wglMakeCurrent(DC, RC); //makes OpenGL window active //GLInit; //initialize OpenGL end; Procedure TPCDrawEngine.GLInit; begin // set viewing projection glMatrixMode(GL_PROJECTION); glFrustum(-0.4, 0.4, -0.4, 0.4, 0.3, 25.0); // position viewer glMatrixMode(GL_MODELVIEW); glEnable(GL_DEPTH_TEST); end; Procedure TPCDrawEngine.GLPaint; begin glClear(GL_COLOR_BUFFER_BIT or GL_DEPTH_BUFFER_BIT); glLoadIdentity; SwapBuffers(wglGetCurrentDC); end; procedure TPCDrawEngine.ClearPens; var i: Integer; begin for i := 0 to FPens.Count - 1 do begin try DeleteObject(TExtPen(FPens.Objects[i]).FhPen); FPens.Objects[i].Free; except on E: Exception do AddExceptionToLogExt(ClassName, 'ClearPens', E.Message); end; end; FPens.Clear; end; procedure GetDeviceSettings; var retval: integer; PixX, PixY: Integer; begin FDeviceName := Printer.Printers[Printer.PrinterIndex]; {Получаем имя} FPageHeightPixel := Printer.PageHeight; {Получаем высоту страницы} FPageWidthPixel := Printer.PageWidth; {Получаем ширину страницы} FOrientation := Printer.Orientation; {Ориентация} {Получаем отступ при печати (поля страницы)} FPrintOffsetPixels.X := GetDeviceCaps(Printer.Handle, PHYSICALOFFSETX); FPrintOffsetPixels.Y := GetDeviceCaps(Printer.Handle, PHYSICALOFFSETY); {Получаем количество пикселей, печатаемое на миллиметре бумаги} PixX := GetDeviceCaps(Printer.Handle, LOGPIXELSX); PixY := GetDeviceCaps(Printer.Handle, LOGPIXELSY); FPixelsPerMMX := INCHES_PER_MILIMETER * PixX; FPixelsPerMMY := INCHES_PER_MILIMETER * PixY; FPageHeightMM := Round(FPageHeightPixel / FPixelsPerMMY); end; procedure TPCDrawEngine.DefinePrinting; begin FPrinting := false; if Printer.Printing then begin try if FCanvas.Handle = Printer.Canvas.Handle then begin if FDeviceName <> Printer.Printers[Printer.PrinterIndex] then GetDeviceSettings; FPrinting := True; end; except end; end; end; function TPCDrawEngine.ExtractExtPenByCanvas: HPEN; var StrKey: String; LogPen: TLogPen; lb: TLogBrush; aHan: HPEN; ExtPenIdx: Integer; ExtPen: TExtPen; begin Result := 0; LogPen.lopnStyle := Ord(ExtPenStyles[FCanvas.Pen.Style]); LogPen.lopnWidth.X := FCanvas.Pen.Width; LogPen.lopnColor := ColorToRGB(FCanvas.Pen.Color); if (FCanvas.Pen.Mode <> pmXor) and (FCanvas.Pen.width>1) then begin lb.lbStyle := BS_SOLID; lb.lbColor := ColorToRGB(FCanvas.Pen.Color); lb.lbHatch := 0; end else ZeroMemory(@lb, SizeOf(lb)); if FCachePen then begin StrKey := IntToStr(LogPen.lopnStyle) +'_'+ IntToStr(LogPen.lopnWidth.X) +'_'+ IntToStr(LogPen.lopnColor)+'_'+ IntToStr(lb.lbStyle) +'_'+ IntToStr(lb.lbColor) +'_'+ IntToStr(Integer(FCanvas)); ExtPenIdx := FPens.IndexOf(StrKey); if ExtPenIdx <> -1 then Result := TExtPen(FPens.Objects[ExtPenIdx]).FhPen; end; if Result = 0 then begin try if (FCanvas.Pen.Mode <> pmXor) and (FCanvas.Pen.width>1) then begin aHan := ExtCreatePen(PS_GEOMETRIC or LogPen.lopnStyle or PS_ENDCAP_SQUARE or PS_JOIN_MITER {PS_JOIN_BEVEL}, FCanvas.pen.width ,lb, 0, nil); result := aHan; end else begin result := CreatePenIndirect(LogPen); end; except end; if FCachePen then begin ExtPen := TExtPen.Create; ExtPen.FhPen := Result; FPens.AddObject(StrKey, ExtPen); //GProcCnt := GProcCnt + 1; end; end; end; function TPCDrawEngine.IsPointInRegion(aReg: Integer; pt: PDoublePoint): Boolean; var ipt, tpt: TPoint; dx,dy,z: Double; begin Result := false; dx := pt^.x; dy := pt^.y; z := 0; ConvertPoint(dx,dy,z); ipt := Point(round(dx),round(dy)); Result := ptInRegion(aReg, ipt.x, ipt.y); end; Function TPCDrawEngine.SkewBitmap(p1,p2,p3,p4: TPoint; pic: TBitmap; var ResultBmp: TBitmap;isTrans:Boolean): Boolean; var i,k: Integer; RowOriginal : pRGBArray; RowRotated : pRGBArray; pa,pb: TDoublepoint; px: Tpoint; bRect: Trect; x,y,h,w: Integer; CalCPoints: array of array of TPoint; begin Screen.Cursor := crHourGlass; if (p1.x = p4.x) and (p2.x = p3.x) and (p1.y = p2.y) and (p4.y = p3.y) then begin ResultBmp.Width := pic.width; ResultBmp.Height := pic.Height; ResultBmp.PixelFormat := pf24bit; Resultbmp.Canvas.Draw(0,0,pic); ResultBmp.Transparent := isTrans; Screen.Cursor := crDefault; exit; end; bRect.TopLeft := p1; bRect.BottomRight := p3; if p1.x < bRect.Left then bRect.Left := p1.x; if p2.x < bRect.Left then bRect.Left := p2.x; if p3.x < bRect.Left then bRect.Left := p3.x; if p4.x < bRect.Left then bRect.Left := p4.x; if p1.x > bRect.Right then bRect.Right := p1.x; if p2.x > bRect.Right then bRect.Right := p2.x; if p3.x > bRect.Right then bRect.Right := p3.x; if p4.x > bRect.Right then bRect.Right := p4.x; if p1.y < bRect.top then bRect.top := p1.y; if p2.y < bRect.top then bRect.top := p2.y; if p3.y < bRect.top then bRect.top := p3.y; if p4.y < bRect.top then bRect.top := p4.y; if p1.y > bRect.bottom then bRect.bottom := p1.y; if p2.y > bRect.bottom then bRect.bottom := p2.y; if p3.y > bRect.bottom then bRect.bottom := p3.y; if p4.y > bRect.bottom then bRect.bottom := p4.y; ResultBmp.Width := bRect.right-bRect.left; ResultBmp.Height := bRect.bottom-bRect.top; ResultBmp.PixelFormat := pf24bit; if isTrans then begin ResultBmp.Canvas.Brush.Color := pic.Canvas.Pixels[0,pic.Height-1]; ResultBmp.Canvas.Brush.Style := bsSolid; ResultBmp.Canvas.FillRect(Rect(0,0,ResultBmp.Width,ResultBmp.Height)); end; SetLength(CalcPoints,ResultBmp.Width); for i := 0 to ResultBmp.Width-1 do begin SetLength(CalcPoints[i],ResultBmp.Height); for k := 0 to ResultBmp.Height-1 do CalcPoints[i,k] := Point(-1,-1); end; for i := 0 to pic.Height-1 do begin pa := GetLineSegmentPoint(DoublePoint(p1),DoublePoint(p4),(i/(pic.Height-1))); pb := GetLineSegmentPoint(DoublePoint(p2),DoublePoint(p3),(i/(pic.Height-1))); for k := 0 to pic.Width-1 do begin px := DP2P(GetLineSegmentPoint(pa,pb,(k/(pic.Width-1)))); px.x := px.x-bRect.left; px.y := px.y-bRect.top; if px.y < 0 then px.y := 0; if px.y > ResultBmp.Height-1 then px.y := ResultBmp.Height-1; if px.x < 0 then px.x := 0; if px.x > ResultBmp.Width-1 then px.x := ResultBmp.Width-1; CalcPoints[px.x,px.y] := Point(k,i); end; end; h := ResultBmp.Height-1; w := ResultBmp.Width-1; for i := 0 to ResultBmp.Height -1 do begin RowRotated := ResultBmp.Scanline[i]; for k := 0 to ResultBmp.Width -1 do begin px := CalcPoints[k,i]; if (px.y = -1) and (i > 0) then px := CalcPoints[k,i-1]; if (px.y = -1) and (k > 0) then px := CalcPoints[k-1,i]; if (px.y = -1) and (k > 0) and (i > 0) then px := CalcPoints[k-1,i-1]; if (px.y = -1) and (i < h) then px := CalcPoints[k,i+1]; if (px.y = -1) and (k < w) then px := CalcPoints[k+1,i]; if (px.y = -1) and (k < w) and (i < h) then px := CalcPoints[k+1,i+1]; if (px.y = -1) and (k < w) and (i > 0) then px := CalcPoints[k+1,i-1]; if (px.y = -1) and (k > 0) and (i < h) then px := CalcPoints[k-1,i+1]; if (px.y <> -1) then begin RowOriginal := pic.ScanLine[px.y]; RowRotated[k] := RowOriginal[px.x]; end; end; end; ResultBmp.Transparent := isTrans; Screen.Cursor := crDefault; end; //Tolik 20/10/2021 -- //Function TPCDrawEngine.MakeBitmap(p1,p2,p3,p4: TPoint; pic: TBitmap; var ResultBmp: TBitmap; isTrans: Boolean): Boolean; Function TPCDrawEngine.MakeBitmap(p1,p2,p3,p4: TPoint; pic: TBitmap; var ResultBmp: TBitmap; isTrans: Boolean; GrColor: TColor = -1): Boolean; // var twidth,theight : integer; teta: real; RegNbr : Integer; ap1,ap2 : TPoint; bufbitmap : tbitmap ; r: double; // Tolik 20/10/2021 -*- i, j: integer; ColorRgb: Integer; ColorR, ColorG, ColorB: Byte; ColorIndex: integer; Begin Result := False; //#From Oleg# //20.09.2010 twidth := round(sqrt(sqr(p1.x-p2.x)+ sqr(p1.y-p2.y))); theight := round(sqrt(sqr(p1.x-p4.x)+ sqr(p1.y-p4.y))); r := tWidth/tHeight; bufbitmap := Tbitmap.Create; bufBitmap.PixelFormat := pf24bit; bufBitmap.Width := round(pic.height*r); bufbitmap.height := pic.height; bufbitmap.Canvas.StretchDraw(Rect(0,0,bufbitmap.width,bufbitmap.height),pic); //Tolik 20/10/2021 - - if grColor <> -1 then begin ColorIndex := -1; for i := 0 to 59 do begin if GrayedColors[i] = GrColor then begin ColorIndex := i; break; end; end; if colorIndex <> -1 then begin { for i := 0 to bufbitmap.Height - 1 do begin p := bufbitmap.ScanLine[Y]; for j := 0 to bufbitmap.Width - 1 do begin P^.rgbReserved:=Round(255*j/(B.Height-1)); P^.rgbBlue:=Round(P^.rgbBlue*P^.rgbReserved/255); P^.rgbGreen:=Round(P^.rgbGreen*P^.rgbReserved/255); P^.rgbRed:=Round(P^.rgbRed*P^.rgbReserved/255); Inc(P); end; end; } {for i := 0 to bufbitmap.Height - 1 do begin for j := 0 to bufbitmap.Width - 1 do begin bufbitmap.Canvas.Pixels[i, j] := grColor; end; end; } if ResultBmp <> nil then ResultBmp.free; ResultBmp := Tbitmap.Create; ResultBmp.PixelFormat := pf32bit; ResultBmp.width := bufBitmap.Width; ResultBmp.Height := bufbitmap.Height; //ResultBmp.Transparent := True; //ResultBmp.TransparentColor := clFuchsia;//grColor; bufbitmap.Transparent := True; bufbitmap.TransparentColor := clFuchsia;//grColor; Resultbmp.TransparentMode := tmAuto; //ResultBmp.Canvas.StretchDraw(Rect(0, 0, bufbitmap.width, bufbitmap.height), bufbitmap); //DrawAlphaAPI(bufbitmap, ResultBmp.Canvas, 0, 0, 255 - Round(ColorIndex * 4.2)); //Tolik 25/01/2022 -- //DrawAlphaAPI(bufbitmap, ResultBmp.Canvas, 0, 0, 255 - Round(F_LayersDialog.tbGrayed.Position * 4.32)); if F_LayersDialog.Showing then DrawAlphaAPI(bufbitmap, ResultBmp.Canvas, 0, 0, 255 - Round(F_LayersDialog.tbGrayed.Position * 4.32)) else begin DrawAlphaAPI(bufbitmap, ResultBmp.Canvas, 0, 0, 255 - Round((Length(GrayedColors) - 1 - colorIndex) * 4.32)); end; // end else begin ResultBmp.Canvas.StretchDraw(Rect(0, 0, bufbitmap.width, bufbitmap.height), bufbitmap); end; end; //DrawOpacityBrush(ResultBmp.Canvas, xRect, 0, 0, ResultBmp.brush.color, 100 ); { for i := 0 to ResultBmp.Height - 1 do begin for j := 0 to ResultBmp.Width - 1 do begin ColorRgb := ColorToRGB(ResultBmp.Canvas.Pixels[j,i]); ColorR := GetRValue(ColorRgb); ColorG := GetGValue(ColorRgb); ColorB := GetBValue(ColorRgb); ResultBmp.Canvas.Pixels[j,i] := GdiPapi.MakeColor(100 , ColorR, ColorG, ColorB); end; end; } // ap1 := p1; ap2 := p2; if ap2.y = ap1.y then Teta := 0 else if ap2.x = ap1.x then Teta := pi/2 else Teta := ArcTan(abs(ap2.y - ap1.y) / abs(ap2.x - ap1.x)); if ap1.x < ap2.x then begin if ap1.y >= ap2.y then RegNbr := 1 else RegNbr := 4; end else begin if ap1.y > ap2.y then RegNbr := 2 else RegNbr := 3; end; If RegNbr = 1 then Teta := Teta else if RegNbr = 2 then Teta := pi - teta else if RegNbr = 3 then Teta := pi + teta else if RegNbr = 4 then Teta := 2*pi - teta; if Teta <> 0 then begin RotateBitmap(BufBitmap,ResultBmp,Teta,isTrans); Result := True; end; bufbitmap.free; end; Procedure TPCDrawEngine.RotateBitmap(var BitmapOriginal,BitmapRotated: TBitmap; Teta: Double; isTrans: Boolean); VAR cosTheta : DOUBLE; i : INTEGER; iRotationAxis : INTEGER; iOriginal : INTEGER; iPrime : INTEGER; iPrimeRotated : INTEGER; j : INTEGER; jRotationAxis : INTEGER; jOriginal : INTEGER; jPrime : INTEGER; jPrimeRotated : INTEGER; RowOriginal : pRGBArray; RowRotated : pRGBArray; sinTheta : DOUBLE; Theta : DOUBLE; // radians OldHeight : integer; OldWidth : integer; NewWidth : integer; NewHeight : integer; NB : INTEGER; NG : INTEGER; NR : INTEGER; add: integer; begin RowOriginal := BitmapOriginal.Scanline[0]; NB:=RowOriginal[0].rgbtBlue; NG:=RowOriginal[0].rgbtGreen; NR:=RowOriginal[0].rgbtRed; Theta := teta; sinTheta := SIN(Theta); cosTheta := COS(Theta); OldWidth := BitmapOriginal.Width; OldHeight := BitmapOriginal.Height; NewWidth := abs(round(OldHeight * sinTheta)) + abs(round(OldWidth *cosTheta)); NewHeight := abs(round(OldWidth * sinTheta)) + abs(round(OldHeight *cosTheta)); BitmapRotated.Width := NewWidth; BitmapRotated.Height := NewHeight; BitmapRotated.PixelFormat := pf24bit; iRotationAxis := OldWidth div 2; jRotationAxis := OldHeight div 2; // Step through each row of rotated image. FOR j := BitmapRotated.Height-1 DOWNTO 0 DO BEGIN RowRotated := BitmapRotated.Scanline[j]; jPrime := 2*(j - (NewHeight - OldHeight) div 2 - jRotationAxis) + 1 ; FOR i := BitmapRotated.Width-1 DOWNTO 0 DO BEGIN // offset origin by the growth factor (NewWidth - OldWidth) div 2 iPrime := 2*(i - (NewWidth - OldWidth) div 2 - iRotationAxis) + 1; iPrimeRotated := ROUND(iPrime * CosTheta - jPrime * sinTheta); jPrimeRotated := ROUND(iPrime * sinTheta + jPrime * cosTheta); // Transform back to pixel coordinates of image, including translation // of origin from axis of rotation to origin of image. iOriginal := (iPrimeRotated - 1) DIV 2 + iRotationAxis; jOriginal := (jPrimeRotated - 1) DIV 2 + jRotationAxis; // Make sure (iOriginal, jOriginal) is in BitmapOriginal. If not, // assign blue color to corner points. IF (iOriginal >= 0) AND (iOriginal <= BitmapOriginal.Width-1) AND (jOriginal >= 0) AND (jOriginal <= BitmapOriginal.Height-1) THEN BEGIN // Assign pixel from rotated space to current pixel in BitmapRotated RowOriginal := BitmapOriginal.Scanline[jOriginal]; RowRotated[i] := RowOriginal[iOriginal] END ELSE BEGIN if isTrans then add := 0 else add := 100; // Tolik 24/12/2019 -- структура побайтовая, чтобы не было переполнения.... {RowRotated[i].rgbtBlue := NB + add; // assign "corner" color RowRotated[i].rgbtGreen := NG + add; RowRotated[i].rgbtRed := NR + add;} if (NB + add) > 255 then RowRotated[i].rgbtBlue := 255 else RowRotated[i].rgbtBlue := NB + add; // assign "corner" color if (NG + add) > 255 then RowRotated[i].rgbtGreen := 255 else RowRotated[i].rgbtGreen := NG + add; if (NR + add) > 255 then RowRotated[i].rgbtRed := 255 else RowRotated[i].rgbtRed := NR + add; // END; END; END; END; Procedure TPCDrawEngine.TextToRect(p1,p2,p3,p4: TDoublePoint; aText: String; aFont: TFont; CSpace:Double; var w,h: Double); var TM : TTextMetric; FontRecord : TLogFont; txSize: TSize; CWidth,CHeight: Double; wChar: Integer; x1,y1: Double; tw,th: Double; rad: Double; z: Double; begin FCanvas.Font := aFont; FCanvas.brush.color := clNone; FCanvas.brush.style := bsClear; x1 := p1.x; y1 := p1.y; z := 0; ConvertCoord(x1,y1,z); rad := GetRadOfLine(p1,p2); // Get Font Record GetObject(FCanvas.Font.Handle,sizeof(FontRecord),Addr(FontRecord)); // Set Angle if rad <> 0 then begin FontRecord.lfEscapement := Round(-1*(rad/pi)*1800); end; // Set Font Height th := abs(GetLineLenght(p1,p4)); CHeight := th; ConvertDim(CHeight); FontRecord.lfHeight := Round(CHeight); tw := Abs(GetLineLenght(p1,p2)); ConvertDim(tw); ConvertDim(CSpace); CWidth := ((tw) / length(aText)) - Round(CSpace); wChar := round(CWidth)+1; FontRecord.lfWidth := wChar; FCanvas.Font.handle := CreateFontIndirect(FontRecord); SetTextCharacterExtra(FCanvas.Handle,Round(CSpace)); GetTextExtentPoint(FCanvas.Handle,pchar(aText),length(aText),txSize); while (txSize.cx > tw) And (wChar > 0) do begin wChar := wChar - 1; GetObject(FCanvas.Font.Handle,sizeof(FontRecord),Addr(FontRecord)); FontRecord.lfWidth := wChar; FCanvas.Font.handle := CreateFontIndirect(FontRecord); GetTextExtentPoint(FCanvas.Handle,pchar(aText),length(aText),txSize); end; if wChar < 0 then wChar := 0; w := wChar; DeConvertDim(w); h := th; end; Procedure TPCDrawEngine.DrawLabel(r1,r2:TDoublePoint;aText: String; afont: Tfont; aheight:Double;pcolor,awidth,style,bc,bs: integer;var RGn:HRGN); var TM : TTextMetric; FontRecord : TLogFont; Leading : LongInt; ap : TPoint; txSize: TSize; wChar: Integer; x1,y1,x2,y2,sw: Double; tx,ty: Integer; leftAl:Boolean; z: Double; begin FCanvas.Font := aFont; FCanvas.brush.color := clNone; FCanvas.brush.style := bsClear; x1 := r1.x; y1 := r1.y; x2 := r2.x; y2 := r2.y; z := 0; ConvertCoord(x1,y1,z); ConvertCoord(x2,y2,z); ConvertDim(aHeight); LeftAl := False; if x1 > x2 then begin //sw := x1; //x1 := x2; //x2 := sw; LeftAl := True; end; if y1 > y2 then begin sw := y1; y1 := y2; y2 := sw; end; // Get Font Record GetObject(FCanvas.Font.Handle,sizeof(FontRecord),Addr(FontRecord)); // Set Font Height FontRecord.lfHeight := Round(aHeight); // Create Modified Font //dFont := FCanvas.Font.handle; FCanvas.Font.handle := CreateFontIndirect(FontRecord); If Not LeftAl then begin tx := Round(x1)+4; end else begin tx := Round(x1) - Fcanvas.TextWidth(aText) - 4; end; ty := Round((y1+y2) / 2) - (Round(aHeight / 2))-2; FCanvas.pen.color := pcolor; FCanvas.pen.width := awidth; FCanvas.pen.style := penstyles[style]; FCanvas.brush.color := bc; FCanvas.brush.style := TBrushStyle(bs); FCanvas.rectangle(tx-4,ty-2,tx+Fcanvas.TextWidth(aText)+4,ty+Round(aHeight)+4); { if rgn = 0 then begin rgn := CreateRectRgn(tx-4,ty-2,tx+Fcanvas.TextWidth(aText)+4,ty+Round(aHeight)+4); end;} FCanvas.brush.color := clNone; FCanvas.brush.style := bsClear; FCanvas.textout(tx,ty,atext); end; Procedure TPCDrawEngine.DrawCenteredText(p1: TDoublePoint;Color:TColor;Text,FontName:String; FontSize:Double;Angle:Double); var tWidth,tHeight:Integer; FontRecord : TLogFont; z,tw,th: Double; ap1,ap2,ap3,ap4: TDoublePoint; fSize: Double; nh,nl: Integer; begin FSize := FontSize; ConvertDim(FSize); if FSize < 4 then exit; FCanvas.brush.color := clNone; FCanvas.brush.style := bsClear; Canvas.Font.Name := FontName; if Eqd(Angle,pi) or eqd(Angle,-pi) then Angle := 0 else if (Angle > pi) and (Angle < 3*(pi/2)) then Angle := Angle-pi else if (Angle > pi/2) and (Angle < pi) then Angle := Angle+pi; // Get Font Record GetObject(FCanvas.Font.Handle,sizeof(FontRecord),Addr(FontRecord)); // Set Font Height FontRecord.lfHeight := Round(FSize); // Create Modified Font FCanvas.Font.handle := CreateFontIndirect(FontRecord); tw := Canvas.TextWidth(text); th := Canvas.TextHeight(text); DeConvertDim(tw); DeConvertDim(th); ap1 := DoublePoint(p1.x-(tw/2),p1.y-(th/2)); ap2 := DoublePoint(ap1.x+tw,ap1.y); ap3 := DoublePoint(ap2.x,ap2.y+th); ap4 := DoublePoint(ap1.x,ap1.y+th); if Angle <> 0 then begin //ap1 := RotatePoint(p1,ap1,2*pi-Angle); ap1 := RotatePoint(p1,ap1,Angle); ap2 := RotatePoint(p1,ap2,Angle); ap3 := RotatePoint(p1,ap3,Angle); ap4 := RotatePoint(p1,ap4,Angle); end; DrawText(ap1,ap2,ap3,ap4,Angle,Text,FontName,Color,FontSize,0,0,nh,nl); end; Procedure TPCDrawEngine.DrawCenteredText(p1: TDoublePoint;Color:TColor;Text,FontName:String; FontSize:Integer;Angle:Double); var tWidth,tHeight:Integer; z: Double; FontRecord : TLogFont; begin if FontSize < 4 then exit; FCanvas.brush.color := clNone; FCanvas.brush.style := bsClear; z := 0; ConvertCoord(p1.x,p1.y,z); FCanvas.brush.color := clNone; FCanvas.brush.style := bsClear; Canvas.Font.Name := FontName; Canvas.Font.Color := Color; // Get Font Record GetObject(FCanvas.Font.Handle,sizeof(FontRecord),Addr(FontRecord)); // Set Font Height FontRecord.lfHeight := FontSize; // Create Modified Font //dFont := FCanvas.Font.handle; FCanvas.Font.handle := CreateFontIndirect(FontRecord); tWidth := Canvas.TextWidth(text); tHeight := Canvas.TextHeight(text);; Canvas.TextOut(Round(p1.x)-(tWidth div 2),Round(p1.y)-(tHeight div 2),Text); end; Procedure TPCDrawEngine.TraceText(p1:TDoublePOint;Color:TColor;Text,FontName:String;FontSize:Integer); var z: Double; begin z := 0; ConvertCoord(p1.x,p1.y,z); DrawTraceText(Round(p1.x),Round(p1.y),Color,Text,FontName,FontSize,Canvas); end; procedure TPCDrawEngine.drawtext(ap1,ap2,ap3,a4: TDoublePoint;angle:Double; atext: string; afont: Tfont; aHeight:Double; CWidth,CSpace:double; Var nH,nL: Integer); var TM : TTextMetric; FontRecord : TLogFont; Leading : LongInt; ap : TPoint; txSize: TSize; wChar: Integer; x1,y1,z: Double; olDFont: TFont; begin nh := 0; nl := 0; ConvertDim(aHeight); if aheight < 4 then exit; OldFont := Fcanvas.Font; FCanvas.Font := aFont; Fcanvas.Font.Height := Round(aHeight); FCanvas.brush.color := clNone; FCanvas.brush.style := bsClear; // Get Font Record GetObject(FCanvas.Font.Handle,sizeof(FontRecord),Addr(FontRecord)); // Set Font Height FontRecord.lfHeight := Round(aHeight); // Create Modified Font FCanvas.Font.handle := CreateFontIndirect(FontRecord); x1 := ap1.x; y1 := ap1.y; z := 0; ConvertCoord(x1,y1,z); if Angle <> 0 then begin // Get Font Record GetObject(FCanvas.Font.Handle,sizeof(FontRecord),Addr(FontRecord)); // Set Angle angle := -1*(angle/pi)*1800; FontRecord.lfEscapement := Round(angle); FontRecord.lfOrientation := Round(angle); // Create Modified Font FCanvas.Font.handle := CreateFontIndirect(FontRecord); end; // Calculate Zero Point GetTextMetrics(FCanvas.Handle,TM); if CWidth <> 0 then begin GetObject(FCanvas.Font.Handle,sizeof(FontRecord),Addr(FontRecord)); ConvertDim(CWidth); wChar := round(CWidth); FontRecord.lfWidth := wchar; FCanvas.Font.handle := CreateFontIndirect(FontRecord); end; Leading := TM.tmInternalLeading; if angle <> 0 then begin ap := getRelativePointbyAngle(Round(angle),DP2P(x1,y1),Dp2P(x1,y1-Leading div 3)); y1 := ap.y; x1 := ap.x; end; if CSpace <> 0 then begin ConvertDim(CSpace); SetTextCharacterExtra(FCanvas.Handle,round(CSpace)); end; FCanvas.textout(round(x1),Round(y1),atext); GetTextExtentPoint(FCanvas.Handle,pchar(aText),length(aText),txSize); nh := txSize.cy; nL := txSize.cx; nL := nl-round(cSpace); if CSpace <> 0 then begin SetTextCharacterExtra(FCanvas.Handle,0); end; Fcanvas.Font := oldFont; end; Procedure TPCDrawEngine.DrawAlignedText(xp1,xp2:TdoublePoint; atext: string; FontName: TFontName; aColor: integer;aheight:double); var TM : TTextMetric; FontRecord : TLogFont; Leading : LongInt; ap : TPoint; aFont,oldFont: TFont; r: Trect; t,z: double; xp:TDoublePoint; Angle:Double; delta: Double; begin ConvertCoord(xp1.x,xp1.y,xp1.z); ConvertCoord(xp2.x,xp2.y,xp2.z); delta := 3.0; ConvertDim(delta); GetParallelPOints(xp1,xp2,xp1,xp2,delta); xp := MPoint(xp1,xp2); if EQD(xp1.x,xp2.x) then Angle := 3*(pi/2) else if EQD(xp1.y,xp2.y) then Angle := 0 else Angle := GetRadOfLine(xp1,xp2); DrawCenteredText(DP2P(xp),acolor,atext,FontName,aHeight,Angle); end; Function TPCDrawEngine.CreateRectRegion(x1,y1,x2,y2:Double):HRGN; begin result := CreateRectRgn(round(x1),round(y1),round(x2),round(y2)); end; Procedure TPCDrawEngine.DrawHDim(ap1,ap2,ap3:TDoublePoint; dLabel: String; fontName: TFontName; Styles:TFontStyles;aColor,TextColor: integer; aheight: Double; LStyle:THDimLabelStyle; TextPos: TDimTextPos; et: TEndType; var RegHandle: HRGN); var x1,x2,x3,y1,y2,y3,z: Double; d,nickD,t: Double; rt,textLen:Integer; TM : TTextMetric; FontRecord : TLogFont; aFont: TFont; r: Trect; OutLen,headLen: Double; rg,reg:HRGN; oldFont : TFont; Procedure AddRegion(rx1,ry1,rx2,ry2: Double); var tReg: HRGN; begin tReg := CreateRectRegion(rx1,ry1,rx2,ry2); CombineRgn(Reg,reg,treg,RGN_OR); DeleteObject(tReg); end; begin z := 0; x1 := ap1.x; y1 := ap1.y; x2 := ap2.x; y2 := ap2.y; x3 := ap3.x; y3 := ap3.y; ConvertCoord(x1,y1,z); ConvertCoord(x2,y2,z); ConvertCoord(x3,y3,z); Outlen := 8; ConvertDim(Outlen); HeadLen := HeadLength; ConvertDim(HeadLen); nickD := 1; ConvertDim(nickD); TextLen := 0; if x1 > x2 then begin t := x1; x1 := x2; x2 := t; t := y1; y1 := y2; y2 := t; end; aFont := nil; //#From Oleg# //20.09.2010 oldFont := nil; if dLabel <> '' then begin oldFont := Fcanvas.font; aFont := Tfont.Create; aFont.Name := FontName; aFont.Style := Styles; aFont.Color := TextColor; FCanvas.Font := aFont; // Get Font Record GetObject(FCanvas.Font.Handle,sizeof(FontRecord),Addr(FontRecord)); // Set Font Height ConvertDim(aHeight); FontRecord.lfHeight := Round(aHeight); if (LStyle <> hlsInner) and (LStyle <> hlsLeft) and (LStyle <> hlsRight) then FontRecord.lfEscapement := 900; // Create Modified Font FCanvas.Font.handle := CreateFontIndirect(FontRecord); GetTextMetrics(FCanvas.Handle,TM); // Set Font Width GetObject(FCanvas.Font.Handle,sizeof(FontRecord),Addr(FontRecord)); FontRecord.lfWidth := round(TM.tmAveCharWidth*0.9); FCanvas.Font.handle := CreateFontIndirect(FontRecord); textLen := FCanvas.TextWidth(Dlabel); end; // Draw Guides if ap3.y > ap1.y then d := 1 else d := -1; drawline(ap1.x,ap1.y+d,ap1.x,ap3.y+d,acolor,1,0,0); ConvertDim(d); if reghandle = 0 then begin reg := CreateRectRegion(x1-2,y1+d,x1+2,y3+d); end; if ap3.y > ap2.y then d := 1 else d := -1; drawline(ap2.x,ap2.y+d,ap2.x,ap3.y+d,acolor,1,0,0); ConvertDim(d); if reghandle = 0 then AddRegion(x2-2,y2+d,x2+2,y3+d); t := -1; if x1 <> x2 then begin if LStyle = hlsInner then begin if et = etRow then rt := 3 else rt := 0; Drawline(ap1.x,ap3.y,ap2.x,ap3.y,acolor,1,0,rt); if reghandle = 0 then AddRegion(x1,y3-2,x2,y3+2); end else if (LStyle = hlsLeft) or (LStyle = hlsLeftTop) or (LStyle = hlsLeftBottom) then begin if et = etRow then rt := 2 else rt := 0; drawlinepixD(x2,y3,x2+Outlen,y3,acolor,1,0,rt); if reghandle = 0 then AddRegion(x2,y3-2,x2+Outlen,y3+2); if (LStyle = hlsLeft) then begin if et = etRow then rt := 1 else rt := 0; drawlinepixD(x1-Outlen-TextLen,y3,x1,y3,acolor,1,0,rt); if reghandle = 0 then AddRegion(x1-Outlen-TextLen,y3-2,x1,y3+2); end else if (LStyle = hlsLeftBottom) then begin if et = etRow then rt := 1 else rt := 0; drawlinepixD(x1-OutLen,y3,x1,y3,acolor,1,0,rt); drawlinepixD(x1-OutLen,y3,x1-Outlen,y3+TextLen+OutLen/2,acolor,1,0,0); if reghandle = 0 then AddRegion(x1-OutLen,y3-2,x1,y3+2); if reghandle = 0 then AddRegion(x1-OutLen-2,y3,x1+2,y3+TextLen+OutLen/2); end else if (LStyle = hlsLeftTop) then begin if et = etRow then rt := 1 else rt := 0; drawlinepixD(x1-OutLen,y3,x1,y3,acolor,1,0,rt); drawlinepixD(x1-OutLen,y3-TextLen-OutLen / 2,x1-Outlen,y3,acolor,1,0,0); if reghandle = 0 then AddRegion(x1-OutLen,y3-2,x1,y3+2); if reghandle = 0 then AddRegion(x1-OutLen-2,y3,x1+2,y3-TextLen-OutLen/2); end; end else if (LStyle = hlsRight) or (LStyle = hlsRightTop) or (LStyle = hlsRightBottom) then begin if et = etRow then rt := 1 else rt := 0; drawlinepixD(x1-Outlen,y3,x1,y3,acolor,1,0,rt); if reghandle = 0 then AddRegion(x1-Outlen,y3-2,x1,y3+2); if (LStyle = hlsRight) then begin if et = etRow then rt := 2 else rt := 0; drawlinepixD(x2,y3,x2+Outlen+TextLen,y3,acolor,1,0,rt); if reghandle = 0 then AddRegion(x2,y3-2,x2+Outlen+TextLen,y3+2); end else if (LStyle = hlsRightTop) then begin if et = etRow then rt := 2 else rt := 0; drawlinepixD(x2,y3,x2+Outlen,y3,acolor,1,0,rt); if reghandle = 0 then AddRegion(x2,y3-2,x2+Outlen,y3+2); drawlinepixD(x2+OutLen,y3,x2+Outlen,y3-TextLen-OutLen / 2,acolor,1,0,0); if reghandle = 0 then AddRegion(x2+OutLen-2,y3,x2+Outlen+2,y3-TextLen-OutLen / 2); end else if (LStyle = hlsRightBottom) then begin if et = etRow then rt := 2 else rt := 0; drawlinepixD(x2,y3,x2+Outlen,y3,acolor,1,0,rt); if reghandle = 0 then AddRegion(x2,y3-2,x2+Outlen,y3+2); drawlinepixD(x2+OutLen,y3,x2+Outlen,y3+TextLen+OutLen / 2,acolor,1,0,0); if reghandle = 0 then AddRegion(x2+OutLen-2,y3,x2+Outlen+2,y3+TextLen+OutLen/2); end; end; rg := 1; if et = etDot then begin DrawCircle(ap1.x,ap3.y,1,acolor,1,0,acolor,0,rg,false); DrawCircle(ap2.x,ap3.y,1,acolor,1,0,acolor,0,rg,false); end else if et = etNick then begin drawlinepixD(x1+NickD,y3-NickD,x1-NickD,y3+NickD,acolor,1,0,0); drawlinepixD(x2+NickD,y3-NickD,x2-NickD,y3+NickD,acolor,1,0,0); end; end; SetBkMode(FCanvas.Handle,TRANSPARENT); if (Textpos <> tpAbove) and (TextPos <> tpBelow) then begin SetbkColor(FCanvas.Handle,clWhite); SetBkMode(FCanvas.Handle,OPAQUE); end; Case LStyle of hlsInner,hlsLeft,hlsRight: begin if TextPos = tpAbove then begin y1 := y3 - aHeight; y2 := y3 ; end else if TextPos = tpBelow then begin y1 := y3 ; y2 := y3 + aHeight; end else begin y1 := y3 - (aHeight / 2); y2 := y3 + (aHeight / 2); end; if LStyle = hlsInner then begin r := DR2R(x1,y1,x2,y2); Windows.DrawText(FCanvas.Handle,pChar(DLabel),length(DLabel),R ,DT_CENTER); if reghandle = 0 then AddRegion(((x1+x2) / 2) - (TextLen / 2),y1, ((x1+x2) / 2) + (TextLen / 2),y2); end else if LStyle = hlsLeft then begin r := DR2R(x1-Outlen-TextLen+4,y1,x1,y2); Windows.DrawText(FCanvas.Handle,pChar(DLabel),length(DLabel),R ,DT_LEFT); if reghandle = 0 then AddRegion(x1-Outlen-TextLen+4,y1, x1-Outlen+4,y2); end else if Lstyle = hlsRight then begin r := DR2R(x2+headLen+4,y1,x2+Outlen+TextLen,y2); Windows.DrawText(FCanvas.Handle,pChar(DLabel),length(DLabel),R ,DT_LEFT); if reghandle = 0 then AddRegion(x2+headLen+4,y1, x2+headLen+4+TextLen,y2); end; end; hlsLeftBottom: begin y1 := y3+TextLen+OutLen / 2 - 6; if TextPos = tpAbove then x1 := x1-OutLen-aHeight else if TextPos = tpBelow then x1 := x1-OutLen else x1 := x1-OutLen-aHeight / 2; Windows.TextOut(FCanvas.Handle,Round(x1),Round(y1),pChar(DLabel),length(DLabel)); if reghandle = 0 then AddRegion(x1,y1,x1+aHeight,y1-TextLen); end; hlsLeftTop: begin y1 := y3- OutLen / 2 + 6; if TextPos = tpAbove then x1 := x1-OutLen-aHeight else if TextPos = tpBelow then x1 := x1-OutLen else x1 := x1-OutLen-aHeight / 2; Windows.TextOut(FCanvas.Handle,Round(x1),Round(y1),pChar(DLabel),length(DLabel)); if reghandle = 0 then AddRegion(x1,y1,x1+aHeight,y1-TextLen); end; hlsRightTop: begin y1 := y3- OutLen / 2 + 6; if TextPos = tpAbove then x2 := x2+OutLen-aHeight else if TextPos = tpBelow then x2 := x2+OutLen else x2 := x2+OutLen-aHeight / 2; Windows.TextOut(FCanvas.Handle,Round(x2),Round(y1),pChar(DLabel),length(DLabel)); if reghandle = 0 then AddRegion(x2,y1,x2+aHeight,y1-TextLen); end; hlsRightBottom: begin y1 := y3 + TextLen+OutLen / 2 - 6; if TextPos = tpAbove then x2 := x2+OutLen-aHeight else if TextPos = tpBelow then x2 := x2+OutLen else x2 := x2+OutLen-aHeight / 2; Windows.TextOut(FCanvas.Handle,Round(x2),Round(y1),pChar(DLabel),length(DLabel)); if reghandle = 0 then AddRegion(x2,y1,x2+aHeight,y1-TextLen); end; end; if regHandle = 0 then RegHandle := Reg; if dLabel <> '' then begin Fcanvas.Font := oldFont; afont.Free; end; end; Procedure TPCDrawEngine.DrawVDim(ap1,ap2,ap3:TDoublepoint; dLabel: String; fontName: TFontName; Styles:TFontStyles;aColor,TextColor: integer; aheight: Double; LStyle:TVDimLabelStyle; TextPos: TDimTextPos; et: TEndType; var RegHandle: HRGN); var x1,x2,x3,y1,y2,y3,z: Double; d,t,tx,ty,nickD: Double; textLen,rt: Integer; TM : TTextMetric; FontRecord : TLogFont; aFont: TFont; r: Trect; OutLen,headLen:Double; rg,reg:HRGN; oldFont : TFont; Procedure AddRegion(rx1,ry1,rx2,ry2: Double); var tReg: HRGN; begin tReg := CreateRectRegion(rx1,ry1,rx2,ry2); CombineRgn(Reg,reg,treg,RGN_OR); DeleteObject(tReg); end; Procedure ArrangeBkMode; begin SetbkColor(FCanvas.Handle,clWhite); SetBkMode(FCanvas.Handle,TRANSPARENT); if (Textpos = tpOnline) then begin SetbkColor(FCanvas.Handle,clWhite); SetBkMode(FCanvas.Handle,OPAQUE); end; end; begin z := 0; x1 := ap1.x; y1 := ap1.y; x2 := ap2.x; y2 := ap2.y; x3 := ap3.x; y3 := ap3.y; ConvertCoord(x1,y1,z); ConvertCoord(x2,y2,z); ConvertCoord(x3,y3,z); Outlen := 8; ConvertDim(Outlen); HeadLen := HeadLength; ConvertDim(HeadLen); nickD := 1; ConvertDim(nickD); TextLen := 0; if y1 > y2 then begin t := y1; y1 := y2; y2 := t; t := x1; x1 := x2; x2 := t; end; oldFont := nil;//#From Oleg# //20.09.2010 afont := nil;//#From Oleg# //20.09.2010 if dLabel <> '' then begin oldFont := Fcanvas.font; aFont := Tfont.Create; aFont.Name := FontName; aFont.Style := Styles; aFont.Color := TextColor; FCanvas.Font := aFont; // Get Font Record GetObject(FCanvas.Font.Handle,sizeof(FontRecord),Addr(FontRecord)); // Set Font Height ConvertDim(aHeight); FontRecord.lfHeight := Round(aHeight); if (LStyle = vlsInner) or (LStyle = vlsTop) or (LStyle = vlsBottom) then FontRecord.lfEscapement := 900; // Create Modified Font FCanvas.Font.handle := CreateFontIndirect(FontRecord); GetTextMetrics(FCanvas.Handle,TM); // Set Font Width GetObject(FCanvas.Font.Handle,sizeof(FontRecord),Addr(FontRecord)); FontRecord.lfWidth := round(TM.tmAveCharWidth*0.9); FCanvas.Font.handle := CreateFontIndirect(FontRecord); textLen := FCanvas.TextWidth(Dlabel); end; // Draw Guides if ap3.x > ap1.x then d := 1 else d := -1; drawline(ap1.x+d,ap1.y,ap3.x+d,ap1.y,acolor,1,0,0); ConvertDim(d); if reghandle = 0 then begin reg := CreateRectRegion(x1+d,y1-2,x3+d,y1+2); end; if ap3.x > ap2.x then d := 1 else d := -1; drawline(ap2.x+d,ap2.y,ap3.x+d,ap2.y,acolor,1,0,0); ConvertDim(d); if reghandle = 0 then AddRegion(x2+d,y2-2,x3+d,y2+2); t := -1; if y1 <> y2 then begin SetBkMode(FCanvas.Handle,TRANSPARENT); if LStyle = vlsInner then begin // DrawLine if et = etRow then rt := 3 else rt := 0; Drawline(ap3.x,ap1.y,ap3.x,ap2.y,acolor,1,0,rt); if reghandle = 0 then AddRegion(x3-2,y1,x3+2,y2); // DrawText ty := y3+TextLen div 2; if TextPos = tpAbove then tx := x3-aHeight else if TextPos = tpBelow then tx := x3 else tx := x3-aHeight / 2; ArrangeBkMode; Windows.TextOut(FCanvas.Handle,round(tx),Round(ty),pChar(DLabel),length(DLabel)); if reghandle = 0 then AddRegion(tx,ty,tx+aHeight,ty-TextLen); end else if (LStyle = vlsTop) or (LStyle = vlsTopLeft) or (LStyle = vlsTopRight) then begin if et = etRow then rt := 2 else rt := 0; drawlinepixD(x3,y2,x3,y2+Outlen,acolor,1,0,rt); if reghandle = 0 then AddRegion(x3-2,y2+Outlen,x3+2,y2); if (LStyle = vlsTop) then begin if et = etRow then rt := 1 else rt := 0; drawlinepixD(x3,y1-Outlen-TextLen,x3,y1,acolor,1,0,rt); if reghandle = 0 then AddRegion(x3-2,y1-Outlen-TextLen,x3+2,y1); // DrawText ty := y1-Outlen+4; if TextPos = tpAbove then tx := x3-aHeight else if TextPos = tpBelow then tx := x3 else tx := x3-aHeight / 2; ArrangeBkMode; Windows.TextOut(FCanvas.Handle,Round(tx),Round(ty),pChar(DLabel),length(DLabel)); if reghandle = 0 then AddRegion(tx,ty,tx+aHeight,ty-TextLen); end else if (LStyle = vlstopLeft) then begin if et = etRow then rt := 1 else rt := 0; drawlinepixD(x3,y1-Outlen,x3,y1,acolor,1,0,rt); if reghandle = 0 then AddRegion(x3-2,y1-Outlen,x3+2,y1); drawlinepixD(x3,y1-Outlen,x3-TextLen - OutLen / 2,y1-Outlen,acolor,1,0,0); if reghandle = 0 then AddRegion(x3,y1-Outlen-2,x3-TextLen-OutLen / 2,y1-Outlen+2); // DrawText tx := x3-TextLen-OutLen / 2+4; if TextPos = tpAbove then ty := y1-OutLen-aHeight else if TextPos = tpBelow then ty := y1-OutLen else ty := y1-OutLen-aHeight / 2; ArrangeBkMode; Windows.TextOut(FCanvas.Handle,Round(tx),Round(ty),pChar(DLabel),length(DLabel)); if reghandle = 0 then AddRegion(tx,ty,tx+TextLen,ty+AHeight); end else if (LStyle = vlsTopright) then begin if et = etRow then rt := 1 else rt := 0; drawlinepixD(x3,y1-Outlen,x3,y1,acolor,1,0,rt); if reghandle = 0 then AddRegion(x3-2,y1-Outlen,x3+2,y1); drawlinepixD(x3,y1-Outlen,x3+TextLen+OutLen / 2,y1-Outlen,acolor,1,0,0); if reghandle = 0 then AddRegion(x3,y1-Outlen-2,x3+TextLen+OutLen / 2,y1-Outlen+2); // DrawText tx := x3+4; if TextPos = tpAbove then ty := y1-OutLen-aHeight else if TextPos = tpBelow then ty := y1-OutLen else ty := y1-OutLen-aHeight / 2; ArrangeBkMode; Windows.TextOut(FCanvas.Handle,Round(tx),Round(ty),pChar(DLabel),length(DLabel)); if reghandle = 0 then AddRegion(tx,ty,tx+TextLen,ty+AHeight); end; end else if (LStyle = vlsBottom) or (LStyle = vlsBottomRight) or (LStyle = vlsBottomLeft) then begin if et = etRow then rt := 2 else rt := 0; drawlinepixD(x3,y1,x3,y1-Outlen,acolor,1,0,rt); if reghandle = 0 then AddRegion(x3-2,y1-Outlen,x3+2,y1); if (LStyle = vlsBottom) then begin if et = etRow then rt := 1 else rt := 0; drawlinepixD(x3,y2+OutLen+TextLen,x3,y2,acolor,1,0,rt); if reghandle = 0 then AddRegion(x3-2,y2+Outlen+TextLen,x3+2,y2); // DrawText ty := y2+Outlen+TextLen-4; if TextPos = tpAbove then tx := x3-aHeight else if TextPos = tpBelow then tx := x3 else tx := x3-aHeight / 2; ArrangeBkMode; Windows.TextOut(FCanvas.Handle,Round(tx),Round(ty),pChar(DLabel),length(DLabel)); if reghandle = 0 then AddRegion(tx,ty,tx+aHeight,ty-TextLen); end else if (LStyle = vlsBottomLeft) then begin if et = etRow then rt := 1 else rt := 0; drawlinepixD(x3,y2+Outlen,x3,y2,acolor,1,0,rt); if reghandle = 0 then AddRegion(x3-2,y2+Outlen,x3+2,y2); drawlinepixD(x3,y2+Outlen,x3-TextLen-OutLen / 2,y2+Outlen,acolor,1,0,0); if reghandle = 0 then AddRegion(x3,y2+Outlen-2,x3-TextLen-OutLen / 2,y2+Outlen+2); // DrawText tx := x3-TextLen-OutLen / 2+4; if TextPos = tpAbove then ty := y2+OutLen-aHeight else if TextPos = tpBelow then ty := y2+OutLen else ty := y2+OutLen-aHeight / 2; ArrangeBkMode; Windows.TextOut(FCanvas.Handle,Round(tx),round(ty),pChar(DLabel),length(DLabel)); if reghandle = 0 then AddRegion(tx,ty,tx+TextLen,ty+AHeight); end else if (LStyle = vlsBottomRight) then begin if et = etRow then rt := 1 else rt := 0; drawlinepixD(x3,y2+Outlen,x3,y2,acolor,1,0,rt); if reghandle = 0 then AddRegion(x3-2,y2+Outlen,x3+2,y2); drawlinepixD(x3,y2+Outlen,x3+TextLen+OutLen / 2,y2+Outlen,acolor,1,0,0); if reghandle = 0 then AddRegion(x3,y2+Outlen-2,x3+TextLen+OutLen / 2,y2+Outlen+2); // DrawText tx := x3+4; if TextPos = tpAbove then ty := y2+OutLen-aHeight else if TextPos = tpBelow then ty := y2+OutLen else ty := y2+OutLen-aHeight / 2; ArrangeBkMode; Windows.TextOut(FCanvas.Handle,round(tx),round(ty),pChar(DLabel),length(DLabel)); if reghandle = 0 then AddRegion(tx,ty,tx+TextLen,ty+AHeight); end; end; rg := 1; if et = etDot then begin DrawCircle(ap3.x,ap1.y,1,acolor,1,0,acolor,0,rg,false); DrawCircle(ap3.x,ap2.y,1,acolor,1,0,acolor,0,rg,false); end else if et = etNick then begin drawlinepixD(x3+NickD,y1-NickD,x3-NickD,y1+NickD,acolor,1,0,0); drawlinepixD(x3+NickD,y2-NickD,x3-NickD,y2+NickD,acolor,1,0,0); end; end; if regHandle = 0 then RegHandle := Reg; //fcanvas.brush.style := bsSolid; //fcanvas.brush.color := clred; //FillRgn(fcanvas.handle,RegHandle,fcanvas.brush.handle); if dLabel <> '' then begin Fcanvas.Font := oldFont; afont.Free; end; end; Procedure TPCDrawEngine.DrawAlignedDim(ap1,ap2,ap3:TDoublePoint; dLabel: String; fontName: TFontName; Styles:TFontStyles;aColor,TextColor: integer; aheight: Double; LStyle:TADimLabelStyle; TextPos: TDimTextPos; et: TEndType; tHorz: Boolean;var RegHandle: HRGN); var x1,x2,x3,y1,y2,y3,tx,ty: Double; d,t,nickD,TH: Double; textLen,rt: Integer; TM : TTextMetric; FontRecord : TLogFont; aFont: TFont; r: Trect; OutLen,headLen: Double; rg,reg:HRGN; oldFont : TFont; p1,p2,p3: TdOUBLEPoint; rad,z: double; ang: integer; Procedure AddTextRegion(p1:TDoublepoint); var tReg: HRGN; ang: double; begin if tHorz then ang := 0 else ang := rad; tReg := CreateRotatedRgn(p1,TextLen,aHeight,ang); CombineRgn(Reg,reg,treg,RGN_OR); DeleteObject(tReg); end; Procedure AddRegion(p1,p2:TDoublepoint); var tReg: HRGN; begin tReg := CreateLinearRgn(p1,p2); CombineRgn(Reg,reg,treg,RGN_OR); DeleteObject(tReg); end; Procedure ArrangeBkMode; begin if (Textpos = tpOnline) or ((LStyle = alsInner) and (tHorz)) then begin SetbkColor(FCanvas.Handle,clWhite); SetBkMode(FCanvas.Handle,OPAQUE); end; end; begin reg := 0; p1 := ap1; p2 := ap2; p3 := ap3; z:= 0; ConvertCoord(p1.x,p1.y,z); ConvertCoord(p2.x,p2.y,z); ConvertCoord(p3.x,p3.y,z); if p1.x > p2.x then begin ap1 := p1; p1 := p2; p2 := ap1; end; rad := GetRadOfLine(p1,p2); ang := Round((rad/pi)*1800); p2 := RotatePoint(p1,p2,-rad); p3 := RotatePoint(p1,p3,-rad); p3.x := (p1.x+p2.x) / 2; x1 := p1.x; y1 := p1.y; x2 := p2.x; y2 := p2.y; x3 := p3.x; y3 := p3.y; Outlen := 8; ConvertDim(Outlen); HeadLen := HeadLength; ConvertDim(HeadLen); nickD := 1; ConvertDim(nickD); TextLen := 0; oldFont := nil; //#From Oleg# //20.09.2010 aFont := nil; //#From Oleg# //20.09.2010 if dLabel <> '' then begin oldFont := Fcanvas.font; aFont := Tfont.Create; aFont.Name := FontName; aFont.Style := Styles; aFont.Color := TextColor; FCanvas.Font := aFont; // Get Font Record GetObject(FCanvas.Font.Handle,sizeof(FontRecord),Addr(FontRecord)); // Set Font Height ConvertDim(aHeight); FontRecord.lfHeight := round(aHeight); if not tHorz then FontRecord.lfEscapement := -ang; // Create Modified Font FCanvas.Font.handle := CreateFontIndirect(FontRecord); GetTextMetrics(FCanvas.Handle,TM); // Set Font Width GetObject(FCanvas.Font.Handle,sizeof(FontRecord),Addr(FontRecord)); FontRecord.lfWidth := round(TM.tmAveCharWidth*0.9); FCanvas.Font.handle := CreateFontIndirect(FontRecord); textLen := FCanvas.TextWidth(Dlabel); end; // Draw Guides if y3 > y1 then d := 1 else d := -1; ConvertDim(d); p1 := DoublePoint(x1,y1+d); p2 := DoublePoint(x1,y3+d); p1 := RotatePoint(DoublePoint(x1,y1),p1,rad); p2 := RotatePoint(DoublePoint(x1,y1),p2,rad); drawlinepixD(p1.x,p1.y,p2.x,p2.y,aColor,1,0,0); if RegHandle = 0 then Reg := CreateLinearRgn(p1,p2); if y3 > y2 then d := 1 else d := -1; ConvertDim(d); p1 := DoublePoint(x2,y2+d); p2 := DoublePoint(x2,y3+d); p1 := RotatePoint(DoublePoint(x1,y1),p1,rad); p2 := RotatePoint(DoublePoint(x1,y1),p2,rad); drawlinepixD(p1.x,p1.y,p2.x,p2.y,aColor,1,0,0); if RegHandle = 0 then AddRegion(p1,p2); SetBkMode(FCanvas.Handle,TRANSPARENT); t := -1; if x1 <> x2 then begin if LStyle = alsInner then begin if et = etRow then rt := 3 else rt := 0; p1 := DoublePoint(x1,y3); p2 := DoublePoint(x2,y3); p1 := RotatePoint(DoublePoint(x1,y1),p1,rad); p2 := RotatePoint(DoublePoint(x1,y1),p2,rad); drawlinepixD(p1.x,p1.y,p2.x,p2.y,acolor,1,0,rt); if RegHandle = 0 then AddRegion(p1,p2); if tHorz then begin tx := (x1+x2) / 2; ty := y3-(aHeight / 2); p1 := RotatePoint(DoublePoint(x1,y1),DoublePoint(tx,ty),rad); p1.x := p1.x - (Textlen / 2); end else begin tx := ((x1+x2) / 2) - (Textlen / 2); if TextPos = tpAbove then ty := y3 - aHeight else if TextPos = tpBelow then ty := y3 else if TextPos = tpOnline then ty := y3 - (aHeight / 2); p1 := RotatePoint(DoublePoint(x1,y1),DoublePoint(tx,ty),rad); end; ArrangeBkMode; Windows.TextOut(FCanvas.Handle,Round(P1.x),Round(P1.y),pChar(DLabel),length(DLabel)); if RegHandle = 0 then AddTextRegion(p1); end else if (LStyle = alsLeft) then begin if et = etRow then rt := 1 else rt := 0; if tHorz then p1 := DoublePoint(x1-OutLen,y3) else p1 := DoublePoint(x1-OutLen-TextLen,y3); p2 := DoublePoint(x1,y3); p1 := RotatePoint(DoublePoint(x1,y1),p1,rad); p2 := RotatePoint(DoublePoint(x1,y1),p2,rad); drawlinepixD(p1.x,p1.y,p2.x,p2.y,acolor,1,0,rt); if RegHandle = 0 then AddRegion(p1,p2); if tHorz then begin p1 := RotatePoint(DoublePoint(x1,y1),DoublePoint(x1-OutLen,y3),rad); p2 := DoublePoint(p1.x-TextLen-OutLen / 2,p1.y); drawlinepixD(p1.x,p1.y,p2.x,p2.y,acolor,1,0,0); if RegHandle = 0 then AddRegion(p1,p2); end; if et = etRow then rt := 2 else rt := 0; p1 := DoublePoint(x2,y3); p2 := DoublePoint(x2+Outlen,y3); p1 := RotatePoint(DoublePoint(x1,y1),p1,rad); p2 := RotatePoint(DoublePoint(x1,y1),p2,rad); drawlinepixD(p1.x,p1.y,p2.x,p2.y,acolor,1,0,rt); if RegHandle = 0 then AddRegion(p1,p2); if tHorz then begin p1 := RotatePoint(DoublePoint(x1,y1),DoublePoint(x1-OutLen,y3),rad); p1 := DoublePoint(p1.x-TextLen-OutLen / 2+4,p1.y); if TextPos = tpAbove then p1.y := p1.y - aHeight else if TextPos = tpBelow then p1.y := p1.y else if TextPos = tpOnline then p1.y := p1.y - (aHeight / 2); if RegHandle = 0 then AddTextRegion(p1); end else begin tx := (x1 - Textlen-Outlen+4); if TextPos = tpAbove then ty := y3 - aHeight else if TextPos = tpBelow then ty := y3 else if TextPos = tpOnline then ty := y3 - (aHeight / 2); p1 := RotatePoint(DoublePoint(x1,y1),DoublePoint(tx,ty),rad); end; ArrangeBkMode; Windows.TextOut(FCanvas.Handle,Round(P1.x),Round(P1.y),pChar(DLabel),length(DLabel)); if RegHandle = 0 then AddTextRegion(p1); end else if (LStyle = alsRight) then begin if et = etRow then rt := 1 else rt := 0; p1 := DoublePoint(x1-OutLen,y3); p2 := DoublePoint(x1,y3); p1 := RotatePoint(DoublePoint(x1,y1),p1,rad); p2 := RotatePoint(DoublePoint(x1,y1),p2,rad); drawlinepixD(p1.x,p1.y,p2.x,p2.y,acolor,1,0,rt); if RegHandle = 0 then AddRegion(p1,p2); if et = etRow then rt := 2 else rt := 0; p1 := DoublePoint(x2,y3); if tHorz then p2 := DoublePoint(x2+Outlen,y3) else p2 := DoublePoint(x2+Outlen+TextLen,y3); p1 := RotatePoint(DoublePoint(x1,y1),p1,rad); p2 := RotatePoint(DoublePoint(x1,y1),p2,rad); drawlinepixD(p1.x,p1.y,p2.x,p2.y,acolor,1,0,rt); if RegHandle = 0 then AddRegion(p1,p2); if tHorz then begin p1 := RotatePoint(DoublePoint(x1,y1),DoublePoint(x2+OutLen,y3),rad); p2 := DoublePoint(p1.x+TextLen+OutLen / 2,p1.y); drawlinepixD(p1.x,p1.y,p2.x,p2.y,acolor,1,0,0); if RegHandle = 0 then AddRegion(p1,p2); end; if tHorz then begin p1 := RotatePoint(DoublePoint(x1,y1),DoublePoint(x2+OutLen,y3),rad); p1 := DoublePoint(p1.x+4,p1.y); if TextPos = tpAbove then p1.y := p1.y - aHeight else if TextPos = tpBelow then p1.y := p1.y else if TextPos = tpOnline then p1.y := p1.y - (aHeight / 2); end else begin tx := (x2+OutLen-4); if TextPos = tpAbove then ty := y3 - aHeight else if TextPos = tpBelow then ty := y3 else if TextPos = tpOnline then ty := y3 - (aHeight / 2); p1 := RotatePoint(DoublePoint(x1,y1),DoublePoint(tx,ty),rad); end; ArrangeBkMode; Windows.TextOut(FCanvas.Handle,Round(P1.x),Round(P1.y),pChar(DLabel),length(DLabel)); if RegHandle = 0 then AddTextRegion(p1); end; rg := 1; if et = etDot then begin p1 := DoublePoint(x1,y3); p2 := DoublePoint(x2,y3); p1 := RotatePoint(DoublePoint(x1,y1),p1,rad); p2 := RotatePoint(DoublePoint(x1,y1),p2,rad); DrawCirclePix(Round(p1.x),Round(p1.y),Round(NickD),acolor,1,0,acolor,0,rg); DrawCirclePix(Round(p2.x),Round(p2.y),Round(NickD),acolor,1,0,acolor,0,rg); end else if et = etNick then begin p1 := DoublePoint(x1+NickD,y3-NickD); p2 := DoublePoint(x1-NickD,y3+NickD); p1 := RotatePoint(DoublePoint(x1,y1),p1,rad); p2 := RotatePoint(DoublePoint(x1,y1),p2,rad); drawlinepixD(p1.x,p1.y,p2.x,p2.y,acolor,1,0,0); p1 := DoublePoint(x2+NickD,y3-NickD); p2 := DoublePoint(x2-NickD,y3+NickD); p1 := RotatePoint(DoublePoint(x1,y1),p1,rad); p2 := RotatePoint(DoublePoint(x1,y1),p2,rad); drawlinepixD(p1.x,p1.y,p2.x,p2.y,acolor,1,0,0); end; end; if regHandle = 0 then RegHandle := Reg; if dLabel <> '' then begin Fcanvas.Font := oldFont; afont.Free; end; end; Procedure TPCDrawEngine.DrawCircleDim(ap1,ap2:TDoublePoint; dLabel: String; fontName: TFontName; Styles:TFontStyles;aColor,TextColor: integer; aheight: Double; LStyle:TCDimLabelStyle; TextPos: TDimTextPos; et: TEndType; tHorz: Boolean;DrawOuterGuide,DrawInnerGuide:Boolean;var RegHandle: HRGN); var x1,x2,x3,y1,y2,y3,tx,ty: Double; d,t,nickD,TH: Double; textLen,rt: Integer; TM : TTextMetric; FontRecord : TLogFont; aFont: TFont; r: Trect; OutLen,headLen: Double; rg,reg:HRGN; oldFont : TFont; p1,p2,p3: TdOUBLEPoint; rad,z: double; ang: integer; Procedure AddTextRegion(p1:TDoublepoint); var tReg: HRGN; ang: double; begin if tHorz then ang := 0 else ang := rad; tReg := CreateRotatedRgn(p1,TextLen,aHeight,ang); CombineRgn(Reg,reg,treg,RGN_OR); DeleteObject(tReg); end; Procedure AddRegion(p1,p2:TDoublepoint); var tReg: HRGN; begin tReg := CreateLinearRgn(p1,p2); CombineRgn(Reg,reg,treg,RGN_OR); DeleteObject(tReg); end; Procedure ArrangeBkMode; begin if (Textpos = tpOnline) or ((LStyle = clsInner) and (tHorz)) then begin SetbkColor(FCanvas.Handle,clWhite); SetBkMode(FCanvas.Handle,OPAQUE); end; end; begin reg := 0; p1 := ap1; p2 := ap2; p3 := MPoint(p1,p2); z:=0; ConvertCoord(p1.x,p1.y,z); ConvertCoord(p2.x,p2.y,z); ConvertCoord(p3.x,p3.y,z); if p1.x > p2.x then begin ap1 := p1; p1 := p2; p2 := ap1; end; rad := GetRadOfLine(p1,p2); ang := Round((rad/pi)*1800); p2 := RotatePoint(p1,p2,-rad); p3 := RotatePoint(p1,p3,-rad); p3.x := (p1.x+p2.x) / 2; x1 := p1.x; y1 := p1.y; x2 := p2.x; y2 := p2.y; x3 := p3.x; y3 := p3.y; Outlen := 8; ConvertDim(Outlen); HeadLen := HeadLength; ConvertDim(HeadLen); nickD := 1; ConvertDim(nickD); TextLen := 0; oldFont := nil; //#From Oleg# //20.09.2010 aFont := nil; //#From Oleg# //20.09.2010 if dLabel <> '' then begin oldFont := Fcanvas.font; aFont := Tfont.Create; aFont.Name := FontName; aFont.Style := Styles; aFont.Color := TextColor; FCanvas.Font := aFont; // Get Font Record GetObject(FCanvas.Font.Handle,sizeof(FontRecord),Addr(FontRecord)); // Set Font Height ConvertDim(aHeight); FontRecord.lfHeight := round(aHeight); if not tHorz then FontRecord.lfEscapement := -ang; // Create Modified Font FCanvas.Font.handle := CreateFontIndirect(FontRecord); GetTextMetrics(FCanvas.Handle,TM); // Set Font Width GetObject(FCanvas.Font.Handle,sizeof(FontRecord),Addr(FontRecord)); FontRecord.lfWidth := round(TM.tmAveCharWidth*0.9); FCanvas.Font.handle := CreateFontIndirect(FontRecord); textLen := FCanvas.TextWidth(Dlabel); end; if RegHandle = 0 then Reg := CreateLinearRgn(p1,p1); SetBkMode(FCanvas.Handle,TRANSPARENT); t := -1; if x1 <> x2 then begin if DrawInnerGuide then begin if et = etRow then rt := 3 else rt := 0; p1 := DoublePoint(x1,y3); p2 := DoublePoint(x2,y3); p1 := RotatePoint(DoublePoint(x1,y1),p1,rad); p2 := RotatePoint(DoublePoint(x1,y1),p2,rad); drawlinepixD(p1.x,p1.y,p2.x,p2.y,acolor,1,0,rt); if RegHandle = 0 then AddRegion(p1,p2); end; if (LStyle = clsInner) then begin if et = etRow then rt := 3 else rt := 0; p1 := DoublePoint(x1,y3); p2 := DoublePoint(x2,y3); p1 := RotatePoint(DoublePoint(x1,y1),p1,rad); p2 := RotatePoint(DoublePoint(x1,y1),p2,rad); if not DrawInnerGuide then begin drawlinepixD(p1.x,p1.y,p2.x,p2.y,acolor,1,0,rt); if RegHandle = 0 then AddRegion(p1,p2); end; if tHorz then begin tx := (x1+x2) / 2; ty := y3-(aHeight / 2); p1 := RotatePoint(DoublePoint(x1,y1),DoublePoint(tx,ty),rad); p1.x := p1.x - (Textlen / 2); end else begin tx := ((x1+x2) / 2) - (Textlen / 2); if TextPos = tpAbove then ty := y3 - aHeight else if TextPos = tpBelow then ty := y3 else if TextPos = tpOnline then ty := y3 - (aHeight / 2); p1 := RotatePoint(DoublePoint(x1,y1),DoublePoint(tx,ty),rad); end; ArrangeBkMode; Windows.TextOut(FCanvas.Handle,Round(P1.x),Round(P1.y),pChar(DLabel),length(DLabel)); if RegHandle = 0 then AddTextRegion(p1); end else if (LStyle = clsLeft) then begin if et = etRow then rt := 1 else rt := 0; if drawInnerGuide then rt := 0; if tHorz then p1 := DoublePoint(x1-OutLen,y3) else p1 := DoublePoint(x1-OutLen-TextLen,y3); p2 := DoublePoint(x1,y3); p1 := RotatePoint(DoublePoint(x1,y1),p1,rad); p2 := RotatePoint(DoublePoint(x1,y1),p2,rad); drawlinepixD(p1.x,p1.y,p2.x,p2.y,acolor,1,0,rt); if RegHandle = 0 then AddRegion(p1,p2); if tHorz then begin p1 := RotatePoint(DoublePoint(x1,y1),DoublePoint(x1-OutLen,y3),rad); p2 := DoublePoint(p1.x-TextLen-OutLen / 2,p1.y); drawlinepixD(p1.x,p1.y,p2.x,p2.y,acolor,1,0,0); if RegHandle = 0 then AddRegion(p1,p2); end; if et = etRow then rt := 2 else rt := 0; if DrawInnerGuide then rt := 0; p1 := DoublePoint(x2,y3); p2 := DoublePoint(x2+Outlen,y3); p1 := RotatePoint(DoublePoint(x1,y1),p1,rad); p2 := RotatePoint(DoublePoint(x1,y1),p2,rad); if DrawOuterGuide then begin drawlinepixD(p1.x,p1.y,p2.x,p2.y,acolor,1,0,rt); if RegHandle = 0 then AddRegion(p1,p2); end; if tHorz then begin p1 := RotatePoint(DoublePoint(x1,y1),DoublePoint(x1-OutLen,y3),rad); p1 := DoublePoint(p1.x-TextLen-OutLen / 2+4,p1.y); if TextPos = tpAbove then p1.y := p1.y - aHeight else if TextPos = tpBelow then p1.y := p1.y else if TextPos = tpOnline then p1.y := p1.y - (aHeight / 2); if RegHandle = 0 then AddTextRegion(p1); end else begin tx := (x1 - Textlen-Outlen+4); if TextPos = tpAbove then ty := y3 - aHeight else if TextPos = tpBelow then ty := y3 else if TextPos = tpOnline then ty := y3 - (aHeight / 2); p1 := RotatePoint(DoublePoint(x1,y1),DoublePoint(tx,ty),rad); end; ArrangeBkMode; Windows.TextOut(FCanvas.Handle,Round(P1.x),Round(P1.y),pChar(DLabel),length(DLabel)); if RegHandle = 0 then AddTextRegion(p1); end else if (LStyle = clsRight) then begin if et = etRow then rt := 1 else rt := 0; if DrawInnerGuide then rt := 0; p1 := DoublePoint(x1-OutLen,y3); p2 := DoublePoint(x1,y3); p1 := RotatePoint(DoublePoint(x1,y1),p1,rad); p2 := RotatePoint(DoublePoint(x1,y1),p2,rad); if DrawOuterGuide then begin drawlinepixD(p1.x,p1.y,p2.x,p2.y,acolor,1,0,rt); if RegHandle = 0 then AddRegion(p1,p2); end; if et = etRow then rt := 2 else rt := 0; if DrawInnerGuide then rt := 0; p1 := DoublePoint(x2,y3); if tHorz then p2 := DoublePoint(x2+Outlen,y3) else p2 := DoublePoint(x2+Outlen+TextLen,y3); p1 := RotatePoint(DoublePoint(x1,y1),p1,rad); p2 := RotatePoint(DoublePoint(x1,y1),p2,rad); drawlinepixD(p1.x,p1.y,p2.x,p2.y,acolor,1,0,rt); if RegHandle = 0 then AddRegion(p1,p2); if tHorz then begin p1 := RotatePoint(DoublePoint(x1,y1),DoublePoint(x2+OutLen,y3),rad); p2 := DoublePoint(p1.x+TextLen+OutLen / 2,p1.y); drawlinepixD(p1.x,p1.y,p2.x,p2.y,acolor,1,0,0); if RegHandle = 0 then AddRegion(p1,p2); end; if tHorz then begin p1 := RotatePoint(DoublePoint(x1,y1),DoublePoint(x2+OutLen,y3),rad); p1 := DoublePoint(p1.x+4,p1.y); if TextPos = tpAbove then p1.y := p1.y - aHeight else if TextPos = tpBelow then p1.y := p1.y else if TextPos = tpOnline then p1.y := p1.y - (aHeight / 2); end else begin tx := (x2+OutLen-4); if TextPos = tpAbove then ty := y3 - aHeight else if TextPos = tpBelow then ty := y3 else if TextPos = tpOnline then ty := y3 - (aHeight / 2); p1 := RotatePoint(DoublePoint(x1,y1),DoublePoint(tx,ty),rad); end; ArrangeBkMode; Windows.TextOut(FCanvas.Handle,Round(P1.x),Round(P1.y),pChar(DLabel),length(DLabel)); if RegHandle = 0 then AddTextRegion(p1); end; rg := 1; if et = etDot then begin p1 := DoublePoint(x1,y3); p2 := DoublePoint(x2,y3); p1 := RotatePoint(DoublePoint(x1,y1),p1,rad); p2 := RotatePoint(DoublePoint(x1,y1),p2,rad); DrawCirclePix(Round(p1.x),Round(p1.y),Round(NickD),acolor,1,0,acolor,0,rg); DrawCirclePix(Round(p2.x),Round(p2.y),Round(NickD),acolor,1,0,acolor,0,rg); end else if et = etNick then begin p1 := DoublePoint(x1+NickD,y3-NickD); p2 := DoublePoint(x1-NickD,y3+NickD); p1 := RotatePoint(DoublePoint(x1,y1),p1,rad); p2 := RotatePoint(DoublePoint(x1,y1),p2,rad); drawlinepixD(p1.x,p1.y,p2.x,p2.y,acolor,1,0,0); p1 := DoublePoint(x2+NickD,y3-NickD); p2 := DoublePoint(x2-NickD,y3+NickD); p1 := RotatePoint(DoublePoint(x1,y1),p1,rad); p2 := RotatePoint(DoublePoint(x1,y1),p2,rad); drawlinepixD(p1.x,p1.y,p2.x,p2.y,acolor,1,0,0); end; end; if regHandle = 0 then RegHandle := Reg; if dLabel <> '' then begin Fcanvas.Font := oldFont; afont.Free; end; end; Procedure TPCDrawEngine.DrawArcDim(ap1: TDoublePoint;Radius,SAngle,FAngle:Double;dLabel: String; fontName: TFontName; Styles:TFontStyles;aColor,TextColor: integer; aheight,GuideLen: Double; LStyle:TArcDimLabelStyle;var Reghandle: HRGN; var p1,p2: TDoublePoint); var x1,x2,x3,y1,y2,y3,tx,ty,per: Double; rad,d,t,nickD,MAngle: Double; TextLen,TH,tw,rt: Integer; TM : TTextMetric; FontRecord : TLogFont; aFont: TFont; r: Trect; OutLen,headLen: Double; rg,reg:HRGN; oldFont : TFont; dp1,dp2,xp1,xp2,p3: TdOUBLEPoint; dim,z: Double; ang: integer; bc: Integer; bs: Integer; Procedure AddTextRegion(p1:TDoublepoint); var tReg: HRGN; ang: double; begin ang := 0; tReg := CreateRotatedRgn(p1,tw,th,ang); CombineRgn(Reghandle,Reghandle,treg,RGN_OR); DeleteObject(tReg); end; Procedure AddRegion(p1,p2:TDoublepoint); var tReg: HRGN; z: Double; begin z := 0; ConvertCoord(p1.x,p1.y,z); ConvertCoord(p2.x,p2.y,z); tReg := CreateLinearRgn(p1,p2); CombineRgn(Reghandle,Reghandle,treg,RGN_OR); DeleteObject(tReg); end; Procedure AddRectRgn(p1,p2,p3,p4:Integer); var tReg: HRGN; begin tReg := CreateRectRgn(p1,p2,p3,p4); CombineRgn(Reghandle,Reghandle,treg,RGN_OR); DeleteObject(tReg); end; begin rg := 1; //bc := clWhite; //if Canvas.Pen.Mode = pmXor then // bc := clBlack; bc := clNone; bs := Ord(bsClear); if radius <> 0 then begin if (LStyle = rlsInner) or (sAngle = Fangle) then begin //drawbezarc(ap1.x,ap1.y,radius,SAngle,FAngle,acolor,1,ord(psSolid), // 0,0,0,rg,p1,p2,false,3); drawbezarc(ap1.x,ap1.y,radius,SAngle,FAngle,acolor,1,ord(psSolid), bc,bs,0,rg,p1,p2,false,3); end else if LStyle = rlsOuter then begin per := pi*radius; MAngle := pi/(per/8); drawbezarc(ap1.x,ap1.y,radius,SAngle-MAngle,SAngle,acolor,1,ord(psSolid), 0,0,0,rg,xp1,p1,false,1); drawbezarc(ap1.x,ap1.y,radius,FAngle,FAngle+MAngle,acolor,1,ord(psSolid), 0,0,0,rg,p2,xp2,false,2); end; end; if (GuideLen < 0) then dim := 1.5 else dim := -1.5; if (FAngle <> SAngle) and (GuideLen <> 0) then begin rad := GetRadOfLine(p1,ap1); xp1 := RotatePoint(ap1,p1,-rad); xp1 := DoublePoint(xp1.x+dim,xp1.y); xp1 := RotatePoint(ap1,xp1,rad); rad := GetRadOfLine(p2,ap1); xp2 := RotatePoint(ap1,p2,-rad); xp2 := DoublePoint(xp2.x+dim,xp2.y); xp2 := RotatePoint(ap1,xp2,rad); if GuideLen = Radius then begin dp1 := ap1; dp2 := ap1; end else begin rad := GetRadOfLine(p1,ap1); dp1 := RotatePoint(ap1,p1,-rad); dp1 := DoublePoint(dp1.x+GuideLen,dp1.y); dp1 := RotatePoint(ap1,dp1,rad); rad := GetRadOfLine(p2,ap1); dp2 := RotatePoint(ap1,p2,-rad); dp2 := DoublePoint(dp2.x+GuideLen,dp2.y); dp2 := RotatePoint(ap1,dp2,rad); end; try drawline(xp1.x,xp1.y,dp1.x,dp1.y,acolor,1,ord(psSolid),0); drawline(xp2.x,xp2.y,dp2.x,dp2.y,acolor,1,ord(psSolid),0); except end; end; if FAngle = SAngle then begin p3 := DoublePoint(ap1.x+radius+3,ap1.y); end else begin if (FAngle < SAngle) then begin MAngle := SAngle+((2*pi)-SAngle+FAngle)/2; end else begin MAngle := (SAngle+FAngle)/2; end; p3 := DoublePoint(ap1.x+radius+3,ap1.y); p3 := RotatePoint(ap1,p3,MAngle); end; if dLabel <> '' then begin oldFont := Fcanvas.font; aFont := Tfont.Create; aFont.Name := FontName; aFont.Style := Styles; aFont.Color := TextColor; FCanvas.Font := aFont; // Get Font Record GetObject(FCanvas.Font.Handle,sizeof(FontRecord),Addr(FontRecord)); // Set Font Height ConvertDim(aHeight); FontRecord.lfHeight := round(aHeight); // Create Modified Font FCanvas.Font.handle := CreateFontIndirect(FontRecord); GetTextMetrics(FCanvas.Handle,TM); // Set Font Width GetObject(FCanvas.Font.Handle,sizeof(FontRecord),Addr(FontRecord)); FontRecord.lfWidth := round(TM.tmAveCharWidth*0.9); FCanvas.Font.handle := CreateFontIndirect(FontRecord); textLen := FCanvas.TextWidth(Dlabel); end; tx := p3.x; ty := p3.y; z := 0; ConvertCoord(tx,ty,z); th := FCanvas.TextHeight(Dlabel); tw := FCanvas.TextWidth(Dlabel); FCanvas.Brush.Color := bc; FCanvas.Brush.Style := TBrushStyle(bs); Windows.TextOut(FCanvas.Handle,Round(tx-(tw div 2)),Round(ty - (th div 2) ),pChar(DLabel),length(DLabel)); if regHandle = 0 then begin RegHandle := CreateRectRgn(Round(tx-(tw div 2)),Round(ty - (th div 2)),Round(tx+(tw div 2)),Round(ty+ (th div 2))); if (FAngle <> SAngle) and (GuideLen <> 0) then begin AddRegion(xp1,dp1); AddRegion(xp2,dp2); end; end; end; procedure TPCDrawEngine.drawselectionpoint(x,y,z: Double; pType: TPointType; dim : double; col : TColor; isXOR:Boolean = False); var p,ap1,ap2:TdoublePoint; tx,ty,tz: Double; begin if pType = ptTarget then begin tx := x; ty := y; tz :=z; drawselectionpoint(tx,ty,tz,ptCross,dim,col,isXOR); tx := x; ty := y; tz :=z; drawselectionpoint(tx,ty,tz,ptECircle,dim/2,col,isXOR); exit; end; FCanvas.pen.color := col; FCanvas.pen.width := 1; FCanvas.pen.style := psSolid; if isXor then FCanvas.pen.mode := pmXOr else FCanvas.pen.mode := pmCopy; //Tolik 03/02/2022 -- //FCanvas.brush.color := col; $00E8731A FCanvas.brush.color := $00E8731A; // FCanvas.brush.style := bsSolid; ConvertCoord(x,y,z); case pType of ptRect : begin RectanglePix(x-dim,y-dim,x+dim,y+dim); end; ptCircle : begin ellipsePix(x-dim-1,y-dim-1,x+dim+1,y+dim+1); end; ptECircle : begin FCanvas.brush.style := bsClear; ellipsePix(x-dim-1,y-dim-1,x+dim+1,y+dim+1); end; ptRCenter: begin FCanvas.brush.style := bsClear; ellipsePix(x-dim-3,y-dim-3,x+dim+3,y+dim+3); FCanvas.brush.color := col; FCanvas.brush.style := bsSolid; ellipsePix(x-dim,y-dim,x+dim,y+dim); end; ptCross : begin movetoPix(x,y-dim);linetoPix(x,y+dim); movetoPix(x-dim,y);linetoPix(x+dim,y); end; ptStar : begin movetoPix(x-dim,y+dim);linetoPix(x+dim,y-dim); movetoPix(x+dim,y+dim);linetoPix(x-dim,y-dim); end; ptRow : begin movetoPix(x-dim+3,y+dim);linetoPix(x-dim+3,y-dim); linetoPix(x+dim+3,y);linetoPix(x-dim+3,y+dim); end; end; end; procedure PrintBitmap(Canvas: TCanvas; DestRect: TRect; Bitmap: TBitmap; ROP: Integer); VAR BitmapHeader: pBitmapInfo; BitmapImage : POINTER; HeaderSize : DWord; ImageSize : DWord; begin GetDIBSizes(Bitmap.Handle,HeaderSize,ImageSize); GetMem(BitmapHeader,HeaderSize); GetMem(BitmapImage,ImageSize); TRY GetDIB(Bitmap.Handle, Bitmap.Palette, BitmapHeader^, BitmapImage^); StretchDIBits(Canvas.Handle, DestRect.Left, DestRect.Top, // Destination Origin DestRect.Right - DestRect.Left, // Destination Width DestRect.Bottom - DestRect.Top, // Destination Height 0,0, // Source Origin Bitmap.Width, Bitmap.Height, // Source Width & Height BitmapImage, TBitmapInfo(BitmapHeader^), DIB_RGB_COLORS, ROP); FINALLY FreeMem(BitmapHeader); FreeMem(BitmapImage) END; END; {PrintBitmap} procedure stretchDrawGraphics(ACanvas : TCanvas; R : TRect; Graphic: TGraphic; transparent : boolean); var TmpRect: TRect; FactorX, FactorY: Double; TmpWidth, TmpHeight: Integer; CWidth, CHeight: Integer; BWidth, BHeight: Integer; begin if (ACanvas <> nil) and Assigned(ACanvas) and (Graphic <> nil) and Assigned(Graphic) and not Graphic.Empty then with ACanvas do try CWidth := R.Right - R.Left + 1 - 1; CHeight := R.Bottom - R.Top + 1 - 1; BWidth := Graphic.Width; BHeight := Graphic.Height; try if BWidth = 0 then FactorX := 0 else FactorX := CWidth /BWidth; if BHeight = 0 then FactorY := 0 else FactorY := CHeight /BHeight; except FactorX := 1; FactorY := 1; end; if FactorY < FactorX then begin TmpWidth := Round(BWidth * FactorY); TmpHeight := CHeight; end else begin TmpHeight := Round(BHeight * FactorX); TmpWidth := CWidth; end; SetRect(TmpRect, 0, 0, TmpWidth, TmpHeight); OffsetRect(TmpRect, R.Left + ((CWidth - TmpWidth) div 2),R.Top + ((CHeight - TmpHeight) div 2)); Graphic.Transparent := transparent; StretchDraw(TmpRect, Graphic); except end; end; procedure TPCDrawEngine.drawcurvesegment(p1, p2: TDoublepoint); var a: integer; x,y,mu,mu2,z: double; xp1,xp2: TDoublePoint; begin xP1 := p1; xp2 := p2;z := 0; ConvertCoord(xp1.x,xp1.y,z); MoveToPix(xp1.x,xp1.y); for a := 0 to 500 do begin mu := (1 / 500)*a; mu2 := (1-cos(mu*PI))/2; y := p1.y*(1-mu2)+p2.y*mu2; x := p1.x + (mu*(p2.x-p1.x)); ConvertCoord(x,y,z); LineToPix(x,y); end; end; Procedure TPCDrawEngine.DrawRTF(re: TRichEdit98; x1,y1,x2,y2: integer); begin DrawRtfToCanvas(re,x1,y1,x2,y2,fCanvas,true); end; Procedure TPCDrawEngine.DrawRTFToCanvas(re: TRichEdit98; x1,y1,x2,y2: Double; xCanvas: Tcanvas; convert: Boolean); var Range: TFormatRange; LogX, LogY, OldMap: Integer; fMetaFile: TMetaFile; DC: HDC; t,z:Double; begin z := 0; if convert then begin ConvertCoord(x1,y1,z); ConvertCoord(x2,y2,z); end; if x1>x2 then begin t := x1; x1 := x2; x2 := t; end; if y1>y2 then begin t := y1; y1 := y2; y2 := t; end; if assigned(re) then with re, Range do begin FillChar(Range, SizeOf(TFormatRange), 0); hdc := xCanvas.Handle; hdcTarget := hdc; LogX := GetDeviceCaps(hdc, LOGPIXELSX); LogY := GetDeviceCaps(hdc, LOGPIXELSY); rc.left := Round(x1 * 1440 / LogX); rc.right := round(x2 * 1440 / LogX); rc.top := round(y1 * 1440 / LogY); rc.bottom := round(y2 * 1440 / LogY); rcPage := rc; chrg.cpMin := 0; chrg.cpMax := -1; OldMap := SetMapMode(hdc, MM_TEXT); //setbkmode(hdc,TRANSPARENT); setbkmode(hdc,OPAQUE); if Assigned(re.Parent) then begin SendMessage(re.Handle, EM_FORMATRANGE, 0, 0); try SendMessage(re.Handle, EM_FORMATRANGE, 0, Longint(@Range)); hdc := xcanvas.handle; hdcTarget := hdc; SendMessage(Handle, EM_FORMATRANGE, 1, Longint(@Range)); finally SendMessage(Handle, EM_FORMATRANGE, 0, 0); SetMapMode(hdc, OldMap); end; end; end; end; Procedure TPCDrawEngine.DrawOleToCanvas(ole: TOLEContainer; x1,y1,x2,y2: Double; xCanvas: Tcanvas; convert: Boolean); var LogX, LogY, OldMap: Integer; fMetaFile: TMetaFile; t,z:Double; begin z := 0; if convert then begin ConvertCoord(x1,y1,z); ConvertCoord(x2,y2,z); end; if x1>x2 then begin t := x1; x1 := x2; x2 := t; end; if y1>y2 then begin t := y1; y1 := y2; y2 := t; end; if assigned(ole) then begin oleDraw(ole.OleObjectInterface ,DVASPECT_CONTENT,xCanvas.Handle,DR2R(x1,y1,x2,y2)); end; end; Function ProcessRichRecord(DC:HDC; HT:PHandleTable; rec:PEnhMetaRecord; count:integer; param: pointer): integer;stdcall; var rectext: PEMRExtTextOut; begin if (rec.iType = EMR_EXTTEXTOUTW) or (rec.iType = EMR_EXTTEXTOUTA) then begin rectext:= PEMRExtTextOut(rec); if rectext.emrtext.fOptions = 2 then rectext.emrtext.fOptions := 0 end; PlayEnhMetaFileRecord(DC,HT^,rec^,count); if rec.itype <> EMR_EOF then result := 1 else result := 0; end; procedure TPCDrawEngine.drawline(p1,p2:TDoublePoint); begin Moveto(p1); Lineto(p2); end; procedure TPCDrawEngine.drawDashLine(p1,p2:TDoublePoint); var done: Boolean; xp: TDoublePoint; begin xp := p1; done := False; repeat Moveto(xp); xp := PushPoint(xp,p2,2.0,done); LineTo(xp); xp := PushPoint(xp,p2,0.75,done); MoveTo(xp); until done; end; procedure TPCDrawEngine.drawbezier(p1,p2,p3,p4: TDoublePoint); var p: array [0..3] of TPoint; z: Double; begin ConvertCoord(p1.x,p1.y,z);p[0] := Dp2P(p1); ConvertCoord(p2.x,p2.y,z);p[1] := Dp2P(p2); ConvertCoord(p3.x,p3.y,z);p[2] := Dp2P(p3); ConvertCoord(p4.x,p4.y,z);p[3] := Dp2P(p4); PolyBezier(FCanvas.handle,p,4); end; procedure TPCDrawEngine.DrawEllipse(p1: TDoublePoint;ax,bx: Double;angle: Double); var sinAngle : real; cosAngle : real; theta : real; xp,yp : real; xr, yr : integer; li : integer; x,y,a,b,z : Double; points : array of TPoint; begin sinAngle := sin (angle); cosAngle := cos (angle); x := p1.x; y := p1.y; a := ax; b :=bx; z := 0; ConvertCoord(x,y,z); ConvertDim(a); ConvertDim(b); //if angle = 0 then //begin // FCanvas.Ellipse(x-a,y-b,x+a,y+b); //end //else begin SetLength(Points,500+1); for li := 0 to 500 do begin theta := (li/500) * 2*PI; // angle step xp := a * cos(theta); // ellipse point yp := b * sin(theta); // rotate ellipse point around center xr := Round (x - xp * cosAngle + yp * sinAngle); yr := Round (y + xp * sinAngle + yp * cosAngle); points[li].x := xr; points[li].y := yr; end; FCanvas.Polygon(points); end; end; function TPCDrawEngine.LineRegion(p1, p2: TDoublePoint; w: Double): HRGN; var np1,np2,np3,np4:TDoublePoint; pArr: TPointArr; begin SetLength(pArr,4); ConvertCoord(p1.x,p1.y,p1.z); ConvertCoord(p2.x,p2.y,p2.z); GetParallelPoints(p1,p2,np1,np2,w+1); GetParallelPoints(p1,p2,np3,np4,-(w+1)); pArr[0] := Point(round(np1.x),round(np1.y)); pArr[1] := Point(round(np2.x),round(np2.y)); pArr[2] := Point(round(np4.x),round(np4.y)); pArr[3] := Point(round(np3.x),round(np3.y)); result := PolygonRegion(pArr); end; procedure TPCDrawEngine.DrawVane(p1, p2: TDoublePoint; pColor, bColor: TColor; Dim,Mar: Double;HasFlans:Boolean; var regHandle:HRGN;Kortapa:Boolean; Covered:Boolean;SeloDist:Double;st:Integer;penS:Integer=0); var rad,sz,h: Double; ap1,ap2,ap3,ap4: TDoublePoint; fp1,fp2,fp3,fp4: TDoublePoint; p: array of TPoint; fMar: Double; kt1,kt2,kt3,kt4: TDoublePOint; tMar,tSize: Double; cp,sp,sp1,sp2,sp3,sp4,xp1,xp2: TDoublePoint; rgn:HRGN; selH: Double; begin tMar := 0.2; tSize := dim; fMar := 1; Selh := 1.5; ConvertDim(fMar); ConvertDim(Dim); ConvertDim(tMar); ConvertDim(tSize); ConvertDim(Selodist); ConvertDim(SelH); sz := dim/2; h := dim/2; ConvertDim(Mar); ConvertCoord(p1.x,p1.y,p1.z); ConvertCoord(p2.x,p2.y,p2.z); rad := GetRadOfLine(p1,p2); p2 := RotatePoint(p1,p2,-rad); kt2 := DoublePoint(p2.x,p2.y-(tSize/2)); kt3 := DoublePoint(p2.x,p2.y+(tSize/2)); kt1 := DoublePOint(kt2.x-tMar,kt2.y); kt4 := DoublePOint(kt3.x-tMar,kt3.y); p2 := DoublePoint(p2.x-sz-1-Mar,p2.y); ap1 := DoublePoint(p2.x-sz,p2.y-h); ap2 := DoublePoint(p2.x+sz,p2.y-h); ap3 := DoublePoint(p2.x+sz,p2.y+h); ap4 := DoublePoint(p2.x-sz,p2.y+h); fp1 := DoublePoint(p2.x-sz-fMar,p2.y-h); fp2 := DoublePoint(p2.x-sz-fmar,p2.y+h); fp3 := DoublePoint(p2.x+sz+fMar,p2.y-h); fp4 := DoublePoint(p2.x+sz+fmar,p2.y+h); ap1 := RotatePoint(p1,ap1,rad); ap2 := RotatePoint(p1,ap2,rad); ap3 := RotatePoint(p1,ap3,rad); ap4 := RotatePoint(p1,ap4,rad); fp1 := RotatePoint(p1,fp1,rad); fp2 := RotatePoint(p1,fp2,rad); fp3 := RotatePoint(p1,fp3,rad); fp4 := RotatePoint(p1,fp4,rad); kt1 := RotatePoint(p1,kt1,rad); kt2 := RotatePoint(p1,kt2,rad); kt3 := RotatePoint(p1,kt3,rad); kt4 := RotatePoint(p1,kt4,rad); cp := MPoint(ap1,ap3); SetLength(p,4); p[0] := Point(Round(ap1.x),Round(ap1.y)); p[1] := Point(Round(ap3.x),Round(ap3.y)); p[2] := Point(Round(ap2.x),Round(ap2.y)); p[3] := Point(Round(ap4.x),Round(ap4.y)); if SeloDist <> 0 then begin sp :=PointByDistToLine(p1,cp,selodist); xp1 := Mpoint(ap1,ap4); xp2 := Mpoint(ap2,ap3); sp1 :=PointByDistToLine(p1,xp1,selodist); sp2 :=PointByDistToLine(p1,xp2,selodist); sp3 := Mpoint(sp2,xp2,-selH); sp4 := Mpoint(sp1,xp1,-selH); DrawLinePix(round(cp.x),round(cp.y),round(sp.x),round(sp.y),pColor,1,penS,0); DrawLinePix(round(sp1.x),round(sp1.y),round(sp2.x),round(sp2.y),pColor,1,penS,0); DrawLinePix(round(sp2.x),round(sp2.y),round(sp3.x),round(sp3.y),pColor,1,penS,0); DrawLinePix(round(sp3.x),round(sp3.y),round(sp4.x),round(sp4.y),pColor,1,penS,0); DrawLinePix(round(sp4.x),round(sp4.y),round(sp1.x),round(sp1.y),pColor,1,penS,0); sp :=PointByDistToLine(p1,cp,selodist); end; Canvas.Pen.Style := TPenStyle(penS); Canvas.Pen.Width := 1; Canvas.Pen.Mode := pmCopy; Canvas.Pen.Color := pColor; Canvas.Brush.Color := bColor; Canvas.Brush.Style := TBrushStyle(st); WPolygon(p,regHandle); if hasFlans then begin DrawLinePix(round(fp1.x),round(fp1.y),round(fp2.x),round(fp2.y),pColor,2,penS,0); DrawLinePix(round(fp3.x),round(fp3.y),round(fp4.x),round(fp4.y),pColor,2,penS,0); end; if Kortapa then begin DrawLinePix(round(kt1.x),round(kt1.y),round(kt2.x),round(kt2.y),pColor,2,penS,0); DrawLinePix(round(kt2.x),round(kt2.y),round(kt3.x),round(kt3.y),pColor,2,penS,0); DrawLinePix(round(kt3.x),round(kt3.y),round(kt4.x),round(kt4.y),pColor,2,penS,0); end; if covered then begin cp := MPoint(fp1,fp4); fp1 := ScalePoint(cp,fp1,3.5,3.5); fp2 := ScalePoint(cp,fp2,3.5,3.5); fp3 := ScalePoint(cp,fp3,3.5,3.5); fp4 := ScalePoint(cp,fp4,3.5,3.5); DrawCover(fp1,fp2,fp4,fp3,pColor,false); end; end; procedure TPCDrawEngine.WPolygon(const p: array of TPoint; var RegHandle: HRGN; ADrawPoints: Pointer=nil); var ip: Pointer; i,size: Integer; xp: TPoint; hPenOld: HPEN; hPen1: HPEN; begin size := Length(p); ip := ADrawPoints; //31.10.2011 if ip = nil then //31.10.2011 begin GetMem(ip,(size+1)*8); for i := 0 to size do begin if i = size then xp := p[0] else xp := p[i]; //PInt(PChar(ip)+i*8+0)^:= xp.x; //PInt(PChar(ip)+i*8+4)^:= xp.y; PInt(PAnsiChar(ip)+i*8+0)^:= xp.x; PInt(PAnsiChar(ip)+i*8+4)^:= xp.y; end; end else Size := 4; //31.10.2011 Пока для TRectangle if (FCanvas.Pen.Mode <> pmXor) and (FCanvas.Pen.width > 1) then begin hPen1 := ExtCreatePenMy(FCanvas); hPenOld := SelectObject(FCanvas.Handle, hPen1);//связываем перо с контекстом Windows.Polygon(FCanvas.Handle, PPoints(ip)^,Size+1); if reghandle = 0 then reghandle := CreatePolygonRgn(PPoints(ip)^,size+1,ALTERNATE); if ADrawPoints = nil then FreeMem(ip,(size+1)*8); SelectObject(FCanvas.Handle, hPenOld); //восстанавливаем предыдущее состояние if Not FCachePen then //01.11.2011 DeleteObject(hPen1);//удаляем перо end else begin Windows.Polygon(FCanvas.Handle, PPoints(ip)^,Size+1); if reghandle = 0 then reghandle := CreatePolygonRgn(PPoints(ip)^,size+1,ALTERNATE); if ADrawPoints = nil then FreeMem(ip,(size+1)*8); end; end; procedure TPCDrawEngine.DrawIsoKombi(p1, p2: TDoublePoint; pColor, bColor: TColor; rad1,rad2: Double;var RegHandle: HRGN;Covered:Boolean;st:Integer); var cp1: TDoublePoint; ap1,ap2,ap3,ap4:TDoublePoint; d: Double; begin d := 10; ConvertDim(d); ConvertDim(rad1); ConvertDim(rad2); ConvertCoord(p1.x,p1.y,p1.z); ConvertCoord(p2.x,p2.y,p2.z); cp1 := MPoint(p2,p1,-rad1); DrawCirclePix(round(cp1.x),round(cp1.y),round(rad1),pColor,1,ord(psSOlid),bColor,st,RegHandle); DrawCirclePix(round(cp1.x),round(cp1.y),round(rad2),pColor,1,ord(psSOlid),bColor,st,RegHandle); DrawCenteredText(Point(Round(cp1.x),Round(cp1.y)),pColor,'G','Verdana',3.5,0); MovetoPix(round(cp1.x),round(cp1.y+rad1)); LinetoPix(round(cp1.x),round(cp1.y+rad1+rad1)); MovetoPix(round(cp1.x-rad1),round(cp1.y+rad1+(rad1/2))); LinetoPix(round(cp1.x+rad1),round(cp1.y+rad1+(rad1/2))); if Covered then begin ap1 := DoublePoint(cp1.x-d,cp1.y-d); ap2 := DoublePoint(cp1.x+d,cp1.y-d); ap3 := DoublePoint(cp1.x+d,cp1.y+d); ap4 := DoublePoint(cp1.x-d,cp1.y+d); DrawCover(ap1,ap2,ap3,ap4,pColor,false); end; end; procedure TPCDrawEngine.DrawIsoOcak(p1, p2: TDoublePoint; pColor, bColor: TColor; size: Double; var RegHandle: HRGN;st:Integer); var cp1: TDoublePoint; p: array [0..3] of TPoint; i: Integer; begin ConvertDim(size); ConvertCoord(p1.x,p1.y,p1.z); ConvertCoord(p2.x,p2.y,p2.z); cp1 := MPoint(p2,p1,-(size/2)); p[0] := Point(Round(cp1.x-(Size/2)),Round(cp1.y-(Size/2))); p[1] := Point(Round(cp1.x+(Size/2)),Round(cp1.y-(Size/2))); p[2] := Point(Round(cp1.x+(Size/2)),Round(cp1.y+(Size/2))); p[3] := Point(Round(cp1.x-(Size/2)),Round(cp1.y+(Size/2))); Canvas.Pen.Style := psSolid; Canvas.Pen.Width := 1; Canvas.Pen.Mode := pmCopy; Canvas.Pen.Color := pColor; Canvas.Brush.Style := TBrushStyle(st); Canvas.Brush.Color := bColor; WPolygon(p,RegHandle); p[0] := Point(Round(cp1.x-(Size/4)),Round(cp1.y-(Size/4))); p[1] := Point(Round(cp1.x+(Size/4)),Round(cp1.y-(Size/4))); p[2] := Point(Round(cp1.x+(Size/4)),Round(cp1.y+(Size/4))); p[3] := Point(Round(cp1.x-(Size/4)),Round(cp1.y+(Size/4))); for i := 0 to 3 do DrawCirclePix(p[i].X,p[i].Y,round(size/6),pColor,1,ord(psSOlid),bColor,ord(bsClear),RegHandle); end; procedure TPCDrawEngine.DrawIsoSoba(p1, p2: TDoublePoint; pColor, bColor: TColor; w, h: Double; var RegHandle: HRGN;st:Integer); var cp1: TDoublePoint; p: array [0..3] of TPoint; i: Integer; m: Double; Shifted: Boolean; begin m := 2.5; ConvertDim(m); ConvertDim(w); ConvertDim(h); Shifted := False; ConvertCoord(p1.x,p1.y,p1.z); ConvertCoord(p2.x,p2.y,p2.z); if p1.z = p2.z then begin if p1.y = p2.y then cp1 := MPoint(p2,p1,-(w/2)) else begin p1 := p2; p2 := DoublePoint(p2.x+(m),p2.y); cp1 := MPoint(p2,p1,-(w/2)); Shifted := True; end; end else begin cp1 := MPoint(p2,p1,-(h/2)); end; p[0] := Point(Round(cp1.x-(w/2)),Round(cp1.y-(h/2))); p[1] := Point(Round(cp1.x+(w/2)),Round(cp1.y-(h/2))); p[2] := Point(Round(cp1.x+(w/2)),Round(cp1.y+(h/2))); p[3] := Point(Round(cp1.x-(w/2)),Round(cp1.y+(h/2))); Canvas.Pen.Style := psSolid; Canvas.Pen.Width := 1; Canvas.Pen.Mode := pmCopy; Canvas.Pen.Color := pColor; Canvas.Brush.Style := TBrushStyle(st); Canvas.Brush.Color := bColor; WPolygon(p,RegHandle); if Shifted then begin MovetoPix(Round(p1.x),Round(p1.y)); LineToPix(Round(p2.x),Round(p2.y)); end; for i := 1 to 4 do begin MoveToPix(p[0].X+round(i*w/4),p[0].y); LineToPix(p[0].X+round(i*w/4),p[3].y); end; end; procedure TPCDrawEngine.DrawIsoSofben(p1, p2: TDoublePoint; pColor, bColor: TColor; rad1: Double; var RegHandle: HRGN;st:Integer); var cp1,lp1,lp2: TDoublePoint; begin ConvertDim(rad1); ConvertCoord(p1.x,p1.y,p1.z); ConvertCoord(p2.x,p2.y,p2.z); cp1 := MPoint(p2,p1,-rad1); DrawCirclePix(round(cp1.x),round(cp1.y),round(rad1),pColor,1,ord(psSOlid),bColor,st,RegHandle); MovetoPix(round(cp1.x),round(cp1.y+rad1)); LineToPix(round(cp1.x),round(cp1.y+rad1+rad1)); DrawRowPix(round(cp1.x),round(cp1.y+rad1),round(cp1.x),round(cp1.y+rad1+rad1),8,8,True); DrawCenteredText(Point(Round(cp1.x),Round(cp1.y)),pColor,'G','Verdana',3.5,0); end; procedure TPCDrawEngine.Drawtext(ap1: TDoublePoint; angle: Double; atext, afontName: String;Styles:TFontStyles;aColor:TColor; aheight: double; marx:double = 0;mary:double=0); var aFont,oldFont:TFont; TM : TTextMetric; FontRecord : TLogFont; begin ConvertDim(aHeight); oldFont := Fcanvas.font; aFont := Tfont.Create; aFont.Name := afontName; aFont.Style := Styles; aFont.Color := aColor; FCanvas.Font := aFont; ConvertCoord(ap1.x,ap1.y,ap1.z); // Set Font Height SetBkMode(Fcanvas.Handle,TRANSPARENT); ConvertDim(marx); ConvertDim(mary); // Get Font Record GetObject(FCanvas.Font.Handle,sizeof(FontRecord),Addr(FontRecord)); // Set Font Height FontRecord.lfHeight := Round(aHeight); // Create Modified Font FCanvas.Font.handle := CreateFontIndirect(FontRecord); if angle <> 0 then begin // Get Font Record GetObject(FCanvas.Font.Handle,sizeof(FontRecord),Addr(FontRecord)); FontRecord.lfEscapement := Round(1800*(angle/pi)); // Create Modified Font FCanvas.Font.handle := CreateFontIndirect(FontRecord); end; GetTextMetrics(FCanvas.Handle,TM); (* // Set Font Width GetObject(FCanvas.Font.Handle,sizeof(FontRecord),Addr(FontRecord)); FontRecord.lfWidth := round(TM.tmAveCharWidth*0.9); FCanvas.Font.handle := CreateFontIndirect(FontRecord); *) ap1.x := ap1.x+marx; ap1.y := ap1.y+mary; FCanvas.TextOut(Round(ap1.x),Round(ap1.y),aText); Fcanvas.Font := oldFont; afont.Free; end; procedure TPCDrawEngine.drawrect(p1: TDoublePoint; rw, rh: Double; color, awidth, style, bc, bs: integer;var rgn:HRGN); begin ConvertCoord(p1.x,p1.y,p1.z); ConvertDim(rw); ConvertDim(rh); FCanvas.pen.color := color; FCanvas.pen.width := awidth; FCanvas.pen.style := penstyles[style]; FCanvas.brush.color := bc; FCanvas.brush.style := TBrushStyle(bs); Fcanvas.Rectangle(Round(p1.x),round(p1.y),round(p1.x)+Round(rw),round(p1.y)+round(rh)); if rgn = 0 then rgn := CreateRectRgn(Round(p1.x),round(p1.y),round(p1.x)+Round(rw),round(p1.y)+Round(rw)); end; Procedure TPCDrawEngine.Drawtext(ap1: TDoublePoint; atext:TstringList; afontName: String;Styles:TFontStyles;aColor:TColor;aheight: double; var Region:HRGN; var tw,th: Double; marx:double = 0;mary:double=0); var twi,thi:Integer; begin tw := 0; th := 0; ConvertDim(aHeight); ConvertCoord(ap1.x,ap1.y,ap1.z); ConvertDim(marx); ConvertDim(mary); DrawMTextToCanvas(Point(Round(ap1.x),Round(ap1.y)),aText,aFontName,Styles,aColor,0, round(aHeight),round(marX),round(marY),0,Region,twi,thi,FCanvas); tw := twi; th := thi; DeconvertDim(tw); DeconvertDim(th); end; procedure TPCDrawEngine.Drawtext(ap1: TDoublePoint; atext: TstringList; afontName: String; Styles: TFontStyles; aColor: TColor; aheight: double; marx:double = 0;mary:double=0); var twi,thi:Integer; reg:HRGN; begin ConvertDim(aHeight); ConvertCoord(ap1.x,ap1.y,ap1.z); ConvertDim(marx); ConvertDim(mary); reg := 1; DrawMTextToCanvas(Point(Round(ap1.x),Round(ap1.y)),aText,aFontName,Styles,aColor,0, round(aHeight),round(marX),round(marY),0,reg,twi,thi,FCanvas); end; procedure TPCDrawEngine.drawrow(xp1, xp2: TDoublePoint; solid: Boolean;var rgn:HRGN;hl, hh: double); var pt : TDoublePointArr; begin //SetLength(pt,3); //CalcRowPoints(xp1.x,xp1.y,xp2.x,xp2.y,hl,hh,pt[0],pt[1],pt[2]); //if solid then Polygon(pt,rgn) else PolyLine(pt); //(* ConvertCoord(xp1.x,xp1.y,xp1.z); ConvertCoord(xp2.x,xp2.y,xp2.z); ConvertLen(hl); ConvertLen(hh); DrawRowPix(Round(xp1.x),Round(xp1.y),Round(xp2.x),Round(xp2.y),round(hh),round(hl),Solid); //*) end; procedure TPCDrawEngine.DrawRegulator(p1, p2: TDoublePoint; pColor, bColor,npColor: TColor; Dim, Mar: Double; var RegHandle: HRGN;covered:Boolean;st:Integer); var sz,rad,dx,dy: Double; cp: TDoublePoint; cp1,cp2,cp3,cp4,lp1,lp2,lp3: TDoublePOint; dp2:TDoublePOint; npMar,mLen,moMar,moR,rh,rW: Double; npR: Double; rgn: HRGN; r1,r2: TDoublePOint; lp: array[0..3] of TPoint; mp1,mp2,mp3,mp4:TDoublePoint; mil: Double; u: Double; Function MoveP(p:TDoublePOint;dist:Double):TDoublePOint; begin result := RotatePoint(p1,p,-rad); result := MovePoint(result,dist,0); result := RotatePoint(p1,result,rad); end; begin mp1 := MPoint(p2,p1,27.0); mp2 := Mpoint(p2,p1,0.5); rad := GetRadOfline(mp1,mp2); mp2 := RotatePOint(mp1,mp2,-rad); cp := mp1; mp1 := DoublePOint(mp1.x,mp1.y-12); mp2 := DoublePOint(mp2.x,mp2.y-12); mp3 := DoublePOint(mp2.x,mp2.y+22); mp4 := DoublePOint(mp1.x,mp1.y+22); mp1 := RotatePoint(cp,mp1,rad); mp2 := RotatePoint(cp,mp2,rad); mp3 := RotatePoint(cp,mp3,rad); mp4 := RotatePoint(cp,mp4,rad); ConvertDim(Dim); npMar := 3.8; moMar := 1.0; moR := 1.2; npR := 0.6; sz := dim/2; rh := 0.6; rw := 0.6; mLen := 4; mil := 1.8; u := 1; rgn:=1; ConvertDim(u); ConvertDim(Mar); ConvertDim(npMar); ConvertDim(moMar); ConvertDim(npR); ConvertDim(mLen); ConvertDim(moR); ConvertDim(rh); ConvertDim(rw); ConvertDim(mil); ConvertCoord(p1.x,p1.y,p1.z); ConvertCoord(p2.x,p2.y,p2.z); rad := GetRadOfLine(p1,p2); cp1 := RotatePoint(p1,p2,-rad); cp1 := DoublePoint(cp1.x-sz-Mar+mil,cp1.y); cp2 := RotatePoint(p1,p2,-rad); cp2 := DoublePoint(cp2.x-sz-Mar+sz+npMar,cp2.y); cp3 := RotatePoint(p1,p2,-rad); cp3 := DoublePoint(cp3.x-sz-Mar-sz-moMar,cp3.y); cp4 := DoublePOint(cp3.x,cp3.y-mLen); r1 := DoublePoint(cp4.x-(mor/2),cp4.y+(mor/2)); r2 := DoublePoint(cp4.x+(mor/2),cp4.y-(mor/2)); cp1 := RotatePoint(p1,cp1,rad); cp2 := RotatePoint(p1,cp2,rad); cp3 := RotatePoint(p1,cp3,rad); cp4 := RotatePoint(p1,cp4,rad); r1 := RotatePoint(p1,r1,rad); r2 := RotatePoint(p1,r2,rad); DrawCirclePix(Round(cp1.x),Round(cp1.y),Round(Dim),pColor,1,ord(psSolid),bColor,st,regHandle); dx := Dim/2; dy := sqrt(dim*dim-dx*dx)-2; lp[0] := Point(Round(cp1.x+dim-2),Round(cp1.y)); lp[1] := Point(Round(cp1.x-dx),Round(cp1.y+dy)); lp[2] := Point(Round(cp1.x-dx),Round(cp1.y-dy)); lp[3] := lp[0]; WPolyline(lp); DrawCirclePix(Round(cp2.x),Round(cp2.y),Round(npR),npColor,1,ord(psSolid),npColor,ord(bsSolid),rgn); cp2 := MoveP(cp2,-6*u); DrawCirclePix(Round(cp2.x),Round(cp2.y),Round(npR),npColor,1,ord(psSolid),npColor,ord(bsSolid),rgn); DrawLinePix(Round(cp3.x),Round(cp3.y),Round(cp4.x),Round(cp4.y),npColor,1,ord(psSolid),0); DrawCirclePix(Round(cp4.x),Round(cp4.y),Round(moR),npColor,1,ord(psSolid),bColor,st,rgn); DrawLinePix(Round(r1.x),Round(r1.y),Round(r2.x),Round(r2.y),npColor,1,ord(psSolid),0); Canvas.Pen.Color := npColor; Canvas.Pen.Style := psSolid; Canvas.Pen.Width := 1; SetCanvasValues(npColor,npColor,1,psSolid,bsSolid,pmCopy); if (rh > 1) and (rw > 1) then DrawRowPix(Round(r1.x),Round(r1.y),Round(r2.x),Round(r2.y),round(rh),round(rw),True); cp3 := Movep(cp3,7.5*u); cp4 := Movep(cp4,7.5*u); r1 := Movep(r1,7.5*u); r2 := Movep(r2,7.5*u); DrawLinePix(Round(cp3.x),Round(cp3.y),Round(cp4.x),Round(cp4.y),npColor,1,ord(psSolid),0); DrawCirclePix(Round(cp4.x),Round(cp4.y),Round(moR),npColor,1,ord(psSolid),bColor,st,rgn); DrawLinePix(Round(r1.x),Round(r1.y),Round(r2.x),Round(r2.y),npColor,1,ord(psSolid),0); Canvas.Pen.Color := npColor; Canvas.Pen.Style := psSolid; Canvas.Pen.Width := 1; SetCanvasValues(npColor,npColor,1,psSolid,bsSolid,pmCopy); if (rh > 1) and (rw > 1) then DrawRowPix(Round(r1.x),Round(r1.y),Round(r2.x),Round(r2.y),round(rh),round(rw),True); if Covered then begin DrawCover(mp1,mp2,mp3,mp4,pColor,true); end; end; procedure TPCDrawEngine.SetCanvasValues(PenColor, BrushColor: TColor; PenWidth: Integer; PenStyle: TPenStyle; BrushStyle: TBrushStyle; PenMode: TPenMode); begin Canvas.Brush.Color := BrushColor; Canvas.Brush.Style := BrushStyle; Canvas.Pen.Color := PenCOlor; Canvas.Pen.Width := PenWidth; Canvas.Pen.Style := PenStyle; Canvas.Pen.Mode := PenMode; end; procedure TPCDrawEngine.SetCanvasValues(PenColor, BrushColor: TColor; PenWidth, PenStyle, BrushStyle: Integer; PenMode: TPenMode); begin SetCanvasValues(PenColor,BrushColor,PenWidth,TPenStyle(PenStyle),TBrushSTyle(BrushStyle),PenMode); end; procedure TPCDrawEngine.WPolyline(const p: array of TPoint); var ip: Pointer; i,size: Integer; xp: TPoint; hPenOld: HPEN; hPen1: HPEN; begin size := Length(p); GetMem(ip,size*8); for i := 0 to size -1 do begin xp := p[i]; // Tolik 23/04/2019 -- //PInt(PChar(ip)+i*8+0)^:= xp.x; //PInt(PChar(ip)+i*8+4)^:= xp.y; PInt(PAnsiChar(ip)+i*8+0)^:= xp.x; PInt(PAnsiChar(ip)+i*8+4)^:= xp.y; // end; if (FCanvas.Pen.Mode <> pmXor) and (FCanvas.Pen.width > 1) then begin hPen1 := ExtCreatePenMy(FCanvas); hPenOld := SelectObject(FCanvas.Handle, hPen1);//связываем перо с контекстом Windows.Polyline(FCanvas.Handle, PPoints(ip)^,Size); SelectObject(FCanvas.Handle, hPenOld); //восстанавливаем предыдущее состояние if Not FCachePen then //01.11.2011 DeleteObject(hPen1);//удаляем перо end else begin Windows.Polyline(FCanvas.Handle, PPoints(ip)^,Size); end; FreeMem(ip,size*8); end; procedure TPCDrawEngine.DrawCenteredText(p1: TPoint; Color: TColor; Text, FontName: String; FontSize: Double;Angle:Double); var tWidth,tHeight:Integer; FSize: Double; FontRecord : TLogFont; ap1,ap2,ap3,ap4:TDoublePoint; begin if angle = 0 then begin FSize := FontSize; ConvertDim(FSize); if FSize < 4 then exit; FCanvas.brush.color := clNone; Canvas.brush.style := bsClear; Canvas.Font.Name := FontName; // Get Font Record GetObject(FCanvas.Font.Handle,sizeof(FontRecord),Addr(FontRecord)); // Set Font Height FontRecord.lfHeight := Round(FSize); // Create Modified Font FCanvas.Font.handle := CreateFontIndirect(FontRecord); Canvas.Font.Color := Color; tWidth := Canvas.TextWidth(text); tHeight := Canvas.TextHeight(text); Canvas.TextOut(Round(p1.x)-(tWidth div 2),Round(p1.y)-(tHeight div 2),Text); end else begin FSize := FontSize; ConvertDim(FSize); if FSize < 4 then exit; Canvas.Font.Name := FontName; // Get Font Record GetObject(FCanvas.Font.Handle,sizeof(FontRecord),Addr(FontRecord)); // Set Font Height FontRecord.lfHeight := Round(FSize); // Create Modified Font FCanvas.Font.handle := CreateFontIndirect(FontRecord); tWidth := Canvas.TextWidth(text); tHeight := Canvas.TextHeight(text); ap1 := DoublePoint(p1.x-(tWidth/2),p1.y-(tHeight/2)); ap2 := DoublePoint(ap1.x+tWidth,ap1.y); ap3 := DoublePoint(ap2.x,ap2.y+tHeight); ap4 := DoublePoint(ap1.x,ap1.y+tHeight); ap1 := RotatePoint(DP(p1),ap1,Angle); ap2 := RotatePoint(DP(p1),ap2,Angle); ap3 := RotatePoint(DP(p1),ap3,Angle); ap4 := RotatePoint(DP(p1),ap4,Angle); DrawText(Dp2P(ap1),Dp2P(ap2),Dp2P(ap3),Dp2P(ap4),Angle,Text,FontName,Color,FontSize); end; end; procedure TPCDrawEngine.DrawCenteredText(p1: TDoublePoint; Color: TColor; Text, FontName: String; FontSize: Double); var tWidth,tHeight:Integer; FSize: Double; FontRecord : TLogFont; begin FSize := FontSize; ConvertDim(FSize); if FSize < 4 then exit; FCanvas.brush.color := clNone; FCanvas.brush.style := bsClear; Canvas.Font.Name := FontName; ConvertCoord(p1.x,p1.y,p1.z); // Get Font Record GetObject(FCanvas.Font.Handle,sizeof(FontRecord),Addr(FontRecord)); // Set Font Height FontRecord.lfHeight := Round(FSize); // Create Modified Font FCanvas.Font.handle := CreateFontIndirect(FontRecord); Canvas.Font.Color := Color; tWidth := Canvas.TextWidth(text); tHeight := Canvas.TextHeight(text);; Canvas.TextOut(Round(p1.x)-(tWidth div 2),Round(p1.y)-(tHeight div 2),Text); end; procedure TPCDrawEngine.SetCanvasValues(PenColor, BrushColor: TColor; PenWidth: Integer; PenStyle: TPenStyle; BrushStyle: TBrushStyle); begin Canvas.Brush.Color := BrushColor; Canvas.Brush.Style := BrushStyle; Canvas.Pen.Color := PenCOlor; Canvas.Pen.Width := PenWidth; Canvas.Pen.Style := PenStyle; end; procedure TPCDrawEngine.DrawFlansh(p1, p2: TDoublePoint; pColor, bColor: TColor; Dim, Mar,Len: Double; var RegHandle: HRGN;st:Integer); var rad,sz,h: Double; ap1,ap2,ap3,ap4: TDoublePoint; p: array of TPoint; tp1,tp2,tp3,tl1,tl2,tl3,tl4,tl5,tl6: TDoublePoint; begin sz := len; h := dim/2; ConvertDim(h); ConvertDim(sz); ConvertDim(Mar); ConvertCoord(p1.x,p1.y,p1.z); ConvertCoord(p2.x,p2.y,p2.z); rad := GetRadOfLine(p1,p2); p2 := RotatePoint(p1,p2,-rad); p2 := DoublePoint(p2.x-sz-1-Mar,p2.y); ap1 := DoublePoint(p2.x-sz,p2.y-h); ap2 := DoublePoint(p2.x+sz,p2.y-h); ap3 := DoublePoint(p2.x+sz,p2.y+h); ap4 := DoublePoint(p2.x-sz,p2.y+h); ap1 := RotatePoint(p1,ap1,rad); ap2 := RotatePoint(p1,ap2,rad); ap3 := RotatePoint(p1,ap3,rad); ap4 := RotatePoint(p1,ap4,rad); SetLength(p,4); p[0] := Point(Round(ap1.x),Round(ap1.y)); p[1] := Point(Round(ap2.x),Round(ap2.y)); p[2] := Point(Round(ap3.x),Round(ap3.y)); p[3] := Point(Round(ap4.x),Round(ap4.y)); Canvas.Pen.Style := psClear; Canvas.Pen.Width := 1; Canvas.Pen.Mode := pmCopy; Canvas.Pen.Color := pColor; Canvas.Brush.Style := TBrushStyle(st); Canvas.Brush.Color := bColor; WPolygon(p,regHandle); Canvas.Pen.Style := psSolid; Canvas.Pen.Width := 2; DrawLinePix(p[0],p[3],0); DrawLinePix(p[1],p[2],0); end; procedure TPCDrawEngine.drawlinePix(p1, p2: TPoint; row: Integer); var rw,rh: Double; x1,y1,x2,y2: Integer; begin x1 := p1.x; x2 := p2.x; y1 := p1.y; y2 := p2.y; rw := 3.5; rh := 1.2; ConvertDim(rw); ConvertDim(rh); if row = 1 then drawrowpix(x1,y1,x2,y2,Round(rh),Round(rw),true) else if row = 2 then drawrowPix(x2,y2,x1,y1,Round(rh),Round(rw),true) else if row = 3 then begin drawrowPix(x2,y2,x1,y1,Round(rh),Round(rw),true); drawrowPix(x1,y1,x2,y2,Round(rh),Round(rw),true) end else if row = 4 then drawrowPix(x1,y1,x2,y2,Round(rh),Round(rw),false) else if row = 5 then drawrowPix(x2,y2,x1,y1,Round(rh),Round(rw),false) else if row = 6 then begin drawrowPix(x2,y2,x1,y1,Round(rh),Round(rw),false); drawrowPix(x1,y1,x2,y2,Round(rh),Round(rw),false) end; FCanvas.brush.color := clNone; FCanvas.brush.style := bsClear; FCanvas.moveto(x1,y1); FCanvas.lineto(x2,y2); end; procedure TPCDrawEngine.DrawKatod(p1, p2: TDoublePoint; Color: TColor; var RegHandle: HRGN); var mp: TDoublePOint; d,rad: Double; h1,h2,h3,h4: TDoublePoint; t1,t2,t3,t4,t5,t6:TDoublePoint; p: array of TPoint; tp: TDoublePOint; i:Integer; begin FCanvas.pen.color := color; FCanvas.pen.width := 1; FCanvas.Pen.Style := psSolid; FCanvas.Brush.Style := bsClear; FCanvas.Brush.Color := color; tp := MPoint(p1,p2); ConvertCoord(p1.x,p1.y,p1.z); ConvertCoord(p2.x,p2.y,p2.z); d := 1; ConvertDim(d); SetLength(p,4); rad := GetRadOfLine(p1,p2); p2 := RotatePoint(p1,p2,-rad); mp := MPoint(p1,p2); h1 := mp; h2 := MovePoint(h1,-2*d,1.5*d); h3 := MovePoint(h2,+d,1.6*d); h4 := MovePoint(h3,-d,1.8*d); t1 := h4; t2 := MovePoint(t1,-1.5*d,d); t3 := MovePoint(t2,0,2*d); t4 := MovePoint(t3,2*d,2.2*d); t5 := MovePoint(t4,2.2*d,-2.5*d); t6 := MovePoint(t5,-d,-1.5*d); h1 := RotatePoint(p1,h1,rad); h2 := RotatePoint(p1,h2,rad); h3 := RotatePoint(p1,h3,rad); h4 := RotatePoint(p1,h4,rad); p[0] := Dp2P(h1); p[1] := Dp2P(h2); p[2] := Dp2P(h3); p[3] := Dp2P(h4); WPolyline(p); t1 := RotatePoint(p1,t1,rad); t2 := RotatePoint(p1,t2,rad); t3 := RotatePoint(p1,t3,rad); t4 := RotatePoint(p1,t4,rad); t5 := RotatePoint(p1,t5,rad); t6 := RotatePoint(p1,t6,rad); SetLength(p,6); p[0] := Dp2P(t1); p[1] := Dp2P(t2); p[2] := Dp2P(t3); p[3] := Dp2P(t4); p[4] := Dp2P(t5); p[5] := Dp2P(t6); FCanvas.Brush.Style := bsSolid; FCanvas.Brush.Color := clWhite; WPolygon(p,regHandle); end; procedure TPCDrawEngine.DrawToprak(p1, p2: TDoublePoint; pColor, bColor: TColor; Dim, Mar: Double; var RegHandle: HRGN;st:Integer;pos:Integer); var rad,sz,h: Double; ap1,ap2,ap3,ap4: TDoublePoint; p: array of TPoint; tp1,tp2,tp3,tl1,tl2,tl3,tl4,tl5,tl6: TDoublePoint; begin sz := 1; ConvertDim(Dim); ConvertDim(sz); h := dim/2; ConvertDim(Mar); ConvertCoord(p1.x,p1.y,p1.z); ConvertCoord(p2.x,p2.y,p2.z); rad := GetRadOfLine(p1,p2); p2 := RotatePoint(p1,p2,-rad); p2 := DoublePoint(p2.x-Mar,p2.y); tp1 := DoublePoint(p2.x-3*sz+3*sz,p2.y); tp2 := DoublePoint(p2.x-3*sz+3*sz,p2.y+2*h); tp3 := DoublePoint(p2.x-6*sz+3*sz,p2.y+2*h); tl1 := DoublePoint(p2.x-6*sz+3*sz,p2.y+2*h-3*sz); tl2 := DoublePoint(p2.x-6*sz+3*sz,p2.y+2*h+3*sz); tl3 := DoublePoint(p2.x-7*sz+3*sz,p2.y+2*h-2*sz); tl4 := DoublePoint(p2.x-7*sz+3*sz,p2.y+2*h+2*sz); tl5 := DoublePoint(p2.x-8*sz+3*sz,p2.y+2*h-1*sz); tl6 := DoublePoint(p2.x-8*sz+3*sz,p2.y+2*h+1*sz); tp1 := RotatePoint(p1,tp1,rad); tp2 := RotatePoint(p1,tp2,rad); tp3 := RotatePoint(p1,tp3,rad); tl1 := RotatePoint(p1,tl1,rad); tl2 := RotatePoint(p1,tl2,rad); tl3 := RotatePoint(p1,tl3,rad); tl4 := RotatePoint(p1,tl4,rad); tl5 := RotatePoint(p1,tl5,rad); tl6 := RotatePoint(p1,tl6,rad); rad := (pos-1)*(pi/2); if rad <> 0 then begin tp2 := RotatePoint(tp1,tp2,rad); tp3 := RotatePoint(tp1,tp3,rad); tl1 := RotatePoint(tp1,tl1,rad); tl2 := RotatePoint(tp1,tl2,rad); tl3 := RotatePoint(tp1,tl3,rad); tl4 := RotatePoint(tp1,tl4,rad); tl5 := RotatePoint(tp1,tl5,rad); tl6 := RotatePoint(tp1,tl6,rad); end; Canvas.Pen.Style := psClear; Canvas.Pen.Width := 1; Canvas.Pen.Color := pColor; Canvas.Pen.Style := psSolid; Canvas.Pen.Width := 1; DrawLinePix(DP2P(tp1),DP2P(tp2),0); DrawLinePix(DP2P(tp2),DP2P(tp3),0); DrawLinePix(DP2P(tl1),DP2P(tl2),0); DrawLinePix(DP2P(tl3),DP2P(tl4),0); DrawLinePix(DP2P(tl5),DP2P(tl6),0); if RegHandle = 0 then begin RegHandle := PolygonRegion(DP2P(tl1),DP2P(tl2),DP2P(tl6),DP2P(tl5)); end; end; function TPCDrawEngine.PolygonRegion(p1, p2, p3, p4: TPoint): HRGN; var p:TPointArr; begin SetLength(p,4); p[0] := p1; p[1] := p2; p[2] := p3; p[3] := p4; result := PolygonRegion(p); end; procedure TPCDrawEngine.Drawtext(ap1, ap2, ap3, a4: TDoublePoint; angle: Double; atext, fontName: String;aColor:TColor; aheight, CWidth, CSpace: double; var nH, nl: Integer); var TM : TTextMetric; FontRecord : TLogFont; Leading : LongInt; ap : TPoint; txSize: TSize; wChar: Integer; x1,y1,z: Double; olDFont: TFont; aFont:Tfont; begin nh := 0; nl := 0; ConvertDim(aHeight); if aheight < 4 then exit; OldFont := Fcanvas.Font; aFont := Tfont.Create; aFont.Name := FontName; aFont.Color := aColor; FCanvas.Font := aFont; Fcanvas.Font.Height := Round(aHeight); FCanvas.brush.color := clNone; FCanvas.brush.style := bsClear; x1 := ap1.x; y1 := ap1.y; z := 0; ConvertCoord(x1,y1,z); // Get Font Record GetObject(FCanvas.Font.Handle,sizeof(FontRecord),Addr(FontRecord)); // Set Font Height FontRecord.lfHeight := Round(aHeight); // Create Modified Font FCanvas.Font.handle := CreateFontIndirect(FontRecord); if Angle <> 0 then begin // Get Font Record GetObject(FCanvas.Font.Handle,sizeof(FontRecord),Addr(FontRecord)); // Set Angle angle := -1*(angle/pi)*1800; FontRecord.lfEscapement := Round(angle); // Create Modified Font FCanvas.Font.handle := CreateFontIndirect(FontRecord); end; // Calculate Zero Point GetTextMetrics(FCanvas.Handle,TM); if CWidth <> 0 then begin GetObject(FCanvas.Font.Handle,sizeof(FontRecord),Addr(FontRecord)); ConvertDim(CWidth); wChar := round(CWidth); FontRecord.lfWidth := wchar; FCanvas.Font.handle := CreateFontIndirect(FontRecord); end; Leading := TM.tmInternalLeading; if angle <> 0 then begin ap := getRelativePointbyAngle(Round(angle),DP2P(x1,y1),Dp2P(x1,y1-Leading div 3)); y1 := ap.y; x1 := ap.x; end; if CSpace <> 0 then begin ConvertDim(CSpace); SetTextCharacterExtra(FCanvas.Handle,round(CSpace)); end; FCanvas.textout(round(x1),Round(y1),atext); GetTextExtentPoint(FCanvas.Handle,pchar(aText),length(aText),txSize); nh := txSize.cy; nL := txSize.cx; nL := nl-round(cSpace); if CSpace <> 0 then begin SetTextCharacterExtra(FCanvas.Handle,0); end; Fcanvas.Font := oldFont; aFont.Free; end; procedure TPCDrawEngine.DrawIsoGnCihaz(p1, p2: TDoublePoint; pColor, bColor: TColor; size: Double; var RegHandle: HRGN;st:Integer); var cp1: TDoublePoint; p: array [0..3] of TPoint; i: Integer; begin ConvertDim(size); ConvertCoord(p1.x,p1.y,p1.z); ConvertCoord(p2.x,p2.y,p2.z); cp1 := MPoint(p2,p1,-(size/2)); p[0] := Point(Round(cp1.x-(Size/2)),Round(cp1.y-(Size/2))); p[1] := Point(Round(cp1.x+(Size/2)),Round(cp1.y-(Size/2))); p[2] := Point(Round(cp1.x+(Size/2)),Round(cp1.y+(Size/2))); p[3] := Point(Round(cp1.x-(Size/2)),Round(cp1.y+(Size/2))); Canvas.Pen.Style := psSolid; Canvas.Pen.Width := 1; Canvas.Pen.Mode := pmCopy; Canvas.Pen.Color := pColor; Canvas.Brush.Style := TBrushStyle(st); Canvas.Brush.Color := bColor; WPolygon(p,RegHandle); end; procedure TPCDrawEngine.drawrow(x1, y1, x2, y2: Double; solid: Boolean; var reg: HRGN; hl, hh: double); var pt : TDoublePointArr; r:HRGN; begin r := 1; SetLength(pt,3); CalcRowPoints(x1,y1,x2,y2,hl,hh,pt[0],pt[1],pt[2]); if solid then Polygon(pt,reg) else PolyLine(pt); end; procedure TPCDrawEngine.CalcRowPoints(x1, y1, x2, y2: Double; hl, hh: double; var r1, r2, r3: TDoublePoint); VAR xLineDelta : double; yLineDelta : double; p1,p2,p3 : TDoublePoint; a : integer; Angle: Double; r: HRGN; HeadLength,HeadHeight: Double; begin try HeadLength := hl; HeadHeight := hh; xLineDelta := x2 - x1; yLineDelta := y2 - y1; if (xLineDelta = 0) and (yLineDelta = 0) then exit; p1.x := x2; p1.y := y2; if (xLineDelta < 0) and (yLineDelta = 0) then begin p2.x := p1.x + HeadLength; p3.x := p2.x; p2.y := p1.y - HeadHeight; p3.y := p1.y + HeadHeight; end else if (xLineDelta > 0) and (yLineDelta = 0) then begin p2.x := p1.x - HeadLength; p3.x := p2.x; p2.y := p1.y - HeadHeight; p3.y := p1.y + HeadHeight; end else if (xLineDelta = 0) and (yLineDelta > 0) then begin p2.x := p1.x - HeadHeight; p3.x := p1.x + HeadHeight; p2.y := p1.y - HeadLength; p3.y := p1.y - HeadLength; end else if (xLineDelta = 0) and (yLineDelta < 0) then begin p2.x := p1.x - HeadHeight; p3.x := p1.x + HeadHeight; p2.y := p1.y + HeadLength; p3.y := p1.y + HeadLength; end else if (xLineDelta > 0) and (yLineDelta > 0) then begin p2.x := p1.x - HeadLength; p3.x := p2.x; p2.y := p1.y - HeadHeight; p3.y := p1.y + HeadHeight; //rotate Angle := ArcTan(abs(yLineDelta) / abs(xLineDelta)); p2 := RotatePoint(p1,p2,Angle); p3 := RotatePoint(p1,p3,Angle); end else if (xLineDelta < 0) and (yLineDelta > 0) then begin p2.x := p1.x - HeadHeight; p3.x := p1.x + HeadHeight; p2.y := p1.y - HeadLength; p3.y := p1.y - HeadLength; // rotate Angle := (pi/2) - ArcTan(abs(yLineDelta) / abs(xLineDelta)); p2 := RotatePoint(p1,p2,Angle); p3 := RotatePoint(p1,p3,Angle); end else if (xLineDelta < 0) and (yLineDelta < 0) then begin p2.x := p1.x + HeadLength; p3.x := p2.x; p2.y := p1.y - HeadHeight; p3.y := p1.y + HeadHeight; // rotate Angle := ArcTan(abs(yLineDelta) / abs(xLineDelta)); p2 := RotatePoint(p1,p2,Angle); p3 := RotatePoint(p1,p3,Angle); end else if (xLineDelta > 0) and (yLineDelta < 0) then begin p2.x := p1.x - HeadHeight; p3.x := p1.x + HeadHeight; p2.y := p1.y + HeadLength; p3.y := p1.y + HeadLength; // rotate Angle := (pi/2) - ArcTan(abs(yLineDelta) / abs(xLineDelta)); p2 := RotatePoint(p1,p2,Angle); p3 := RotatePoint(p1,p3,Angle); end; r1 := p2; r2 := p1; r3 := p3; except end; end; procedure TPCDrawEngine.Drawtext(ap1, ap2, ap3, a4: TPoint; angle: Double; atext, fontName: String; aColor: TColor; aheight: double); var TM : TTextMetric; FontRecord : TLogFont; Leading : LongInt; ap : TPoint; txSize: TSize; wChar: Integer; x1,y1: Integer; olDFont: TFont; aFont:Tfont; begin ConvertDim(aHeight); if aheight < 4 then exit; OldFont := Fcanvas.Font; aFont := Tfont.Create; aFont.Name := FontName; aFont.Color := aColor; FCanvas.Font := aFont; Fcanvas.Font.Height := Round(aHeight); FCanvas.brush.color := clNone; FCanvas.brush.style := bsClear; x1 := ap1.x; y1 := ap1.y; // Get Font Record GetObject(FCanvas.Font.Handle,sizeof(FontRecord),Addr(FontRecord)); // Set Font Height FontRecord.lfHeight := Round(aHeight); // Create Modified Font FCanvas.Font.handle := CreateFontIndirect(FontRecord); if Angle <> 0 then begin // Get Font Record GetObject(FCanvas.Font.Handle,sizeof(FontRecord),Addr(FontRecord)); // Set Angle angle := -1*(angle/pi)*1800; FontRecord.lfEscapement := Round(angle); // Create Modified Font FCanvas.Font.handle := CreateFontIndirect(FontRecord); end; // Calculate Zero Point GetTextMetrics(FCanvas.Handle,TM); Leading := TM.tmInternalLeading; if angle <> 0 then begin ap := getRelativePointbyAngle(Round(angle),Point(x1,y1),Point(x1,y1-Leading div 3)); y1 := ap.y; x1 := ap.x; end; FCanvas.textout(round(x1),Round(y1),atext); Fcanvas.Font := oldFont; aFont.Free; end; procedure TPCDrawEngine.DrawCover(p1, p2, p3, p4: TDoublePoint; aColor: TColor;dConvert:Boolean); var rgn:HRGN; p:Array of TPoint; rad:Double; cp:Tpoint; xp1,xp2:TDoublePoint; dx: Double; begin rgn:= 1; xp1 := MPoint(p1,p4); xp2 := MPoint(p2,p3); dx := 3; if not dConvert then ConvertDim(dx); xp1 := MPoint(xp1,xp2,dx); dx := 1.5; if not dConvert then ConvertDim(dx); xp2 := MPoint(xp1,xp2,-dx); Setlength(p,5); if dConvert then begin ConvertCoord(p1.x,p1.y,p1.z); ConvertCoord(p2.x,p2.y,p2.z); ConvertCoord(p3.x,p3.y,p3.z); ConvertCoord(p4.x,p4.y,p4.z); ConvertCoord(xp1.x,xp1.y,xp1.z); ConvertCoord(xp2.x,xp2.y,xp2.z); end; p[0] := DP2P(p1); p[1] := DP2P(p2); p[2] := DP2P(p3); p[3] := DP2P(p4); p[4] := DP2P(p1); Canvas.Brush.Style := bsClear; Canvas.Pen.Style := psDot; Canvas.Pen.Width := 1; Canvas.Pen.Color := aColor; WPolygon(p,rgn); //cp := DP2P(MPoint(p1,p4)); rad := GetRadOfLine(p1,p4); if EQD(rad ,pi) or EQD(rad,-pi) then rad := 0; if EQD(rad, 3*pi/2) then rad := pi/2; //DrawCenteredText(cp,aColor,'Muhafaza','Arial',2,rad); {$ifdef p55} DrawCenteredText(DP2P(xp1),aColor,'Havalandэrэlmэю','Arial',2,rad); {$endif p55} DrawCenteredText(DP2P(xp2),aColor,'Muhafaza','Arial',2,rad); end; procedure TPCDrawEngine.GetTextLens(var TextLen, TextH: Double; atext: string; afont: Tfont; aheight, CWidth, CSpace: double); var TM : TTextMetric; FontRecord : TLogFont; Leading : LongInt; ap : TPoint; txSize: TSize; wChar: Integer; x1,y1,z: Double; olDFont: TFont; begin ConvertDim(aHeight); // if aheight < 4 then exit; OldFont := Fcanvas.Font; FCanvas.Font := aFont; Fcanvas.Font.Height := Round(aHeight); // Get Font Record GetObject(FCanvas.Font.Handle,sizeof(FontRecord),Addr(FontRecord)); // Set Font Height FontRecord.lfHeight := Round(aHeight); // Create Modified Font FCanvas.Font.handle := CreateFontIndirect(FontRecord); GetTextMetrics(FCanvas.Handle,TM); if CWidth <> 0 then begin GetObject(FCanvas.Font.Handle,sizeof(FontRecord),Addr(FontRecord)); ConvertDim(CWidth); wChar := round(CWidth); FontRecord.lfWidth := wchar; FCanvas.Font.handle := CreateFontIndirect(FontRecord); end; Leading := TM.tmInternalLeading; if CSpace <> 0 then begin ConvertDim(CSpace); SetTextCharacterExtra(FCanvas.Handle,round(CSpace)); end; GetTextExtentPoint(FCanvas.Handle,pchar(aText),length(aText),txSize); TextH := txSize.cy; TextLen := txSize.cx; TextLen := TextLen-round(cSpace); DeConvertDim(TextLen); DeConvertDim(TextH); if CSpace <> 0 then begin SetTextCharacterExtra(FCanvas.Handle,0); end; Fcanvas.Font := oldFont; end; procedure TPCDrawEngine.DrawPatternLine(p1, p2: TDoublePoint; color, awidth, style: integer; Pattern: TObject); var points: TDoublePointArr; begin SetLength(Points,4); points[0] := p1; points[1] := p1; points[2] := p2; points[3] := p2; DrawPatBezier(points,4,color,awidth,style,0,0,false,pattern); end; procedure TPCDrawEngine.DrawMtextToCanvas(ap1: TPoint; atext: TstringList; afontName: String; Styles: TFontStyles; aColor: TColor; aSize,aHeight,marX,marY,limitH: Integer; var Region: HRGN; var tw,th: Integer; FCanvas: TCanvas); var aFont,oldFont:TFont; TM : TTextMetric; FontRecord : TLogFont; i,k,p1,p2,p3,p4: Integer; xp1,tp: TPoint; tx,ty,sx,sy,lx: Integer; xText: String; bsh: Integer; KeepLine: Boolean; sqroot,bs,ts,tab: Boolean; mText,Lines: TstringList; txt,c,tag,etag,tx1,tx2,tx3: String; done: boolean; lh:Integer; tab2: Boolean; begin tw := 0; th := 0; if (aHeight < 4) and (aSize < 4) then exit; oldFont := Fcanvas.font; aFont := Tfont.Create; aFont.Name := afontName; aFont.Style := Styles; aFont.Color := aColor; if aSize > 0 then aFont.Size := aSize else aFont.Height := aHeight; FCanvas.Font := aFont; SetBkMode(Fcanvas.Handle,TRANSPARENT); xp1 := ap1; tab2 := false; lh := FCanvas.TextHeight('ABC'); // Create Modified Font //FCanvas.Font.handle := CreateFontIndirect(FontRecord); ap1.x := ap1.x+marx; ap1.y := ap1.y+mary; tp := ap1; sx := 0; sy := 0; KeepLine := False; mtext := TstringList.Create; lines := TstringList.Create; for i := 0 to aText.Count-1 do begin xText := atext[i]; p1 := Pos('|TAB|',xText); if p1 = 0 then p1 := Pos('|TAB2|',xText); if p1 > 0 then begin tx1 := Copy(xText,1,p1-1); if Trim(tx1) <> '' then lines.Add(tx1+'|KL|'); tx2 := copy(xText,p1,Length(xText)-p1+1); lines.Add(tx2); end else begin lines.Add(xtext); end; end; for i := 0 to lines.Count-1 do begin xText := lines[i]; done := false; repeat p1 := Pos('<',xText); if p1 > 0 then begin p2 := Pos('>',xText); if p2 > 0 then begin tag := '<'+Copy(xText,p1+1,p2-p1-1)+'>'; eTag := ''; p3 := Pos(etag,xText); if p3 > 0 then begin if p1 > 1 then begin tx1 := Copy(xText,1,p1-1)+'|KL|'; mText.Add(tx1); end; tx2 := Copy(xText,p2+1,p3-p2-1)+tag; p4 := p3+Length(etag)-1; if p4 < Length(xText) then begin tx3 := Copy(xText,p4+1,Length(xText)-p4); xText := tx3; tx2 := tx2+'|KL|'; end else begin done := true; end; mText.Add(tx2); end else begin mText.Add(xText); done := true; end; end; end else begin mText.Add(xText); done := true; end; until done; end; for i := 0 to mText.Count-1 do begin xText := mText[i]; FCanvas.Font.Style := Styles; if (Pos('',xText) > 0) then FCanvas.Font.Style := Styles+[fsBold]; if (Pos('',xText) > 0) then FCanvas.Font.Style := Styles+[fsItalic]; if (Pos('',xText) > 0) then FCanvas.Font.Style := Styles+[fsUnderline]; if (Pos('|KL|',xText) > 0) or (Pos('',xText) > 0) then KeepLine := True else KeepLine := False; if (Pos('',xText) > 0) then sqroot := True else sqroot :=False; if (Pos('|TAB|',xText) > 0) then tab := True else tab :=False; if (Pos('|TAB2|',xText) > 0) then tab2 := True else tab2 :=False; if (Pos('',xText) > 0) then FCanvas.Font.Name := 'Symbol' else FCanvas.Font.Name := afontName; if (Pos('',xText) > 0) then bs := True else bs := false; if (Pos('',xText) > 0) then ts := True else ts := false; if bs or ts then begin if aSize > 0 then fcanvas.Font.Size := Round(aSize*0.6) else fcanvas.Font.Height := Round(aHeight*0.6); end else begin if aSize > 0 then fcanvas.Font.Size := aSize else fcanvas.Font.Height := aHeight; end; xText := StringReplace(xText,'','',[rfReplaceAll]); xText := StringReplace(xText,'','',[rfReplaceAll]); xText := StringReplace(xText,'','',[rfReplaceAll]); xText := StringReplace(xText,'','',[rfReplaceAll]); xText := StringReplace(xText,'|KL|','',[rfReplaceAll]); xText := StringReplace(xText,'','',[rfReplaceAll]); xText := StringReplace(xText,'','',[rfReplaceAll]); xText := StringReplace(xText,'','',[rfReplaceAll]); xText := StringReplace(xText,'','',[rfReplaceAll]); xText := StringReplace(xText,'','',[rfReplaceAll]); xText := StringReplace(xText,'|TAB|','',[rfReplaceAll]); xText := StringReplace(xText,'|TAB2|','',[rfReplaceAll]); xText := StringReplace(xText,'|grt|','>',[rfReplaceAll]); xText := StringReplace(xText,'|sml|','<',[rfReplaceAll]); tx := FCanvas.TextWidth(xText); if not (bs or ts) then begin ty := FCanvas.TextHeight(xText); if xText = '' then ty := aHeight; end; if tab then tp.X := xp1.X + 40; if tab2 then tp.X := xp1.X + 120; if sqroot then begin FCanvas.Pen.Color := FCanvas.Font.Color; FCanvas.Pen.Style := psSolid; FCanvas.Pen.Width := 1; FCanvas.MoveTo(Round(tp.x),Round(tp.y-2+ty/2)); FCanvas.LineTo(Round(tp.x-2+ty/2),Round(tp.y-2+ty)); FCanvas.LineTo(Round(tp.x-2+ty),Round(tp.y)); FCanvas.LineTo(Round(tp.x+ty+tx+1),Round(tp.y)); FCanvas.LineTo(Round(tp.x+ty+tx+1),Round(tp.y+ty/3)); FCanvas.TextOut(Round(tp.x+ty),Round(tp.y),xText); tx := tx+ty+2; end else begin bsh := 0; if bs then bsh := Round(lh*0.4); FCanvas.TextOut(Round(tp.x),Round(tp.y+bsh),xText); end; if not keepLine then begin tp.y := tp.y+ty+2; tp.x := ap1.x; lx := lx+tx; if lx > sx then sx := lx; sy := sy+ty+2; lx := 0; end else begin tp.x := tp.x+tx+2; lx := lx+tx+2; if lx > sx then sx := lx; end; end; sx := sx+marx; sy := sy+mary; tw := sx; th := sy; if Region = 0 then Region := CreateRectRgn(Round(xp1.x),round(xp1.y),round(xp1.x+sx),round(xp1.y+sy)); Fcanvas.Font := oldFont; afont.Free; mtext.Clear; mText.Free; Lines.Clear; Lines.Free; end; Function TPCDrawEngine.SetCanvasFont(FName: String; FHeight, CWidth, CSpace,Angle: Double; Styles: TFontStyles; Charset: Byte;FColor:TColor):TFont; var aFont,oldFont:TFont; TM : TTextMetric; FontRecord : TLogFont; begin ConvertDim(FHeight); oldFont := Fcanvas.font; aFont := Tfont.Create; aFont.Name := fName; aFont.Style := Styles; aFont.Color := FColor; aFont.Charset := Charset; FCanvas.Font := aFont; // Set Font Height SetBkMode(Fcanvas.Handle,TRANSPARENT); // Get Font Record GetObject(FCanvas.Font.Handle,sizeof(FontRecord),Addr(FontRecord)); // Set Font Height FontRecord.lfHeight := Round(FHeight); // Create Modified Font FCanvas.Font.handle := CreateFontIndirect(FontRecord); if angle <> 0 then begin // Get Font Record GetObject(FCanvas.Font.Handle,sizeof(FontRecord),Addr(FontRecord)); FontRecord.lfEscapement := Round(1800*(angle/pi)); // Create Modified Font FCanvas.Font.handle := CreateFontIndirect(FontRecord); end; GetTextMetrics(FCanvas.Handle,TM); if CWidth <> 0 then begin GetObject(FCanvas.Font.Handle,sizeof(FontRecord),Addr(FontRecord)); ConvertDim(CWidth); FontRecord.lfWidth := round(CWidth); FCanvas.Font.handle := CreateFontIndirect(FontRecord); end; if CSpace <> 0 then begin ConvertDim(CSpace); SetTextCharacterExtra(FCanvas.Handle,round(CSpace)); end; result := oldFont; end; procedure TPCDrawEngine.ResetCanvasFont(oldFont: TFont); var aFont:TFont; begin aFont := FCanvas.Font; Fcanvas.Font := oldFont; // aFont.Free; end; procedure TPCDrawEngine.GDIDrawText(r1, r2,r3,r4: TDoublePoint; Text: String; vAlign:TTextVAlign;hAlign:TTextHAlign); var xRect,xoRect: Trect; z:Double; format: Integer; Ang: Double; begin Ang := GetRadOfLine(r1,r2); ConvertCoord(r1.x,r1.y,z); ConvertCoord(r2.x,r2.y,z); ConvertCoord(r3.x,r3.y,z); ConvertCoord(r4.x,r4.y,z); ang := getRadOfLine(r1,r2); if ang <> 0 then begin RotateCanvas(FCanvas.handle,ang); r1 := RotatePoint(DoublePoint(0,0),r1,-ang); r2 := RotatePoint(DoublePoint(0,0),r2,-ang); r3 := RotatePoint(DoublePoint(0,0),r3,-ang); r4 := RotatePoint(DoublePoint(0,0),r4,-ang); end; xRect := Rect(round(r1.x),round(r1.y),round(r3.x),round(r3.y)); format := 0; Format := 0; case VAlign of //vtCenter : format := format or DT_VCENTER; vtTop : format := format or DT_TOP; //vtBottom: format := format or DT_BOTTOM; end; format := format or DT_TOP; case HAlign of htCenter : format := format or DT_CENTER; htLeft : format := format or DT_LEFT; htRight: format := format or DT_RIGHT; end; format := format or DT_WORDBREAK; if vAlign = vtCenter then begin xoRect := xRect; // make a 2. copy // Compute rect of text in rect Windows.DrawTextEx(FCanvas.Handle, Pchar(Text), -1,xoRect, format or DT_CALCRECT, nil); // Compute the vcenter-line - half vsize xRect.top := xRect.top + Round((xRect.bottom - xoRect.bottom )/2); end else if vAlign = vtBottom then begin xoRect := xRect; // make a 2. copy // Compute rect of text in rect Windows.DrawTextEx(FCanvas.Handle, Pchar(Text), -1,xoRect, format or DT_CALCRECT, nil); // Compute the vcenter-line - half vsize xRect.top := xRect.Bottom - (xoRect.bottom - xoRect.top); end; Windows.DrawText(FCanvas.Handle, Pchar(Text), -1, xRect,format); if ang <> 0 then begin ResetCanvas(FCanvas.handle) end; end; procedure TPCDrawEngine.DrawFiltre(p1, p2: TDoublePoint; pColor, bColor: TColor; Dim, Mar, Len: Double; var RegHandle: HRGN; st: Integer); var rad,sz,h: Double; ap1,ap2,ap3,ap4: TDoublePoint; p: array of TPoint; tp1,tp2,tp3,tp4,tl1,tl2,tl3,tl4,tl5,tl6: TDoublePoint; dx,dy: Integer; begin sz := len; h := dim/2; ConvertDim(h); ConvertDim(sz); ConvertDim(Mar); ConvertCoord(p1.x,p1.y,p1.z); ConvertCoord(p2.x,p2.y,p2.z); rad := GetRadOfLine(p1,p2); p2 := RotatePoint(p1,p2,-rad); p2 := DoublePoint(p2.x-sz-1-Mar,p2.y); ap1 := DoublePoint(p2.x-sz,p2.y-h); ap2 := DoublePoint(p2.x+sz,p2.y-h); ap3 := DoublePoint(p2.x+sz,p2.y+h); ap4 := DoublePoint(p2.x-sz,p2.y+h); tp1 := ap1; tp2 := ap2; tp3 := ap3; tp4 := ap4; ap1 := RotatePoint(p1,ap1,rad); ap2 := RotatePoint(p1,ap2,rad); ap3 := RotatePoint(p1,ap3,rad); ap4 := RotatePoint(p1,ap4,rad); SetLength(p,4); p[0] := Point(Round(ap1.x),Round(ap1.y)); p[1] := Point(Round(ap2.x),Round(ap2.y)); p[2] := Point(Round(ap3.x),Round(ap3.y)); p[3] := Point(Round(ap4.x),Round(ap4.y)); Canvas.Pen.Mode := pmCopy; Canvas.Pen.Color := pColor; Canvas.Brush.Style := TBrushStyle(st); Canvas.Brush.Color := bColor; Canvas.Pen.Style := psSolid; Canvas.Pen.Width := 2; WPolygon(p,regHandle); Canvas.Pen.Style := psSolid; Canvas.Pen.Width := 1; tl1 := MPoint(ap1,ap2); tl2 := Mpoint(ap3,ap4); p[0] := Point(Round(tl1.x),Round(tl1.y)); p[1] := Point(Round(tl2.x),Round(tl2.y)); DrawLinePix(p[0],p[1],0); tl1 := MPoint(ap1,ap4); tl2 := Mpoint(ap2,ap3); p[0] := Point(Round(tl1.x),Round(tl1.y)); p[1] := Point(Round(tl2.x),Round(tl2.y)); DrawLinePix(p[0],p[1],0); tl1 := MPoint(ap1,ap4); tl1 := MPoint(ap1,tl1); tl2 := Mpoint(ap2,ap3); tl2 := Mpoint(tl2,ap2); p[0] := Point(Round(tl1.x),Round(tl1.y)); p[1] := Point(Round(tl2.x),Round(tl2.y)); DrawLinePix(p[0],p[1],0); tl1 := MPoint(ap1,ap4); tl1 := MPoint(ap4,tl1); tl2 := Mpoint(ap2,ap3); tl2 := Mpoint(tl2,ap3); p[0] := Point(Round(tl1.x),Round(tl1.y)); p[1] := Point(Round(tl2.x),Round(tl2.y)); DrawLinePix(p[0],p[1],0); tl1 := MPoint(ap1,ap2); tl1 := MPoint(ap1,tl1); tl2 := Mpoint(ap3,ap4); tl2 := Mpoint(ap4,tl2); p[0] := Point(Round(tl1.x),Round(tl1.y)); p[1] := Point(Round(tl2.x),Round(tl2.y)); DrawLinePix(p[0],p[1],0); tl1 := MPoint(ap1,ap2); tl1 := MPoint(ap2,tl1); tl2 := Mpoint(ap3,ap4); tl2 := Mpoint(ap3,tl2); p[0] := Point(Round(tl1.x),Round(tl1.y)); p[1] := Point(Round(tl2.x),Round(tl2.y)); DrawLinePix(p[0],p[1],0); end; procedure TPCDrawEngine.ClipAnd(clpRgn: HRGN); begin if clipRgn = 0 then ExClip := 0 else begin DeleteObject(ExClip); ExClip := CreateRectRgn(0,0,0,0); GetClipRgn(Canvas.Handle,ExClip); end; ExtSelectClipRgn(Canvas.Handle,clpRgn,RGN_AND); end; procedure TPCDrawEngine.ClipBack; begin Clip(ExClip); end; (* procedure DrawOpacityBrush(ACanvas: TCanvas; aRect: TRect; X, Y: Integer; AColor: TColor; Opacity: Byte); var Bmp: TBitmap; I, J: Integer; Pixels: PRGBQuad; ColorRgb: Integer; ColorR, ColorG, ColorB: Byte; aBlendFunc : TBlendFunction; bmpPixels: PByteArray; bmpR, bmpG, bmpB: Byte; rgbRes: Byte; //GdiGraph : TGPGraphics; //GDIBrush : TGPSolidBrush; begin Bmp := TBitmap.Create; try Bmp.PixelFormat := pf32Bit; // needed for an alpha channel Bmp.Width := (aRect.Right - aRect.Left); Bmp.Height := (aRect.Bottom - aRect.Top); // Bmp.Transparent := true; // Bmp.TransparentColor := clGreen; with Bmp.Canvas do begin // нельзя чтобы совпадал цвет, иначе получится полная прозрачность (типа не будет заливки) if AColor <> clFuchsia then Brush.Color := clFuchsia // background color to mask out else Brush.Color := clSkYBlue; Brush.Color := AColor; ColorRgb := ColorToRGB(Brush.Color); ColorR := GetRValue(ColorRgb); ColorG := GetGValue(ColorRgb); ColorB := GetBValue(ColorRgb); // must pre-multiply the pixel with its alpha channel before drawing ColorR := (ColorR * Opacity) div $FF; ColorG := (ColorG * Opacity) div $FF; ColorB := (ColorB * Opacity) div $FF; Brush.Color := RGB(ColorR, ColorG, ColorB); FillRect(Rect(0,0,Bmp.Width,Bmp.Height)); {Pen.Color := AColor; Pen.Style := psSolid; Pen.Width := aRect.Bottom - aRect.Top; } //MoveTo(0,0); //LineTo(0,(aRect.Right - aRect.Left)); // MoveTo(ASize div 2, ASize div 2); // LineTo(ASize div 2, ASize div 2); end; Bmp.Canvas.Refresh; { bmp.Canvas.Brush.Color:= aColor;// clBlue; bmp.Canvas.Pen.Width := 1; bmp.Canvas.Pie(55,55, 200,200, 200,0, 0,0); //bmp.Canvas.FloodFill(90,90, clBlack, fsBorder); } for I := 0 to Bmp.Height-1 do begin Pixels := PRGBQuad(Bmp.ScanLine[I]); for J := 0 to Bmp.Width-1 do begin with Pixels^ do begin rgbReserved := Opacity; end; Inc(Pixels); end; end; { for I := 0 to Bmp.Height-1 do begin Pixels := PRGBQuad(Bmp.ScanLine[I]); for J := 0 to Bmp.Width-1 do begin with Pixels^ do begin if (rgbRed = ColorR) and (rgbGreen = ColorG) and (rgbBlue = ColorB) then rgbReserved := 0 else rgbReserved := Opacity; // must pre-multiply the pixel with its alpha channel before drawing rgbRed := (rgbRed * rgbReserved) div $FF; rgbGreen := (rgbGreen * rgbReserved) div $FF; rgbBlue := (rgbBlue * rgbReserved) div $FF; end; Inc(Pixels); end; end; } //end; DrawAlphaAPI(bmp, ACanvas, x, y, Opacity); finally Bmp.Free; end; (* bmp.PixelFormat := pf32Bit; Bmp.Width := (aRect.Right - aRect.Left); Bmp.Height := (aRect.Bottom - aRect.Top); bmp.HandleType := bmDIB; bmp.ignorepalette := true; //bmp.alphaformat := afPremultiplied; ColorRgb := ColorToRGB(AColor); ColorR := GetRValue(ColorRgb); ColorG := GetGValue(ColorRgb); ColorB := GetBValue(ColorRgb); GdiGraph := TGPGRaphics.Create(bmp.Canvas.Handle); GDiBrush := TGPSolidBrush.Create(GdiPapi.MakeColor(Opacity, ColorR, ColorG, ColorB)); GdiGraph.FillRectangle(GDIBrush, GdiPapi.MakeRect(0,0,Bmp.Width, bmp.Height)); GDIBrush.Free; GdiGraph.Free; // BitBlt(ACanvas.Handle, x, y, bmp.Width, bmp.Height, bmp.Canvas.Handle, 0, 0, srcCopy); //aCanvas.CopyRect(Rect(x,y,Bmp.Width + x, Bmp.Height + y), Bmp.Canvas, Rect(0,0,Bmp.Width, Bmp.Height)); DrawAlphaAPI(bmp, ACanvas, x, y, Opacity); Bmp.Free; *) (* end; *) procedure TPCDrawEngine.FillRect(rect: TDoubleRect; bc, bs: Integer; aTransParency: Integer = 0); var xRect: TRect; z: Double; begin if aTransParency = 100 then exit; FCanvas.brush.color := bc; FCanvas.brush.style := TBrushStyle(bs); //DrawOpacityBrush(FCanvas, Round(rect.Left), Round(rect.top), clGreen, Round(rect.right - rect.Left), 120); ConvertCoord(rect.left,rect.top,z); ConvertCoord(rect.right,rect.bottom,z); xRect := Classes.Rect(Round(rect.Left),Round(rect.top),Round(rect.right),Round(rect.bottom)); // Tolik 24/06/2017 -- //if aTransParency = 0 then // if aTransParency = 0 then Windows.FillRect(FCanvas.Handle,xrect,FCanvas.Brush.Handle) else //DrawOpacityBrush(FCanvas, ABS(xRect.Right - xRect.Left), Round(rect.Left), Round(rect.top), FCanvas.brush.color, ABS(xRect.Bottom - xRect.Top), 120); //DrawOpacityBrush(FCanvas, ABS(xRect.Right - xRect.Left), Round(rect.Left), Round(rect.top), FCanvas.brush.color, ABS(xRect.Bottom - xRect.Top), 255 - Round(aTransparency*2.55)); // Tolik 03/11/2017 -- тут вводим ограничение на размер битмапа в 200 000 000, а то ебнется на отрисовке (системе не хватит // ресурсов на отрисовку битмапа ), все что превышает указанный размер - прозрачным рисовать не будем // DrawOpacityBrush(FCanvas, xRect, Round(rect.Left), Round(rect.top), FCanvas.brush.color, Byte( 255 - Round(aTransparency*2.55)) ) begin // if ((Rect.Right - Rect.Left ) * (Rect.Bottom - Rect.Top) * 4) < 200000000 then try DrawOpacityBrush(FCanvas, xRect, Round(rect.Left), Round(rect.top), FCanvas.brush.color, Byte( 255 - Round(aTransparency*2.55)) ) except on E: exception do Windows.FillRect(FCanvas.Handle,xrect,FCanvas.Brush.Handle); end; end; end; function TPCDrawEngine.ExtCreatePenMy(aCanva: TCanvas): HPEN; //01.11.2011 const //01.11.2011 PenStyles: array[TPenStyle] of Word = //01.11.2011 (PS_SOLID, PS_DASH, PS_DOT, PS_DASHDOT, PS_DASHDOTDOT, PS_NULL, //01.11.2011 PS_INSIDEFRAME); var LogPen: TLogPen; lb: TLogBrush; i: Integer; aHan: HPEN; aPrinting: Boolean; Styles: array[0..3] of Integer; OldMode: integer; Begin result := aCanva.Pen.Handle; //01.11.2011 - тормозит жутко //aPrinting := False; //try // if aCanva.Handle = Printer.Canvas.Handle then // begin // if FDeviceName <> Printer.Printers[Printer.PrinterIndex] then // GetDeviceSettings; // aPrinting := True; // end; //except //end; aPrinting := FPrinting; if aPrinting then begin with LogPen do try begin lopnStyle := Ord(ExtPenStyles[FCanvas.Pen.Style]); lopnWidth.X := FCanvas.Pen.Width; lopnColor := ColorToRGB(FCanvas.Pen.Color); if (FCanvas.Pen.Mode <> pmXor) and (FCanvas.Pen.width > 1) then begin // if (FCanvas.Pen.Style = psSolid) or (FCanvas.Pen.Style = psDash) or (FCanvas.Pen.Style = psDot) then begin oldMode := -1; oldMode := SetMapMode (FCanvas.Handle, MM_ANISOTROPIC); SetWindowExtEx (FCanvas.Handle, GetDeviceCaps(FCanvas.Handle, LOGPIXELSX), GetDeviceCaps(FCanvas.Handle, LOGPIXELSY), Nil); SetViewportExtEx (FCanvas.Handle, GetDeviceCaps(FCanvas.Handle, LOGPIXELSX), GetDeviceCaps(FCanvas.Handle, LOGPIXELSY), Nil); lb.lbStyle := BS_SOLID; lb.lbColor := ColorToRGB(FCanvas.Pen.Color); lb.lbHatch := 0; aHan := ExtCreatePen(PS_GEOMETRIC or lopnStyle or PS_ENDCAP_SQUARE or PS_JOIN_MITER, Round(FCanvas.pen.width * FPixelsPerMMY / 3.3 ),lb, 0, nil); result := aHan; if OldMode > 0 then SetMapMode (FCanvas.Handle, OldMode) ; end; (* if (FCanvas.Pen.Style = psDash) then begin lb.lbStyle := BS_SOLID; lb.lbColor := ColorToRGB(FCanvas.Pen.Color); lb.lbHatch := 0; Styles[0] := Round(18 * FPixelsPerMMY / 5.8 ); Styles[1] := Round(6 * FPixelsPerMMY / 5.8 ); Styles[2] := Round(18 * FPixelsPerMMY / 5.8 ); Styles[3] := Round(6 * FPixelsPerMMY / 5.8 ); aHan := ExtCreatePen(PS_GEOMETRIC or PS_USERSTYLE or lopnStyle or PS_ENDCAP_FLAT or PS_JOIN_MITER {PS_JOIN_BEVEL}, Round(FCanvas.pen.width * FPixelsPerMMY / 3.3 ),lb, 4, @Styles[0]); result := aHan; end; if (FCanvas.Pen.Style = psDot) then begin lb.lbStyle := BS_SOLID; lb.lbColor := ColorToRGB(FCanvas.Pen.Color); lb.lbHatch := 0; Styles[0] := Round(3 * FPixelsPerMMY / 5.8 ); Styles[1] := Round(3 * FPixelsPerMMY / 5.8 ); Styles[2] := Round(3 * FPixelsPerMMY / 5.8 ); Styles[3] := Round(3 * FPixelsPerMMY / 5.8 ); aHan := ExtCreatePen(PS_GEOMETRIC or PS_USERSTYLE or lopnStyle or PS_ENDCAP_FLAT or PS_JOIN_MITER {PS_JOIN_BEVEL}, Round(FCanvas.pen.width * FPixelsPerMMY / 3.3 ),lb, 4, @Styles[0]); result := aHan; end; *) end else begin result := CreatePenIndirect(LogPen); end; end; except end; end else begin Result := ExtractExtPenByCanvas; //01.11.2011 //with LogPen do // try // begin // lopnStyle := ExtPenStyles[FCanvas.Pen.Style]; // lopnWidth.X := FCanvas.Pen.Width; // lopnColor := ColorToRGB(FCanvas.Pen.Color); // if (FCanvas.Pen.Mode <> pmXor) and (FCanvas.Pen.width>1) then // begin // lb.lbStyle := BS_SOLID; // lb.lbColor := ColorToRGB(FCanvas.Pen.Color); // lb.lbHatch := 0; // aHan := ExtCreatePen(PS_GEOMETRIC or lopnStyle or // PS_ENDCAP_SQUARE or PS_JOIN_MITER {PS_JOIN_BEVEL}, FCanvas.pen.width ,lb, 0, nil); // result := aHan; // end // else // begin // result := CreatePenIndirect(LogPen); // end; // end; // except // end; end; end; initialization {$ifdef demo} if not delphiloaded then application.terminate; {$endif demo} end. (* hPenOld: HPEN; hPen1: HPEN; if (FCanvas.Pen.Mode <> pmXor) and (FCanvas.Pen.width > 1) and (FCanvas.Pen.Style <> psSOlid) and (FCanvas.Pen.Style <> psClear) then if (FCanvas.Pen.Mode <> pmXor) and (FCanvas.Pen.width > 1) then begin hPen1 := ExtCreatePenMy(FCanvas); hPenOld := SelectObject(FCanvas.Handle, hPen1);//связываем перо с контекстом // SelectObject(FCanvas.Handle, hPenOld); //восстанавливаем предыдущее состояние DeleteObject(hPen1);//удаляем перо end else begin end; *)