unit DrawObjects; interface uses SysUtils, WinTypes, WinProcs, Messages, Classes, Controls, Forms, Dialogs,ExtCtrls,comctrls,buttons,stdctrls,extdlgs, windows,math,PCTypesUtils,Graphics,DrawEngine, U_Common_Classes, Menus,RichForm,RichEdit2,OleCtnrs,rrEllipses, LibJpeg, inputForm,GUIStrings,magwand, {Tolik 24/05/2019 -- } RichEdit, {GDIPlus, GDIPAPI,} GDIPOBJ, U_RasterImageSettings {$IF Not Defined (FINAL_SCS)} // , GDIPUTIL {$IFEND } ; Type TRoomConfig = Packed record aWorkRoom: Boolean; aPlenumArea: Boolean; aUnroutableArea: Boolean; IsCabinetExt: Boolean; POintCount: Integer; CabinetNumPos: Integer; CabinetSignPos: Integer; NumRadius: Integer; end; // Tolik TPieCutStyle = (PieLinearCut, PieArcCut); // тип обрезки сектора от центра // ProomConfig = ^TRoomConfig; TLayer = class; TPattern = class; TVector = class; TFigure = class; TFigureGrp = class; TPolyline = class; TFigMoveEvent = Procedure (Sender: TFigure;dx,dy:integer) of object; //Tolik TRegionObject = Class; // Tolik 24/12/2019 -- //TModPoint = class (TObject) TModPoint = class (TMyObject) // CoordX : Double; CoordY : Double; CoordZ : Double; SeqNbr : integer; PType : TModPointType; DType : TPointType; Figure : TFigure; Color : TColor; Dim : Double; PixX: integer; PixY: integer; PixDetX:Integer; PixDetY:Integer; Tag: Integer; Obj1: LongInt; Obj2: LongInt; Obj3: LongInt; Obj4: LongInt; OnlyIso: Boolean; isBlink:Boolean; isDraw:Boolean; //FIsDrag: Boolean; Constructor Create(aFigure: TFigure; aType: TModPointType; aDType: TPointType; aColor: TColor; aDim, X,Y: Double; aSeqNbr: integer; Z: Double=0); Function IsPointIn(x,y,pdim: Double):Boolean; Function IsPointInInt(x,y,pdim: Integer):Boolean; Function IsPointInDetInt(x,y,pdim: Integer):Boolean; //Tolik Destructor Destroy; override; end; TLayer = class (tobject) name : string[255]; ModPoints : TList; visible: TShow; DrawEngine: TPCDrawEngine; Data: TObject; vertZero: integer; horzZero: integer; PenColor : TColor; BrushColor: TColor; TextColor : TColor; Description: String; Tag: Integer; LayerWidth: Integer; LayerHeight: Integer; IsDxf: boolean; tmpVisible: TShow; constructor create(aname:string); destructor Destroy; Procedure WriteToStream(stream:TStream;CadControl:TObject); class Function CreateFromStream(Stream:TStream; aDEngine: TPCDrawEngine;CadControl:Tobject):TLayer; Procedure SetLayerPropertyInt(xCode:Byte; Value:Integer); Procedure SetLayerPropertyStr(xCode:Byte; Value:String); Procedure SetLayerPropertyDbl(xCode:Byte; Value:Double); Procedure SetLayerPropertyStream(xCode:Byte; Stream:TStream;CadControl:TObject); end; //Tolik TRegionObject = class(TMyObject) protected public RegObjOwner: TFigure; CheckPointByRects: Boolean; RegObjDataLength: Cardinal; RegObjData: PRgnData; //RegObjData: Pointer; // здесь будет сидеть все описание региона (у него же и украдем, прежде, чем убить) //RectArray: array of TRect; procedure GetRegData(RegObjHandle: HRGN); constructor create(RegionObjectOwner: TFigure); destructor destroy; override; end; // TFigureClass = class of TFigure; TFigureFill = class(TMyObject) public Owner: TFigure; Step: Double; TxtSize: Integer; FillType: TFillType; HatchStyle: THatchStyle; GradStyle: TGradStyle; TextureStyle: TTextureStyle; Color: TColor; BackColor: TColor; Grp: TFigureGrp; PenStyle: TPenStyle; PenWidth: Integer; GradBmp: TBitmap; TxtBmp: TBitmap; Empty: Boolean; UseBack: Boolean; Procedure Move(dx,dy:Double); Procedure Rotate(Angle:Double;cPoint:TDoublePoint); Procedure Scale(px,py:Double;rPoint:TDoublePoint); Procedure SetPen(pStyle:TPenStyle;pWidth:Integer); Procedure SetStyle(FType:TFillType;Data:Integer); Procedure SetColor(FColor:TColor); Procedure SetBackColor(BColor:TColor); Procedure SetTextSize(TxSize:Integer); Procedure SetHatchStep(FStep:Double); Procedure Clear; Constructor Create(AOwner:TFigure;FStep:Double;FType:TFillType;Data:Integer); Destructor Destroy; override; Procedure SetSubData(Data:Integer); Procedure ReGenerate; Procedure BuildHatch; Procedure BuildGradient; Procedure BuildTexture; Procedure Draw(DEngine: TPCDrawEngine;isGrayed:Boolean); end; TFigure = class(TMyObject) private fLockModify: Boolean; fLockMove: Boolean; fLockSelect: Boolean; fDiagonal: Boolean; fIncombined: Boolean; procedure SetInCombined(const Value: Boolean);virtual; Protected FOnMouseDownMacro: String; FOnModifiedMacro: String; FOnMouseUpMacro: String; FBeforeDeleteMacro: String; FOnDblClickMacro: String; FOnMoveMacro: String; FOnClickMacro: String; originals :TDoublePointArr; actuals :TDoublePointArr; // Tolik 24/12/2019 -- //SelPoints: TList; SelPoints: TMyList; // MenuIndex: Integer; OldStyleLoad: Boolean; fTempPoints: array of TPoint; fPointEvent: Boolean; CreateDims: Boolean; Function GdiBrs:Integer; Function GetAp1: TDoublePoint;virtual; Function GetAp2: TDoublePoint;virtual; Function GetAp3: TDoublePoint;virtual; Function GetAp4: TDoublePoint;virtual; function getCp: TDoublePoint; Procedure GetPointArray(var Arr:TDoublePointArr);overload; Procedure GetPointArray(var Arr:TDoublePointArr;Count: Integer);overload; Function GetOrig(index: integer): TDoublePoint; Procedure SetOrig(index: integer; xpoint: TDoublePoint); Function GetActual(index: integer): TDoublePoint; Procedure SetActual(index: integer; xpoint: TDoublePoint); Function GetPoint(index: integer): TDoublePoint; Procedure SetPoint(Index: integer; const Value: TDoublepoint); Function GetP1: TDoublePoint; Procedure GetRotatePoints(ModList: TList);virtual; Procedure GetRegionPoints(var points: array of TDoublePoint);virtual; Procedure CreateDimLinesFromStream(xStream:TStream;LHandle:Integer;Owner:TComponent); Procedure OnNewPoint;virtual; Procedure ClearPoints; Procedure RedimenPoints; Function NeedRegion:Boolean; Property InCombined: Boolean read fIncombined write SetInCombined; public Fill: TFigureFill; DragMove: Boolean; Shift: TShiftState; OnModified: TnotifyEvent; UserClass:String; Name: String; Cname: String; AngletoPoint : Double; RotPoint : TDoublePoint; DrawStyle : PCTypesUtils.TDrawStyle; Modified : Boolean; Selected : Boolean; FirstSelected : Boolean; SelectedPoint:Integer; IsOp : Boolean; Deleted : Boolean; Radius : Double; RMode:Boolean; vertZero: integer; horzZero: integer; Icon: TBitmap; IconX,IconY: Double; IconVertPos: TIconVertPos; IconHorzPos: TIconHorzPos; Urc: Integer; // Undo recorded Count //internal use only JoinedFigures: TList; SelOrder: Integer; DelIndex: Integer; TracePoint:TModPoint; IsDrawingDetail: Boolean; DimLines:TList; EditX: Double; EditY: Double; PopStyle: TFigurePopStyle; CustomPops: String; Visible:Boolean; ClipFigures: TList; NativeFill: Boolean; InClip: Boolean; NotNeedToDraw: Boolean; FClassIndex: ShortInt; InsideCabinet: Boolean; Function IsPointInRegion(x,y: Double): Boolean;overload; Function IsPointInRegion(x,y: Double;reg:Integer): Boolean;overload; //Tolik Function IsPointInRegionByRegObj(x,y: Double): Boolean;overload; // попадет ли точка в регион Function IsPointInRegionByRegObj(x,y: Double; RegObj: TRegionObject): Boolean;overload; // попадет ли точка в регион function ptInRegionByRegObj(x,y: Double; RegObj: TRegionObject): Boolean; // типа вместо ptInRegion (Tolik) Function GetRegionBox(var r: TRect): Integer; // вернет границы региона (прямоугольник или 0, если нечего вернуть) Procedure ResetRegObject; // сброс данных о регионе procedure GetRegObject; // получение данных о регионе // Procedure ClearClipFigures; Procedure MoveClipFigures(deltax,deltaY:Double); Procedure RefreshHatch; Procedure Unfilled;virtual; Procedure OnFigureModified;virtual; Procedure ClearDimLines;virtual; Procedure CreateDimLines;virtual; //Procedure GetModPoints(ModList: TList);virtual; procedure getModPoints(ModList: TMyList);virtual; Function Offset(Thick:Double):TFigure;virtual; Procedure ClearBounds; Function GetClassName:String;virtual; Procedure VerifyZeroPoints(orgV,orgH:Byte);virtual; Class Function ShadowType:TShadowType;virtual; Class Function IsOneClick:Boolean;virtual; Class Function InsideSelection:Boolean;virtual; Procedure Initialize;virtual; Function Rename:String;virtual; Function Edit: Boolean;virtual; Procedure SelectPoint(Modpoint:TModPOint);virtual; Procedure DeSelectPoint(Modpoint:TModPOint);virtual; Function SnapPoints(var x,y:Double;DotsPerMil:Double):Boolean;virtual; Procedure GetBounds(var figMaxX,figMaxY,figMinX,figMinY: Double);virtual; Procedure getboundsWithoutGrpSize(var figMaxX,figMaxY,figMinX,figMinY: Double);virtual;abstract; Procedure GetSelBounds(var figMaxX,figMaxY,figMinX,figMinY: Double);virtual; Procedure UpdateBounds(var figMaxX,figMaxY,figMinX,figMinY: Double);virtual; Procedure GetIsometricBounds(var figMaxX,figMaxY,figMinX,figMinY: Double);virtual; Procedure GetRegionBounds(var figMaxX,figMaxY,figMinX,figMinY: Double);virtual; Function GetBoundRect(UseGRpSize: boolean):TDoubleRect;overload; Function GetBoundRect:TDoubleRect;overload;virtual; Procedure Move(deltax, deltay: Double);virtual; Procedure Rotate(aAngle: Double);overload; Procedure Rotate(aAngle: Double; cPoint: TDoublePoint);overload;virtual; Procedure Mirror(Point1,Point2: TDoublePoint);virtual; Procedure Scale(px,py: Double);overload; Procedure Scale(px,py: Double; rPoint: TDoublepoint);overload;virtual; Procedure ModifySelection(mm: TModifyMode; value: Integer);virtual; Function ModifyTextAndFont(mm: TModifyMode; valueI: Double; valueS:string; valueSt: TFontStyles; ValueB:Boolean):Boolean;virtual; Function IsPointIn(x,y:Double): boolean; virtual; Function IsPointInInt(x,y:Integer): boolean; virtual; Function CheckifInArea(area: TDoubleRect): Boolean; Function Duplicate: TFigure; virtual; Procedure CopyProperties(Figure:TFigure);virtual; procedure Draw(DEngine: TPCDrawEngine;isGrayed:Boolean);virtual; procedure DrawDimLines(DEngine: TPCDrawEngine;isGrayed:Boolean);virtual; procedure DrawDetail(DEngine: TPCDrawEngine;DetailStyle:TDetailStyle);virtual; Procedure CollectFaces(Faces:Tlist);Virtual; procedure DrawRotTrace(DEngine: TPCDrawEngine;isGrayed:Boolean); procedure ResetRegion;virtual; procedure SetModified;virtual; Procedure Select;Virtual; Procedure Deselect;Virtual; Procedure ReSelect;Virtual; Procedure ReSelectUnsel;Virtual; //02.04.2012 Procedure ReSelectSel;Virtual; //02.04.2012 Procedure RotateSelect;Virtual; Procedure SetHatch(HStyle:THatchStyle;ForeColor,BackColor:TColor;StepSize:Double);virtual; Procedure SetGradient(GStyle:TGradStyle;ForeColor,BackColor:TColor);virtual; Procedure SetTexture(TStyle:TTextureStyle;TexSize:Integer);virtual; Procedure DrawFill(DEngine: TPCDrawEngine;isGrayed:Boolean);Virtual; Procedure DrawClipFigures(DEngine: TPCDrawEngine;isGrayed:Boolean);Virtual; Procedure DrawSelPoint(DEngine: TPCDrawEngine;isGrayed:Boolean;mp:TModPoint); Procedure DrawSelectionPoints(DEngine: TPCDrawEngine;isGrayed:Boolean);virtual; Procedure DrawFigureGuides(DEngine: TPCDrawEngine);virtual; Procedure DrawFigureGuidesInDetail(DEngine: TPCDrawEngine;DetailStyle:TDetailStyle);virtual; Constructor Create(LHandle:LongInt; aDrawStyle:PCTypesUtils.TDrawStyle; aOwner: TComponent); class Function CreateFromStream(Stream: TStream; LHandle:LongInt; aDrawStyle: PCTypesUtils.TDrawStyle;aOwner: TComponent): TFigure; Class Function CreateFromShadow(aOwner:TComponent;LHandle:LongInt;Shadow:TFigure):TFigure;virtual; Destructor Destroy;override; class Function CreateShadow(x,y:Double): TFigure;virtual; Function ShadowClick(ClickIndex: Integer; x,y: Double):Boolean;virtual; Function ShadowTrace(ClickIndex: Integer; x,y: Double):Boolean;virtual; Function ShadowKeyStroke(var ClickIndex,KeyCode:Integer;Shift:TShiftState;var Fnished:Boolean):Boolean;virtual; Function CreateModification: TFigure;virtual; Function TraceModification(CadControl: Pointer;mp:TModPoint;TraceFigure:TFigure; x,y:Double;Shift: TShiftState):boolean;virtual; Function EndModification(CadControl: Pointer;mp:TModPoint;TraceFigure:TFigure; x,y:Double;Shift: TShiftState):boolean;virtual; Function TraceRotate(CadControl: Pointer;mp:TModPoint;var TraceFigure:TFigure; x,y:Double;Shift: TShiftState):boolean;virtual; Function EndRotate(CadControl: Pointer;mp:TModPoint;TraceFigure:TFigure; x,y:Double;Shift: TShiftState):boolean;virtual; Function GetStartPoint:TDoublePoint;virtual; Function GetEndPoint:TDoublePoint;virtual; Function IsWelded(f:Tfigure): Integer; Procedure ShowProperties;virtual; Procedure PropUpdate(PropName,PropVal:String);virtual; Procedure UpdateMenu(var popMenu: TPopUpMenu;var sIndex:Integer);virtual; Procedure MenuClicked(commandId:integer);virtual; Procedure WriteToStream(Stream:TStream);virtual; Procedure SetPropertiesFromStream(Stream: TStream); Procedure SetSpecialPropertiesFromStream(Stream: TStream);virtual; Procedure SetPropertyFromStream(xCode:Byte;data:pointer;size:integer);virtual; Procedure GetVectorObjects(Objects:Tlist;BaseP: TDoublePoint);virtual; Procedure SendSignal(port:Integer;value:Integer);virtual; Function DuplicateAsBezier:TFigure;virtual; Function DuplicateAsStroke:TFigure;virtual; Function isVisible:Boolean; Function Knife(p1,p2:TdoublePoint;Figures:TList):Boolean;virtual; Function BreakbyPoints(p:TdoublePointArr;var Figures:TList):boolean;virtual; Function BreakByPoint(p:TdoublePoint;var Figures:TList):boolean;virtual; Function GetLinearInterSections(p1,p2:TDoublePoint; var pArr:TDoublePointArr):Boolean;virtual; Function GetZAvg(dRect:TDoubleRect;var fAvg:Double):Boolean;virtual; Function GetLength:Double;virtual; Function GetArea: Double;virtual; Property OriginalPoints[Index : integer]:TDoublepoint read GetOrig write SetOrig; Property ActualPoints[Index : integer]:TDoublepoint read GetActual write SetActual; Property ap1: TDoublePoint read getAp1; Property ap2: TDoublePoint read getAp2; Property ap3: TDoublePoint read getAp3; Property ap4: TDoublePoint read getAp4; Property CenterPoint:TDoublePoint read getCp; (* Property OnMoveMacro: String read FOnMoveMacro write FOnMoveMacro; Property OnMouseDownMacro: String read FOnMouseDownMacro write FOnMouseDownMacro; Property OnMouseUpMacro: String read FOnMouseUpMacro write FOnMouseUpMacro; Property OnClickMacro: String read FOnClickMacro write FOnClickMacro; Property OnDblClickMacro: String read FOnDblClickMacro write FOnDblClickMacro; Property OnModifiedMacro: String read FOnModifiedMacro write FOnModifiedMacro; Property BeforeDeleteMacro: String read FBeforeDeleteMacro write FBeforeDeleteMacro; *) public Handle: TFigHandle; ID: Integer; DataID: integer; LayerHandle: LongInt; Owner: TComponent; width: integer; color: integer; Style: integer; RowStyle : Integer; Angle: Double; Brc,Brs : integer; ExHatchStyle :THatchStyle; ExGradStyle :TGradStyle; ExTextureStyle :TTextureStyle; ExFillBackColor:TColor; ExHatchStepSize: Double; ExTextureSize: Integer; PointCount: integer; RegHandle : HRGN; //Tolik RegObject: TRegionObject; // Tolik -- 26/05/2017 -- процент прозрачности для заливки фигуры // по умолчанию выставим в 0 типа == 0% прозрачности Transparency: integer; isAutoCreatedFigure: Byte; // Tolik -- 30/05/ 2017 -- если фигура создана автоматически = 1 иначе = 0 // id_for_dellist: Integer; Data: Pointer; CustomStream: TStream; Info:String; FullHitTest: Boolean; DrawInfo: Boolean; FBoundRect: TDoubleRect; //31.10.2011 FIsLoadedBounds: Boolean; //31.10.2011 Parent: TFigure;//28.04.2011 FBeforeAllScale: TNotifyEvent; //27.05.2011 FAfterAllScale: TNotifyEvent; //27.05.2011 //FAfterScalingBeforeEvents: TNotifyEvent; //23.09.2011 - Событие после Scale всех объектов и перед FScaleAllEvent FScaleAllEvent: TNotifyEvent; //27.05.2011 FBeforeDelFromParent: TNotifyEvent; //22.09.2011 - вызывается перед free из группы FAfterUndo: TNotifyEvent; //23.09.2011 - вызывается после undo всех объектов Property FigurePoints[Index : integer]:TDoublepoint read GetPoint write SetPoint; Property LockMove: Boolean read fLockMove write fLockMove; Property LockSelect: Boolean read fLockSelect write fLockSelect; Property LockModify: Boolean read fLockModify write fLockModify; Property DiagonalScale: Boolean read fDiagonal write fDiagonal; function GetModPointBySeqNbr(ANbr: Integer; x, y: Double): TModPoint; end; TFigureGrp = class(TFigure) private procedure SetCombined(const Value: Boolean); protected procedure SetInCombined(const Value: Boolean);override; public FMetafile: TMetafile; InFigures: TList; bDeltaX,bDeltaY: double; Changed: Boolean; FCombined: Boolean; FReLoad: Boolean; UnGrouped: Boolean; LoadIdx: Integer; AlwaysTogether: Boolean; UseMetafile: Boolean; BoundCalc : Boolean; DimLocked: Boolean; Mirrored: Boolean; DrawRatio: Double; // Tolik 27/06/2017 -- HasAutocreatedFigures: Boolean; // Procedure SetHatch(HStyle:THatchStyle;ForeColor,BackColor:TColor;StepSize:Double);override; Procedure SetGradient(GStyle:TGradStyle;ForeColor,BackColor:TColor);override; Procedure SetTexture(TStyle:TTextureStyle;TexSize:Integer);override; Procedure Unfilled;override; Function Edit:Boolean;override; Procedure Initialize;override; Function Rename:string;override; procedure ResetRegion;override; procedure SetModified;override; Procedure UnGroup; Procedure SetFieldText(FName, FValue: String); Procedure ReplaceTextWithWMF(FName: String; mf:TMEtafile); Procedure RemoveInFigure(FName: String); Procedure AddFigure(fig: TFigure; AResetReg: Boolean=true); // Tolik -- 22/08/2017 -- Procedure InsertFigure(fig: TFigure; AResetReg: Boolean = True); // Procedure CreateMetaFile; Procedure ClearFigureList; constructor create(LHandle: LongInt;aOwner: TComponent); Procedure DestroyInFigures; Destructor Destroy;override; Destructor DestroyGrp; procedure move(deltax, deltay: double);override; procedure draw(DEngine: TPCDrawEngine; isGrayed: Boolean);override; Procedure DrawInFigures(DEngine: TPCDrawEngine; isGrayed:Boolean); Procedure SetOwnerProps; Procedure DrawFigureGuides(DEngine: TPCDrawEngine);override; //procedure getModPoints(ModList: TList);override; procedure getModPoints(ModList: TMyList);override; function isPointIn(x,y: double): boolean;override; procedure getbounds(var figMaxX,figMaxY,figMinX,figMinY: double);override; procedure getInbounds(var figMaxX,figMaxY,figMinX,figMinY: double); // Tolik 29/06/2017 -- procedure GetBoundsWithoutAutoCreatedFigures(var figMaxX,figMaxY,figMinX,figMinY: double); procedure GetINBoundsWithoutAutoCreatedFigures(var figMaxX,figMaxY,figMinX,figMinY: double); procedure GetBoundsWithAutoCreatedFigures(var figMaxX,figMaxY,figMinX,figMinY: double); // Function duplicate:TFigure; override; Function DuplicateAsBezier:TFigure; override; Procedure Mirror(Point1,Point2: TdoublePoint);override; Procedure ModifySelection(mm: TModifyMode; value: Integer);override; Function ModifyTextAndFont(mm: TModifyMode; valueI:Double; valueS:string; valueSt: TFontStyles;ValueB:Boolean):Boolean;override; Procedure WriteToStream(Stream:TStream);override; Procedure SetPropertyFromStream(xCode:Byte;data:pointer;size:integer);override; Procedure SetSpecialPropertiesFromStream(Stream: TStream);override; Function CreateModification: TFigure;override; Function TraceModification(CadControl: Pointer;mp:TModPoint;TraceFigure:TFigure; x,y:double;Shift: TShiftState):boolean;override; Function EndModification(CadControl: Pointer;mp:TModPoint;TraceFigure:TFigure; x,y:double;Shift: TShiftState):boolean;override; Function CountBlock(BlockName:String):integer; Procedure UpdateMenu(var popMenu: TPopUpMenu;var sIndex:Integer);override; Procedure MenuClicked(CommandId:integer);override; Procedure GetVectorObjects(Objects:Tlist;BaseP: TDoublePoint);override; Procedure VerifyZeroPoints(orgV,orgH:Byte);override; Procedure SetReload(Value:Boolean); Procedure GetFigures(xList:TList); Function GetClassName:String;override; Procedure DrawDimlines(DEngine:TPCDrawEngine;isGrayed:Boolean);override; Procedure LockDimensions(w,h:Double); Procedure Rotate(aAngle: double; cPoint: TdoublePoint);override; Procedure scale(percentx,percenty: double; rPoint: Tdoublepoint);override; function AddToGrp(AFigure: TFigure): Integer; //28.04.2011 function RemoveFromGrp(AFigure: TFigure): Integer; //28.04.2011 // Tolik 14/09/2017 -- Function GetBoundRectWithoutAutoCreatedFigures: TDoubleRect; // // Tolik 27/06/2017 -- function CheckHasAutocreatedFigures(aFigure: TFigure): Boolean; function InsertFig(aFigure: TFigure): Integer; // Property ReLoading: Boolean read FReload write SetReload; Property Combined:Boolean read FCombined write SetCombined; end; TBlock = class(TFigureGrp) Blockname: String; //CCount: integer; OrgVz: Byte; OrgHz: Byte; MapScale: Double; Procedure Initialize;override; Function Rename:string;override; constructor Create(LHandle: LongInt;aOwner: TComponent); Procedure WriteToStream(Stream:TStream);override; Procedure SetPropertyFromStream(xCode:Byte;data:pointer;size:integer);override; Function duplicate:TFigure; override; Function GetClassName:String;override; //procedure CreateProperties; procedure SaveToFile(const AFileName: String); //27.08.2010 //#From Oleg# End; TLine = class(TFigure) InMoveList: Boolean; JoinFigure1,JoinFigure2: Tfigure; RowH,RowL: Double; RowWhite: Boolean; KeepAngle: Boolean; EndMod: Boolean; Function SnapPoints(var x,y:Double;DotsPerMil:Double):Boolean;override; Procedure Initialize;override; Procedure SetJFigure1(jf:TFigure);virtual; Procedure SetJFigure2(jf:TFigure);virtual; Procedure UnBound;virtual; Procedure JoinFigureMoved(Sender: TFigure; dx,dy:double);virtual; constructor create( aX1,aY1,aX2,aY2:Double; w,s,c: integer; row:integer; LHandle: LongInt; aDrawStyle: PCTypesUtils.TDrawStyle;aOwner: TComponent);reintroduce; //Tolik destructor Destroy;override; // class Function ShadowType:TShadowType;override; procedure draw(DEngine: TPCDrawEngine; isGrayed:Boolean);override; Procedure DrawFigureGuides(DEngine: TPCDrawEngine);override; //procedure getModPoints(ModList: TList);override; procedure getModPoints(ModList: TMyList);override; function isPointIn(x,y: double): boolean;override; procedure getbounds(var figMaxX,figMaxY,figMinX,figMinY: double);override; Function duplicate:TFigure; override; Function DuplicateAsBezier:TFigure;override; Function GetLinearInterSections(p1,p2:TDoublePoint; var pArr:TDoublePointArr):Boolean;override; Function BreakByPoint(p:TdoublePoint;var Figures:TList):boolean;override; Procedure WriteToStream(Stream:TStream);override; Procedure SetPropertyFromStream(xCode:Byte;data:pointer;size:integer);override; class function CreateFromShadow(aOwner: TComponent;LHandle: LongInt;Shadow:TFigure): TFigure;override; Function ShadowClick(ClickIndex: Integer;x,y: Double):Boolean;override; Function ShadowTrace(ClickIndex: Integer;x,y: Double):Boolean;override; Function TraceModification(CadControl: Pointer;mp:TModPoint;TraceFigure:TFigure;x,y:double;Shift: TShiftState):boolean;override; Function EndModification(CadControl: Pointer;mp:TModPoint;TraceFigure:TFigure;x,y:double;Shift: TShiftState):boolean;override; Procedure GetVectorObjects(Objects:Tlist;BaseP: TDoublePoint);override; Procedure Move(deltax, deltay: Double);override; Function Offset(Thick:Double):TFigure;override; Function GetClassName:String;override; Procedure CreateDimLines;override; Function GetLength:Double;override; end; THellical = class(TFigure) STep: Integer; Procedure Initialize;override; constructor create( aX1,aY1,aX2,aY2:Double; w,s,c: integer; row:integer; LHandle: LongInt; aDrawStyle: PCTypesUtils.TDrawStyle;aOwner: TComponent); class Function ShadowType:TShadowType;override; procedure draw(DEngine: TPCDrawEngine; isGrayed:Boolean);override; Procedure DrawFigureGuides(DEngine: TPCDrawEngine);override; //procedure getModPoints(ModList: TList);override; procedure getModPoints(ModList: TMyList);override; function isPointIn(x,y: double): boolean;override; procedure getbounds(var figMaxX,figMaxY,figMinX,figMinY: double);override; Function duplicate:TFigure; override; Function DuplicateAsBezier:TFigure;override; Function GetLinearInterSections(p1,p2:TDoublePoint; var pArr:TDoublePointArr):Boolean;override; Function BreakByPoint(p:TdoublePoint;var Figures:TList):boolean;override; Procedure WriteToStream(Stream:TStream);override; Procedure SetPropertyFromStream(xCode:Byte;data:pointer;size:integer);override; class function CreateFromShadow(aOwner: TComponent;LHandle: LongInt;Shadow:TFigure): TFigure;override; Function ShadowClick(ClickIndex: Integer;x,y: Double):Boolean;override; Function ShadowTrace(ClickIndex: Integer;x,y: Double):Boolean;override; Function TraceModification(CadControl: Pointer;mp:TModPoint;TraceFigure:TFigure;x,y:double;Shift: TShiftState):boolean;override; Function EndModification(CadControl: Pointer;mp:TModPoint;TraceFigure:TFigure;x,y:double;Shift: TShiftState):boolean;override; Procedure Move(deltax, deltay: Double);override; Function Offset(Thick:Double):TFigure;override; Function GetClassName:String;override; end; TUserLine = class(TLine) procedure draw(DEngine: TPCDrawEngine; isGrayed:Boolean);override; Function duplicate:TFigure; override; Function isPointIn(x,y: double): boolean;override; class function CreateFromShadow(aOwner: TComponent;LHandle: Integer; Shadow: TFigure): TFigure;override; Function GetClassName:String;override; end; TVertex = class (TFigure) constructor create(aX,aY: Double;LHandle:LongInt; aDrawStyle: PCTypesUtils.TDrawStyle;aOwner: TComponent); Procedure Initialize;override; Procedure Draw(DEngine: TPCDrawEngine; isGrayed:Boolean);override; //Procedure getModPoints(ModList: TList); override; procedure getModPoints(ModList: TMyList);override; function isPointIn(x,y:double): boolean;override; procedure getbounds(var figMaxX,figMaxY,figMinX,figMinY: double);override; Function duplicate:TFigure; override; Procedure WriteToStream(Stream:TStream);override; class Function CreateShadow(x,y:double): TFigure;override; Function ShadowClick(ClickIndex:Integer; x,y:Double):Boolean;override; Function CreateModification: TFigure;override; Function TraceModification(CadControl: Pointer;mp:TModPoint;TraceFigure:TFigure;x,y:double;Shift: TShiftState):boolean;override; Function EndModification(CadControl: Pointer;mp:TModPoint;TraceFigure:TFigure;x,y:double;Shift: TShiftState):boolean;override; class function CreateFromShadow(aOwner: TComponent;LHandle: LongInt;Shadow:TFigure): TFigure;override; Procedure GetVectorObjects(Objects:Tlist;BaseP: TDoublePoint);override; Function GetClassName:String;override; end; TCircleVertex = class(TVertex) //Procedure getModPoints(ModList: TList); override; procedure getModPoints(ModList: TMyList);override; function isPointIn(x,y:double): boolean;override; Procedure Initialize;override; Procedure Draw(DEngine: TPCDrawEngine; isGrayed:Boolean);override; Function duplicate:TFigure; override; class function CreateFromShadow(aOwner: TComponent;LHandle: LongInt;Shadow:TFigure): TFigure;override; Function GetClassName:String;override; procedure getbounds(var figMaxX,figMaxY,figMinX,figMinY: double);override; Function CreateModification: TFigure;override; end; TUserVertex = class(TVertex) procedure draw(DEngine: TPCDrawEngine; isGrayed:Boolean);override; Function duplicate:TFigure; override; Function isPointIn(x,y: double): boolean;override; class function CreateFromShadow(aOwner: TComponent;LHandle: Integer; Shadow: TFigure): TFigure;override; Function GetClassName:String;override; end; TPlSegment = class(TMyObject) Index: Integer; SType: TSegmentType; CPoint1:TDoublePoint; Cpoint2:TDoublePoint; TangentKnot:Boolean; Inverted: Boolean; tp1,tp2: TDoublePoint; ShowDim:Boolean; Constructor Create(aIndex:Integer;aType:TSegmentType;cp1,cp2:TDoublepoint); Destructor Destroy; // Tolik 13/12/2019 -- Procedure SetVals(aType:TSegmentType;cp1,cp2:TDoublePoint); Procedure Move(deltax, deltay: Double); Procedure Rotate(aAngle: Double; cPoint: TDoublePoint); Procedure Mirror(Point1,Point2: TDoublePoint); Procedure Scale(percentx, percenty: Double; rPoint: TDoublePoint); Function Duplicate:TPlSegment; Function BreakByPoint(knot1,knot2,bp: TDoublePoint; var seg1,seg2: TPLSegment; Knifing:Boolean; kp1,kp2:TDoublePoint):Boolean; Procedure CopyFrom(frSeg:TPLSegment); end; TPolyline = class(TLine) protected Tracing: Boolean; fClosed: Boolean; KnifePoint1: TDoublePoint; KnifePoint2: TDoublePoint; Knifing :Boolean; SavedfigMaxX: double; SavedfigMaxY: double; SavedfigMinX: double; SavedfigMinY: double; SavedStateFig: string; procedure setClosed(const Value: Boolean); procedure CollectPolyLinePoints(var pdPoints: TDoublePointArr); procedure CollectPolyBezierPoints(var pdPoints: TDoublePointArr; var rpS1,rpS2,rpE1,rpE2:TDoublePoint; var fLine,lLine:Boolean);overload; procedure CollectPolyBezierPoints(var pdPoints: TDoublePointArr);overload; Procedure OffSetPolyBezierPoints(var pdPoints: TDoublePointArr;w:Double); Procedure OffSetSegments(var NewSegs: TList;w:Double); Procedure DrawRows(DEngine: TPCDrawEngine;xColor: TColor; rpS1,rpS2,rpE1,rpE2:TDoublePoint;firstLine,lastLine:Boolean); public PenPattern: TPattern; Segments: TList; BrushBitmap: TBitmap; KeyControl : Boolean; HatchLines : TDoublePointArr; HatchSeg: Integer; HatchDist: Double; NeedBounds: Boolean; // Tolik 02/08/2021 -- Procedure HatchBySegment(SegIdx:Integer; Distance:Double); Procedure RemoveHatch; Procedure AssignPenPattern(MasterPattern: TPattern); Procedure ClearSegments; Procedure ArrangeSegment(SegNbr: integer; SegType: TSegmentType); Procedure ArrangeSelectedSegment(SegType: TSegmentType); Procedure InsertKnot(SegNbr:Integer);overload; Procedure InsertKnot(SegNbr:Integer;MP:TDoublePoint);overload; Procedure DivideSegment(SegNbr:Integer;Cnt:Integer); Procedure RoundCornerByArc(SeqNbr:Integer; Rad: Double); Procedure DeleteKnot(SegNbr:Integer); Procedure OnNewPoint;override; Procedure MoveControlPointsOfKnot(KnotNbr: Integer;DeltaX,DeltaY:Double); Procedure GetControlPointsOfKnot(KnotNbr: integer; var cp1,cp2: TDoublePoint); Procedure SetControlPointsOfKnot(KnotNbr: integer; cp1,cp2: TDoublePoint); Procedure GetControlPointsOfSegment(SegNbr: integer; var cp1,cp2: TDoublePoint); Procedure SetControlPointsOfSegment(SegNbr: integer; cp1,cp2: TDoublePoint); Procedure TangentControlLine(KnotNbr: Integer); Procedure BreakControlLine(KnotNbr: Integer); Procedure InvertSegment(KnotNbr: Integer); Function IsKnotTangent(KnotNbr: Integer):Boolean; Function TypeOfSegment(SegNbr: Integer): TSegmentType; Procedure SetJFigure1(jf:TFigure);override; Procedure SetJFigure2(jf:TFigure);override; Procedure UnBound;override; Procedure JoinFigureMoved(Sender: TFigure; dx,dy:double);override; Procedure MenuClicked(CommandId:integer);override; Procedure UpdateMenu(var PopMenu: TPopUpMenu;var sIndex: integer);override; Procedure Initialize;override; constructor create(Points:TDoublePointArr;w,s,c,abrs,abrc: integer;row:integer; aClosed: Boolean; LHandle: LongInt;aDrawStyle: PCTypesUtils.TDrawStyle;aOwner: TComponent); class function createP4(p1,p2,p3,p4:TDoublePoint;w,s,c,abrs,abrc: integer;row:integer; aClosed: Boolean; LHandle: LongInt;aDrawStyle: PCTypesUtils.TDrawStyle;aOwner: TComponent):TPolyline; class function CreateFromBezierPoints(Points:TDoublePointArr;w,s,c,abrs,abrc: integer;row:integer; aClosed: Boolean;LHandle: LongInt; aDrawStyle: PCTypesUtils.TDrawStyle;aOwner: TComponent):TPolyline; procedure draw(DEngine: TPCDrawEngine; isGrayed:Boolean);override; Procedure DrawFigureGuides(DEngine: TPCDrawEngine);override; //procedure getModPoints(ModList: TList);override; procedure getModPoints(ModList: TMyList);override; function isPointIn(x,y: double): boolean;override; function isPointInSegment(SegNbr: Integer; x, y: double): boolean; procedure getbounds(var figMaxX,figMaxY,figMinX,figMinY: double);override; Function duplicate:TFigure; override; Procedure ConvertToBezier; Procedure ConvertToPolyLine; Procedure WriteToStream(Stream:TStream);override; Procedure SetPropertyFromStream(xCode:Byte;data:pointer;size:integer);override; Procedure SegmentsToStream(xStream:TStream); Procedure SegmentsFromStream(xStream:TStream); class Function CreateShadow(x,y:Double): TFigure;override; Function ShadowKeyStroke(var ClickIndex,KeyCode:Integer;Shift:TShiftState; var Fnished:Boolean):Boolean;override; Function ShadowClick(ClickIndex: Integer; x,y: Double): Boolean;override; Function ShadowTrace(ClickIndex: Integer; x,y: Double):Boolean;override; Function CreateModification: TFigure;override; class function CreateFromShadow(aOwner: TComponent;LHandle: LongInt;Shadow:TFigure): TFigure;override; Function TraceModification(CadControl: Pointer;mp:TModPoint;TraceFigure:TFigure;x,y:double;Shift: TShiftState):boolean;override; Function EndModification(CadControl: Pointer;mp:TModPoint;TraceFigure:TFigure;x,y:double;Shift: TShiftState):boolean;override; Procedure SelectPoint(ModPoint:TModpoint);override; Procedure DeSelectPoint(ModPoint:TModpoint);override; Procedure DrawSelectionPoints(DEngine: TPCDrawEngine;isGrayed:Boolean);override; Procedure Move(deltax, deltay: double);override; Procedure Rotate(aAngle: double; cPoint: TDoublePoint);override; Procedure Mirror(Point1,Point2: TDoublePoint);override; Procedure scale(percentx,percenty: double; rPoint: TDoublepoint);override; Procedure GetVectorObjects(Objects:Tlist;BaseP: TDoublePoint);override; Procedure VerifyZeroPoints(orgV,orgH:Byte);override; Destructor Destroy;override; Function BreakByPoint(p:TdoublePoint;var Figures:TList):boolean;override; Function GetLinearInterSections(p1,p2:TDoublePoint; var pArr:TDoublePointArr):Boolean;override; Function Knife(p1,p2:TdoublePoint;Figures:TList):Boolean;override; Function SelfIntersecting:Boolean; Function Offset(Thick:Double):TFigure;override; Function DuplicateAsBezier:TFigure; override; Function GetClassName:String;override; Class Function InsideSelection:Boolean;override; Procedure CreateDimLines;override; Procedure ClearDimLines;override; Procedure SetSegmentDimension(SegNbr:Integer;Vis:Boolean); Function GetSegmentDimension(SegNbr:Integer):Boolean; Procedure ToggleSegmentDimension(SegNbr:Integer); Function GetLength:Double;override; Function GetArea:Double;override; Procedure SimplfyPoints; Property Closed: Boolean read fClosed write setClosed; end; TFreeHand = class(TPolyline) Function ShadowClick(ClickIndex: Integer; x,y: Double): Boolean;override; Function ShadowTrace(ClickIndex: Integer; x,y: Double):Boolean;override; class Function CreateShadow(x,y:Double): TFigure;override; Function GetClassName:String;override; end; TPointSet = class(TPolyline) Procedure Draw(Dengine:TPCDrawEngine;isGrayed:Boolean);override; class Function CreateShadow(x,y:Double): TFigure;override; Function GetClassName:String;override; class function CreateFromShadow(aOwner: TComponent;LHandle: LongInt;Shadow:TFigure): TFigure;override; Function CreateModification: TFigure;override; Procedure DrawSelectionPoints(DEngine: TPCDrawEngine;isGrayed:Boolean);override; end; TAngleLine = class(TPolyline) Function GetAngle:Double; Function ShadowClick(ClickIndex: Integer; x,y: Double): Boolean;override; Procedure Draw(Dengine:TPCDrawEngine;isGrayed:Boolean);override; class Function CreateShadow(x,y:Double): TFigure;override; Function GetClassName:String;override; class function CreateFromShadow(aOwner: TComponent;LHandle: LongInt;Shadow:TFigure): TFigure;override; Function CreateModification: TFigure;override; Procedure DrawSelectionPoints(DEngine: TPCDrawEngine;isGrayed:Boolean);override; end; TUserPolyline = class(TPolyline) procedure draw(DEngine: TPCDrawEngine; isGrayed:Boolean);override; Function duplicate:TFigure; override; Function isPointIn(x,y: double): boolean;override; class function CreateFromShadow(aOwner: TComponent;LHandle: Integer; Shadow: TFigure): TFigure;override; Function GetClassName:String;override; end; TEllipse = class(TFigure) alen,blen : double; constructor create( cX,cY,len1,len2,aAngle: Double;w,s,c,abrs,abrc:integer; LHandle:LongInt; aDrawStyle: PCTypesUtils.TDrawStyle;aOwner: TComponent); //Constructor create3P( cX,cY,x1,y1,x2,y2: Double; w,s,c,abrs,abrc:integer; // LHandle:LongInt; aDrawStyle: TDrawStyle;aOwner: TComponent); Procedure Initialize;override; procedure draw(DEngine: TPCDrawEngine; isGrayed:Boolean);override; //procedure getModPoints(ModList: TList);override; procedure getModPoints(ModList: TMyList);override; function isPointIn(x,y:Double): boolean;override; procedure getbounds(var figMaxX,figMaxY,figMinX,figMinY: Double);override; Function duplicate:TFigure; override; Procedure Scale(percentx,percenty: Double; rPoint: TDoublePoint);override; Procedure Move(deltax, deltay: Double);override; Procedure Rotate(aAngle: Double; cPoint: TDoublePoint);override; Procedure Mirror(Point1,Point2: TDoublePoint);override; Procedure WriteToStream(Stream:TStream);override; Procedure SetPropertyFromStream(xCode:Byte;data:pointer;size:integer);override; Procedure SetSpecialPropertiesFromStream(Stream: TStream);override; Function ShadowClick(ClickIndex:Integer;x,y: double):Boolean;override; Function ShadowTrace(ClickIndex:Integer;x,y: double):Boolean;override; Function TraceModification(CadControl: Pointer;mp:TModPoint;TraceFigure:TFigure;x,y:double;Shift: TShiftState):boolean;override; Function EndModification(CadControl: Pointer;mp:TModPoint;TraceFigure:TFigure;x,y:double;Shift: TShiftState):boolean;override; class function CreateFromShadow(aOwner: TComponent;LHandle: LongInt;Shadow:TFigure): TFigure;override; class Function CreateShadow(x,y:double): TFigure;override; Function CreateModification: TFigure;override; //Procedure RefreshBounds; Procedure VerifyZeroPoints(orgV,orgH:Byte);override; Procedure GetVectorObjects(Objects:Tlist;BaseP: TDoublePoint);override; Function DuplicateAsBezier:TFigure;override; Function BreakByPoint(p:TdoublePoint;var Figures:TList):boolean;override; Function GetLinearInterSections(p1,p2:TDoublePoint; var pArr:TDoublePointArr):Boolean;override; Function Offset(Thick:Double):TFigure;override; Function GetClassName:String;override; Function GetLength:Double;override; Function GetArea:Double;override; end; TUserEllipse = class(TEllipse) procedure draw(DEngine: TPCDrawEngine; isGrayed:Boolean);override; Function duplicate:TFigure; override; Function isPointIn(x,y: double): boolean;override; class function CreateFromShadow(aOwner: TComponent;LHandle: Integer; Shadow: TFigure): TFigure;override; Function GetClassName:String;override; end; TCircle = class(TFigure) Hatched: Boolean; constructor create( cX,cY,rad: Double;w,s,c,abrs,abrc:integer; LHandle:LongInt; aDrawStyle: PCTypesUtils.TDrawStyle;aOwner: TComponent); Procedure Initialize;override; Function Edit: Boolean;override; procedure draw(DEngine: TPCDrawEngine; isGrayed:Boolean);override; Procedure DrawFigureGuides(DEngine: TPCDrawEngine);override; // procedure getModPoints(ModList: TList);override; procedure getModPoints(ModList: TMyList);override; function isPointIn(x,y:Double): boolean;override; procedure getbounds(var figMaxX,figMaxY,figMinX,figMinY: Double);override; Function duplicate:TFigure; override; Procedure scale(percentx,percenty: double; rPoint: Tdoublepoint);override; Procedure WriteToStream(Stream:TStream);override; Procedure SetPropertyFromStream(xCode:Byte;data:pointer;size:integer);override; Function ShadowClick(ClickIndex:Integer;x,y: Double):Boolean;override; Function ShadowTrace(ClickIndex:Integer;x,y: Double):Boolean;override; Function TraceModification(CadControl: Pointer;mp:TModPoint;TraceFigure:TFigure;x,y:Double;Shift: TShiftState):boolean;override; Function EndModification(CadControl: Pointer;mp:TModPoint;TraceFigure:TFigure;x,y:Double;Shift: TShiftState):boolean;override; class function CreateFromShadow(aOwner: TComponent;LHandle: LongInt;Shadow:TFigure): TFigure;override; class function ShadowType:TShadowType;override; Procedure GetVectorObjects(Objects:Tlist;BaseP: TDoublePoint);override; Function DuplicateAsBezier:TFigure;override; Function GetLinearInterSections(p1,p2:TDoublePoint; var pArr:TDoublePointArr):Boolean;override; Function BreakByPoint(p:TdoublePoint;var Figures:TList):boolean;override; Function Offset(Thick:Double):TFigure;override; Function GetClassName:String;override; Procedure CreateDimLines;override; Function GetLength:Double;override; Function GetArea:Double;override; end; // Tolik -- 19/08/2017 -- TOverLappedCircle = class(TFigure) Hatched: Boolean; CutRadius: Double; constructor create(cX,cY,cX1, cY1, rad, cutRad: Double;w,s,c,abrs,abrc:integer; LHandle:LongInt; aDrawStyle: PCTypesUtils.TDrawStyle;aOwner: TComponent); Procedure Initialize;override; procedure draw(DEngine: TPCDrawEngine; isGrayed:Boolean);override; //Procedure WriteToStream(Stream:TStream);override; // Procedure SetPropertyFromStream(xCode:Byte;data:pointer;size:integer);override; // Function GetClassName:String;override; { Function Edit: Boolean;override; Procedure DrawFigureGuides(DEngine: TPCDrawEngine);override; procedure getModPoints(ModList: TList);override; function isPointIn(x,y:Double): boolean;override; procedure getbounds(var figMaxX,figMaxY,figMinX,figMinY: Double);override; Function duplicate:TFigure; override; Procedure scale(percentx,percenty: double; rPoint: Tdoublepoint);override; Function ShadowClick(ClickIndex:Integer;x,y: Double):Boolean;override; Function ShadowTrace(ClickIndex:Integer;x,y: Double):Boolean;override; Function TraceModification(CadControl: Pointer;mp:TModPoint;TraceFigure:TFigure;x,y:Double;Shift: TShiftState):boolean;override; Function EndModification(CadControl: Pointer;mp:TModPoint;TraceFigure:TFigure;x,y:Double;Shift: TShiftState):boolean;override; class function CreateFromShadow(aOwner: TComponent;LHandle: LongInt;Shadow:TFigure): TFigure;override; class function ShadowType:TShadowType;override; Procedure GetVectorObjects(Objects:Tlist;BaseP: TDoublePoint);override; Function DuplicateAsBezier:TFigure;override; Function GetLinearInterSections(p1,p2:TDoublePoint; var pArr:TDoublePointArr):Boolean;override; Function BreakByPoint(p:TdoublePoint;var Figures:TList):boolean;override; Function Offset(Thick:Double):TFigure;override; Procedure CreateDimLines;override; Function GetLength:Double;override; Function GetArea:Double;override; } end; TOverLappedEllipse = class(TFigure) Hatched: Boolean; Radius1, CutRadius1, CutRadius2: Double; constructor create(cX, cY, cX1, cY1, Rad1, Rad2, CutRad1, CutRad2: Double;w,s,c,abrs,abrc:integer; LHandle: LongInt; aDrawStyle: PCTypesUtils.TDrawStyle; aOwner: TComponent); Procedure Initialize;override; procedure draw(DEngine: TPCDrawEngine; isGrayed:Boolean);override; procedure getbounds(var figMaxX,figMaxY,figMinX,figMinY: double);override; Procedure WriteToStream(Stream:TStream);override; Procedure SetPropertyFromStream(xCode:Byte;data:pointer;size:integer);override; Function GetClassName:String;override; end; // TUserCircle = class(TCircle) procedure draw(DEngine: TPCDrawEngine; isGrayed:Boolean);override; Function duplicate:TFigure; override; Function isPointIn(x,y: double): boolean;override; class function CreateFromShadow(aOwner: TComponent;LHandle: Integer; Shadow: TFigure): TFigure;override; Function GetClassName:String;override; end; TArc = class(TFigure) ArcStyle: TArcStyle; SAngle,FAngle:Double; constructor create( cx,cy,rad,a1,a2:Double;w,s,c,abrs,abrc,aArcStyle:integer; LHandle:LongInt; aDrawStyle: PCTypesUtils.TDrawStyle;aOwner: TComponent); Function GetStartPoint:TDoublePoint;override; Function GetEndPoint:TDoublePoint;override; Procedure Initialize;override; procedure draw(DEngine: TPCDrawEngine; isGrayed:Boolean);override; //procedure getModPoints(ModList: TList);override; procedure getModPoints(ModList: TMyList);override; function isPointIn(x,y:Double): boolean;override; function isAngleIn(a:Double): boolean; procedure getbounds(var figMaxX,figMaxY,figMinX,figMinY: Double);override; Function duplicate:TFigure; override; Function DuplicateAsBezier:TFigure;override; Procedure Invert; Procedure WriteToStream(Stream:TStream);override; Procedure Mirror(Point1,Point2: TDoublePoint);override; Procedure ArrangeStyle(val: TArcStyle); Procedure UpdateMenu(var popMenu: TPopUpMenu;var sIndex:Integer);override; Procedure MenuClicked(CommandId:integer);override; Procedure SetPropertyFromStream(xCode:Byte;data:pointer;size:integer);override; Function ShadowClick(ClickIndex:Integer; x,y: Double):Boolean;override; Function ShadowTrace(ClickIndex:Integer; x,y: Double):Boolean;override; Function TraceModification(CadControl: Pointer;mp:TModPoint;TraceFigure:TFigure;x,y:Double;Shift: TShiftState):boolean;override; Function EndModification(CadControl: Pointer;mp:TModPoint;TraceFigure:TFigure;x,y:Double;Shift: TShiftState):boolean;override; class function CreateFromShadow(aOwner: TComponent;LHandle: LongInt;Shadow:TFigure): TFigure;override; class Function CreateShadow(x,y:Double): TFigure;override; Function CreateModification: TFigure;override; Procedure VerifyZeroPoints(orgV,orgH:Byte);override; Function BreakByPoint(p:TdoublePoint;var Figures:TList):boolean;override; Function GetLinearInterSections(p1,p2:TDoublePoint; var pArr:TDoublePointArr):Boolean;override; Function Offset(Thick:Double):TFigure;override; Function GetClassName:String;override; Procedure CreateDimLines;override; Procedure Rotate(aAngle: Double; cPoint: TDoublePoint);override; Procedure Scale(percentx,percenty: Double; rPoint: TDoublePoint);override; end; // Tolik -- 23/05/2017 -- TPie = class(TFigure) public FillColor: Integer; SAngle,FAngle:Double; GuideLen: Double; DrawGuides: Boolean; DLabel: String; Prefix: String; Suffix: String; AutoText: Boolean; TextFont: String; TextHeight: Double; TextBold: Boolean; TextItalic: Boolean; TextColor: TColor; LStyle: TArcDimLabelStyle; CutStyle : TPieCutStyle; // cut style from center point CutRadius: double; Function Edit:Boolean;override; Procedure Draw(DEngine: TPCDrawEngine; isGrayed:Boolean);override; function IsPointIn(x,y: Double): boolean;override; // Function Duplicate:TFigure; override; Procedure WriteToStream(Stream:TStream);override; Procedure SetPropertyFromStream(xCode:Byte;data:pointer;size:integer);override; class function CreateFromShadow(aOwner:TComponent;LHandle: LongInt;Shadow:TFigure): TFigure;override; class Function CreateShadow(x,y:Double): TFigure;override; Function ShadowClick(ClickIndex:Integer;x,y:Double):Boolean;override; Function ShadowTrace(ClickIndex:Integer;x,y:Double):Boolean;override; Function CreateModification: TFigure;override; Function GetMiddleAngle: Double; Function TraceModification(CadControl: Pointer;mp:TModPoint;TraceFigure:TFigure;x,y:double;Shift: TShiftState):boolean;override; Function EndModification(CadControl: Pointer;mp:TModPoint;TraceFigure:TFigure;x,y:double;Shift: TShiftState):boolean;override; Procedure UpdateMenu(var popMenu: TPopUpMenu;var sIndex:Integer);override; Procedure MenuClicked(CommandId:integer);override; // Function ModifyTextAndFont(mm: TModifyMode; valueI:Double; valueS: string; // valueSt: TFontStyles;ValueB:Boolean):Boolean;override; function GetAngle: Double; //06.10.2011 function SetAngle(AValue: Double): Boolean; //06.10.2011 procedure Scale(percentx, percenty: Double; rPoint: TDoublePoint); override; //Constructor create( cx,cy,rad,a1,a2:Double;w,s,c,abrs,abrc: Integer; // LHandle:LongInt; aDrawStyle: TDrawStyle;aOwner: TComponent); Constructor create(cx,cy,rad,a1,a2:Double;w,s,c,abrs,abrc: Integer; LHandle:LongInt; aDrawStyle: PCTypesUtils.TDrawStyle;aOwner: TComponent; aCutStyle: TPieCutStyle; aCutRadius: Double = 0); Destructor Destroy;override; Function GetClassName:String;override; Procedure Initialize;override; procedure getbounds(var figMaxX,figMaxY,figMinX,figMinY: double);override; //procedure GetModPoints(ModList: TList);override; procedure getModPoints(ModList: TMyList);override; function GetCutStyle: TPieCutStyle; Procedure Rotate(aAngle: Double; cPoint: TDoublePoint);override; Procedure Mirror(Point1,Point2: TDoublePoint);override; //class Function CreateFromShadow(aOwner: TComponent; // LHandle: Integer; Shadow: TFigure): TFigure;overload; end; // TElpArc = class(TFigure) ArcStyle: TArcStyle; SAngle,FAngle:Double; ALen,BLen: Double; constructor create(cx, cy, radA, radB, a1, a2: Double; aAngle: Double; w,s,c,abrs,abrc,aArcStyle:integer; LHandle:LongInt; aDrawStyle: PCTypesUtils.TDrawStyle;aOwner: TComponent); Function GetStartPoint:TDoublePoint;override; Function GetEndPoint:TDoublePoint;override; Procedure Initialize;override; //procedure getModPoints(ModList: TList);override; procedure getModPoints(ModList: TMyList);override; function isPointIn(x,y:Double): boolean;override; procedure getbounds(var figMaxX,figMaxY,figMinX,figMinY: Double);override; Function duplicate:TFigure; override; Function DuplicateAsBezier:TFigure;override; Procedure Invert; Procedure WriteToStream(Stream:TStream);override; Procedure Mirror(Point1,Point2: TDoublePoint);override; Procedure ArrangeStyle(val: TArcStyle); Procedure UpdateMenu(var popMenu: TPopUpMenu;var sIndex:Integer);override; Procedure MenuClicked(CommandId:integer);override; Procedure SetPropertyFromStream(xCode:Byte;data:pointer;size:integer);override; Function ShadowClick(ClickIndex:Integer; x,y: Double):Boolean;override; Function ShadowTrace(ClickIndex:Integer; x,y: Double):Boolean;override; Function TraceModification(CadControl: Pointer;mp:TModPoint;TraceFigure:TFigure;x,y:Double;Shift: TShiftState):boolean;override; Function EndModification(CadControl: Pointer;mp:TModPoint;TraceFigure:TFigure;x,y:Double;Shift: TShiftState):boolean;override; class function CreateFromShadow(aOwner: TComponent;LHandle: LongInt;Shadow:TFigure): TFigure;override; class Function CreateShadow(x,y:Double): TFigure;override; Function CreateModification: TFigure;override; Procedure VerifyZeroPoints(orgV,orgH:Byte);override; Function BreakByPoint(p:TdoublePoint;var Figures:TList):boolean;override; Function GetLinearInterSections(p1,p2:TDoublePoint; var pArr:TDoublePointArr):Boolean;override; function isAngleIn(a:Double): boolean; Function Offset(Thick:Double):TFigure;override; Function GetClassName:String;override; procedure draw(DEngine: TPCDrawEngine; isGrayed:Boolean);override; Procedure Rotate(aAngle: Double; cPoint: TDoublePoint);override; Procedure Scale(percentx,percenty: Double; rPoint: TDoublepoint);override; end; TUserArc = class(TArc) procedure draw(DEngine: TPCDrawEngine; isGrayed:Boolean);override; Function duplicate:TFigure; override; Function isPointIn(x,y: double): boolean;override; class function CreateFromShadow(aOwner: TComponent;LHandle: Integer; Shadow: TFigure): TFigure;override; Function GetClassName:String;override; end; TRectangle = class(TFigure) DimLeft:Boolean; DimRight: Boolean; DimTop: Boolean; DimBottom:Boolean; FDrawPoints: Pointer; constructor create(aX1,aY1,aX2,aY2:Double;w,s,c,abrs,abrc:integer; LHandle:LongInt; aDrawStyle: PCTypesUtils.TDrawStyle;aOwner: TComponent); Procedure Initialize;override; procedure draw(DEngine: TPCDrawEngine; isGrayed:Boolean);override; //procedure getModPoints(ModList: TList);override; procedure getModPoints(ModList: TMyList);override; function isPointIn(x,y:Double): boolean;override; Procedure getbounds(var figMaxX,figMaxY,figMinX,figMinY: Double);override; Function duplicate:TFigure; override; Procedure WriteToStream(Stream:TStream);override; Procedure SetPropertyFromStream(xCode:Byte;data:pointer;size:integer);override; class function CreateFromShadow(aOwner: TComponent;LHandle: Integer; Shadow: TFigure): TFigure;override; class Function ShadowType:TShadowType;override; Function CreateModification: TFigure;override; Function ShadowClick(ClickIndex:Integer;x,y:Double):Boolean;override; Function ShadowTrace(ClickIndex:Integer;x,y:Double):Boolean;override; Function TraceModification(CadControl: Pointer;mp:TModPoint;TraceFigure:TFigure;x,y:Double;Shift: TShiftState):boolean;override; Function EndModification(CadControl: Pointer;mp:TModPoint;TraceFigure:TFigure;x,y:Double;Shift: TShiftState):boolean;override; Procedure GetVectorObjects(Objects:Tlist;BaseP: TDoublePoint);override; Function DuplicateAsBezier:TFigure;override; Function BreakByPoint(p:TdoublePoint;var Figures:TList):boolean;override; Function GetLinearInterSections(p1,p2:TDoublePoint; var pArr:TDoublePointArr):Boolean;override; Function Offset(Thick:Double):TFigure;override; Function GetClassName:String;override; Procedure CreateDimLines;override; //Function Edit: Boolean;override; Function GetLength:Double;override; Function GetArea:Double;override; Destructor Destroy;override; //31.10.2011 end; TUserRectangle = class(TRectangle) procedure draw(DEngine: TPCDrawEngine; isGrayed:Boolean);override; Function duplicate:TFigure; override; Function isPointIn(x,y: double): boolean;override; class function CreateFromShadow(aOwner: TComponent;LHandle: Integer; Shadow: TFigure): TFigure;override; Function GetClassName:String;override; end; TRichText = class(TRectangle) re: TRichEdit98; ttMetaFile: TMetafile; frm: TfrmInput; ShowGuide: Boolean; Lines: TStringList; TagParse: Boolean; FontSize: Integer; FontName: String; FontStyle: TFontStyles; constructor create(aX1,aY1,aX2,aY2: Double; w, s, c, abrs, abrc: integer; LHandle: LongInt; aDrawStyle: PCTypesUtils.TDrawStyle; aOwner: TComponent; AText: Boolean=true); constructor createEx(aX1,aY1,aX2,aY2:Double;w,s,c,abrs,abrc:integer; Lines:String; FontName:String; FontSize: Integer; LHandle:LongInt; aDrawStyle: PCTypesUtils.TDrawStyle; aOwner: TComponent); Procedure Initialize;override; procedure draw(DEngine: TPCDrawEngine; isGrayed:Boolean);override; Procedure WriteToStream(Stream:TStream);override; Function edit:Boolean;override; class function CreateFromShadow(aOwner: TComponent;LHandle: Integer; Shadow: TFigure): TFigure;override; function isPointIn(x,y:Double): boolean;override; Procedure rotate(aAngle: Double; cPoint: TDoublePoint);override; Procedure mirror(Point1,Point2: TDoublePoint);override; Destructor Destroy;override; procedure SetPropertyFromStream(xCode:Byte;data:pointer;size:integer);override; Function duplicate:TFigure; override; Procedure DrawFigureGuides(DEngine: TPCDrawEngine);override; class function ShadowType: TShadowType;override; Function GetClassName:String;override; Procedure CheckAndChangeFont; end; TRichText_my = class(TRichText) //Procedure Initialize;override; end; TOLEObject = class(TRectangle) ole: TMFSOle; MetaFile: TMetafile; constructor create(aX1,aY1,aX2,aY2:Double; w,s,c,abrs,abrc:integer; LHandle:LongInt; aDrawStyle:PCTypesUtils.TDrawStyle;aOwner: TComponent); Procedure Initialize;override; procedure draw(DEngine: TPCDrawEngine; isGrayed:Boolean);override; Function edit:Boolean;override; class function CreateFromShadow(aOwner: TComponent;LHandle: LongInt;Shadow:TFigure): TFigure;override; function isPointIn(x,y:Double): boolean;override; Procedure rotate(aAngle: Double; cPoint: TDoublePoint);override; Procedure mirror(Point1,Point2: TDoublePoint);override; Destructor Destroy;override; Procedure SetPropertyFromStream(xCode:Byte;data:pointer;size:integer);override; Procedure WriteToStream(Stream:TStream);override; Function duplicate:TFigure; override; Procedure DrawFigureGuides(DEngine: TPCDrawEngine);override; class Function ShadowType:TShadowType;override; Function GetClassName:String;override; end; TWMFObject = class(TFigure) PictureName: String; MetaFile: TMetafile; constructor create(x,y: Double;fName:string; LHandle:LongInt; aDrawStyle: PCTypesUtils.TDrawStyle;aOwner: TComponent); constructor createEx(x,y: Double;mf:Tmetafile; LHandle:LongInt; aDrawStyle: PCTypesUtils.TDrawStyle;aOwner: TComponent); Procedure Initialize;override; procedure draw(DEngine: TPCDrawEngine; isGrayed:Boolean);override; function isPointIn(x,y:Double): boolean;override; Procedure Mirror(Point1,Point2: TDoublePoint);override; Procedure Rotate(aAngle: Double; cPoint: TDoublePoint);override; Destructor Destroy;override; Procedure SetPropertyFromStream(xCode:Byte;data:pointer;size:integer);override; Procedure WriteToStream(Stream:TStream);override; Function duplicate:TFigure; override; class Function ShadowType:TShadowType;override; class function CreateFromShadow(aOwner: TComponent;LHandle: LongInt; Shadow:TFigure): TFigure;override; Class Function IsOneClick:Boolean;override; Procedure UpdateMenu(var PopMenu: TPopUpMenu;var sIndex:integer);override; Procedure MenuClicked(CommandId:integer);override; Procedure CloneAsEditObjects; Function GetClassName:String;override; end; TMathGraph = class(TRectangle) Source: String; UnitSize : Double; BorderColor: Integer; BorderStyle: Integer; BorderWidth: Integer; AxisColor: Integer; AxisStyle: Integer; AxisWidth: Integer; OrgCenter: Boolean; ScaleStyle:TMGScaleStyle; PolarScale: Boolean; ScaleColor: Integer; NumStep : Integer; constructor create(aX1,aY1,aX2,aY2:Double;w,s,c,abrs,abrc:integer; LHandle:LongInt; aDrawStyle: PCTypesUtils.TDrawStyle;aOwner: TComponent); Procedure Initialize;override; procedure draw(DEngine: TPCDrawEngine; isGrayed:Boolean);override; Procedure WriteToStream(Stream:TStream);override; Function edit:Boolean;override; function isPointIn(x,y:Double): boolean;override; Procedure rotate(aAngle: Double; cPoint: TDoublePoint);override; Procedure mirror(Point1,Point2: TDoublePoint);override; Destructor Destroy;override; procedure SetPropertyFromStream(xCode:Byte;data:pointer;size:integer);override; Function duplicate:TFigure; override; Procedure DrawFigureGuides(DEngine: TPCDrawEngine);override; //Procedure GetModPoints(ModList: TList);override; procedure getModPoints(ModList: TMyList);override; Procedure UpdateMenu(var popMenu: TPopUpMenu;var sIndex:Integer);override; Procedure MenuClicked(CommandId:integer);override; Procedure SetOriginToCenter; Procedure ZoomIn; Procedure ZoomOut; Function CreateModification: TFigure;override; class function CreateFromShadow(aOwner: TComponent;LHandle: LongInt;Shadow:TFigure): TFigure;override; Function TraceModification(CadControl: Pointer;mp:TModPoint;TraceFigure:TFigure;x,y:Double;Shift: TShiftState):boolean;override; class Function ShadowType:TShadowType;override; Function GetClassName:String;override; end; TBMPObject = class (TFigure) Picture : TBitmap; Image : TBitmap; PictureName : string; VertFlipped : Boolean; HorzFlipped : Boolean; fTrans : Boolean; Dpm : Real; ClipFigure: TFigure; ClpRgn: HRGN; Skewed: Boolean; SelMode: Byte; // 0: Select Bitmap 1: Select ClipFigure 2: Select Group Tiled: Boolean; // Tolik -- ImageEdited: Boolean; // для отрисовки, чтобы, если не было измениений, не отрисовывать поворот картинки каждый раз (не будет так тормозить) // Procedure CreateMWPath(x,y:Double;Tol:Double;var DPoints:TDoublePointArr;var closed:Boolean); procedure setTrans(value: Boolean); // Tolik -- 10/03/2016 -- constructor create( x,y: Double; afName: string; LHandle:LongInt; aDrawStyle: PCTypesUtils.TDrawStyle;aOwner: TComponent; JPEGBounds: Boolean = False); (* constructor create( x,y: Double; afName: string; LHandle:LongInt; aDrawStyle: TDrawStyle;aOwner: TComponent);*) // constructor createEx( x,y: Double; aBitmap: TBitmap; LHandle:LongInt;aDrawStyle:PCTypesUtils.TDrawStyle;aOwner: TComponent); constructor createExRes(x,y: Double;BmpRes:Integer;aBitmap: TBitmap; LHandle:LongInt;aDrawStyle:PCTypesUtils.TDrawStyle;aOwner: TComponent); Procedure Initialize;override; Procedure RelocatePoints; procedure draw(DEngine: TPCDrawEngine; isGrayed:Boolean);override; Function Edit: Boolean;override; //procedure getModPoints(ModList: TList);override; procedure getModPoints(ModList: TMyList);override; function isPointIn(x,y:Double): boolean;override; Function DoMagicWand(x,y:Double):Tfigure; Procedure mirror(Point1,Point2: TDoublePoint);override; procedure scale(percentx,percenty: Double; rPoint: TDoublepoint);override; procedure move(deltax, deltay: Double);override; Procedure rotate(aAngle: Double; cPoint: TDoublePoint);override; procedure getbounds(var figMaxX,figMaxY,figMinX,figMinY: Double);override; Function duplicate:TFigure; override; Procedure FlipHorz; Procedure FlipVert; Procedure UpdateMenu(var PopMenu: TPopUpMenu;var sIndex:integer);override; Procedure MenuClicked(CommandId:integer);override; Procedure WriteToStream(Stream:TStream);override; Procedure SetPropertyFromStream(xCode:Byte;data:pointer;size:integer);override; function CreateModification: TFigure;override; Function TraceModification(CadControl: Pointer;mp:TModPoint;TraceFigure:TFigure;x,y:Double;Shift: TShiftState):boolean;override; Function TraceModificationClipped(CadControl: Pointer;mp:TModPoint;TraceFigure:TFigure;x,y:Double;Shift: TShiftState):boolean; Function EndModification(CadControl: Pointer;mp:TModPoint;TraceFigure:TFigure;x,y:Double;Shift: TShiftState):boolean;override; Destructor Destroy;override; property Transparent: Boolean read fTrans write setTrans; Procedure Select;override; Procedure Deselect;override; Procedure drawselectionpoints(DEngine: TPCDrawEngine;isGrayed:Boolean);override; class function CreateFromShadow(aOwner: TComponent;LHandle: LongInt;Shadow:TFigure): TFigure;override; class Function ShadowType:TShadowType;override; class Function CreateShadow(x,y:Double): TFigure;override; Function ShadowClick(ClickIndex:Integer;x,y:Double):Boolean;override; Procedure SkewShape; Function GetClassName:String;override; end; TTextPanel = class (TRectangle) Text: String; Alignment: TTextAlign; Height: Double; CSpace: Double; Font : TFont; constructor create(xp1,xp2: TDoublePoint; LHandle:LongInt; aDrawStyle: PCTypesUtils.TDrawStyle;aOwner: TComponent); Destructor Destroy;override; Procedure Initialize;override; Function Edit: Boolean;override; procedure draw(DEngine: TPCDrawEngine; isGrayed:Boolean);override; Function ModifyTextAndFont(mm: TModifyMode; valueI:Double; valueS: string; valueSt: TFontStyles;ValueB:Boolean):Boolean;override; procedure scale(percentx,percenty: Double; rPoint: TDoublepoint);override; class function CreateFromShadow(aOwner: TComponent;LHandle: Integer; Shadow: TFigure): TFigure;override; function isPointIn(x,y:Double): boolean;override; Procedure WriteToStream(Stream:TStream);override; procedure SetPropertyFromStream(xCode:Byte;data:pointer;size:integer);override; Function duplicate:TFigure; override; Procedure DrawFigureGuides(DEngine: TPCDrawEngine);override; class function ShadowType: TShadowType;override; Function GetClassName:String;override; Procedure UpdateMenu(var popMenu: TPopUpMenu;var sIndex:Integer);override; Procedure MenuClicked(CommandId:integer);override; Procedure SetField(FName,FValue:String); end; TText = class(TFigure) Text: string; Font: TFont; Height: Double; CWidth: double; CSpace: Double; fKeepA: Boolean; TextLength,TextHeight: Double; BoxWidth: Double; // Tolik 18/10/2019 -- ширина контейнера, в котором находится текст Outlined: Boolean; constructor Create( aX1,aY1,h,w: double;atext: string; FontName:String; FontCharset: Byte;aColor:Integer;LHandle:LongInt; aDrawStyle: TDrawStyle;aOwner: TComponent); Class function CreateCentered(aX1,aY1,h,w: double;atext: string; FontName:String; FontCharset: Byte;aColor:Integer;LHandle:LongInt; aDrawStyle: TDrawStyle;aOwner: TComponent):TText; Procedure Initialize;override; procedure draw(DEngine: TPCDrawEngine; isGrayed:Boolean);override; Function Edit: Boolean;override; //procedure getModPoints(ModList: TList);override; procedure getModPoints(ModList: TMyList);override; function isPointIn(x,y:Double): boolean;override; procedure getbounds(var figMaxX,figMaxY,figMinX,figMinY:Double);override; procedure setRegionPoints; Function duplicate:TFigure; override; Procedure mirror(Point1,Point2: TDoublePoint);override; Procedure ValidatePoints; procedure scale(percentx,percenty: Double; rPoint: TDoublepoint);override; Procedure rotate(aAngle: Double; cPoint: TDoublePoint);override; Procedure CalculateAngle; Procedure WriteToStream(Stream:TStream);override; Function ModifyTextAndFont(mm: TModifyMode; valueI:Double; valueS: string; valueSt: TFontStyles;ValueB:Boolean):Boolean;override; Procedure SetPropertyFromStream(xCode:Byte;data:pointer;size:integer);override; class function CreateFromShadow(aOwner: TComponent;LHandle: LongInt;Shadow:TFigure): TFigure;override; class Function CreateShadow(x,y:Double): TFigure;override; Function ShadowClick(ClickIndex:Integer;x,y:Double):Boolean;override; Destructor Destroy;override; class Function ShadowType:TShadowType;override; Function EndModification(CadControl: Pointer;mp:TModPoint;TraceFigure:TFigure; x,y:Double;Shift: TShiftState):boolean;override; Procedure UpdateMenu(var popMenu: TPopUpMenu;var sIndex:Integer);override; Procedure MenuClicked(CommandId:integer);override; Function DuplicateAsBezier:TFigure; override; Function GetClassName:String;override; Procedure SetField(FName,FValue:String); end; TDimLine = class(TFigure) DLabel: String; Prefix: String; Suffix: String; AutoText: Boolean; TextPos : TDimTextPos; TextFont: String; TextHeight: Double; TextBold: Boolean; TextItalic: Boolean; TextColor: TColor; EndType: TEndType; MapScale: Double; Procedure Initialize;override; Function Edit:Boolean;override; constructor Create(LHandle: LongInt;aDrawStyle:TDrawStyle;aOwner: TComponent); //procedure GetModPoints(ModList: TList);override; procedure getModPoints(ModList: TMyList);override; function IsPointIn(x,y:Double): boolean;override; procedure Getbounds(var figMaxX,figMaxY,figMinX,figMinY:Double);override; Function Duplicate:TFigure; override; Procedure WriteToStream(Stream:TStream);override; Procedure SetPropertyFromStream(xCode:Byte;data:pointer;size:integer);override; class function CreateFromShadow(aOwner:TComponent;LHandle: LongInt;Shadow:TFigure): TFigure;override; class Function CreateShadow(x,y:Double): TFigure;override; Function ShadowClick(ClickIndex:Integer; x,y:Double):Boolean;override; Function ShadowTrace(ClickIndex:Integer;x,y:Double):Boolean;override; Function ModifyTextAndFont(mm: TModifyMode; valueI:Double; valueS: string; valueSt: TFontStyles;ValueB:Boolean):Boolean;override; // Tolik 04/03/2020 Function DefineHStyle(currStyle: THDimLabelStyle): THDimLabelStyle; // переопределить положение текста, если длина текста превышает длину самой линии Function DefineVStyle(currStyle: TVDimLabelStyle): TVDimLabelStyle; // переопределить положение текста, если длина текста превышает длину самой линии // end; THDimLine = class(TDimLine) caption: string; LStyle: THDimLabelStyle; Function Edit:Boolean;override; Procedure Draw(DEngine: TPCDrawEngine; isGrayed:Boolean);override; function IsPointIn(x,y:Double): boolean;override; Procedure Getbounds(var figMaxX,figMaxY,figMinX,figMinY: Double);override; Function Duplicate:TFigure; override; Procedure WriteToStream(Stream:TStream);override; Procedure SetPropertyFromStream(xCode:Byte;data:pointer;size:integer);override; class function CreateFromShadow(aOwner:TComponent;LHandle: LongInt;Shadow:TFigure): TFigure;override; class Function CreateShadow(x,y:Double): TFigure;override; Function ShadowClick(ClickIndex:Integer;x,y:Double):Boolean;override; Function ShadowTrace(ClickIndex:Integer;x,y:Double):Boolean;override; Function CreateModification: TFigure;override; Function TraceModification(CadControl: Pointer;mp:TModPoint;TraceFigure:TFigure;x,y:Double;Shift: TShiftState):boolean;override; Function EndModification(CadControl: Pointer;mp:TModPoint;TraceFigure:TFigure;x,y:Double;Shift: TShiftState):boolean;override; Procedure UpdateMenu(var popMenu: TPopUpMenu;var sIndex:Integer);override; Procedure MenuClicked(CommandId:integer);override; Procedure Rotate(aAngle: Double; cPoint: TDoublePoint);override; Procedure Mirror(Point1,Point2: TDoublePoint);override; Function GetClassName:String;override; end; TVDimLine = class(TDimLine) caption: string; LStyle: TVDimLabelStyle; Function Edit:Boolean;override; Procedure Draw(DEngine: TPCDrawEngine; isGrayed:Boolean);override; function IsPointIn(x,y: Double): boolean;override; Procedure Getbounds(var figMaxX,figMaxY,figMinX,figMinY: Double);override; Function Duplicate:TFigure; override; Procedure WriteToStream(Stream:TStream);override; Procedure SetPropertyFromStream(xCode:Byte;data:pointer;size:integer);override; class function CreateFromShadow(aOwner:TComponent;LHandle: LongInt;Shadow:TFigure): TFigure;override; class Function CreateShadow(x,y:Double): TFigure;override; Function ShadowClick(ClickIndex:Integer;x,y: Double):Boolean;override; Function ShadowTrace(ClickIndex:Integer;x,y: Double):Boolean;override; Function CreateModification: TFigure;override; Function TraceModification(CadControl: Pointer;mp:TModPoint;TraceFigure:TFigure;x,y:Double;Shift: TShiftState):boolean;override; Function EndModification(CadControl: Pointer;mp:TModPoint;TraceFigure:TFigure;x,y:Double;Shift: TShiftState):boolean;override; Procedure UpdateMenu(var popMenu: TPopUpMenu;var sIndex:Integer);override; Procedure MenuClicked(CommandId:integer);override; Procedure Rotate(aAngle:Double; cPoint: TDoublePoint);override; Procedure Mirror(Point1,Point2: TDoublePoint);override; Function GetClassName:String;override; end; TADimLine = class(TDimLine) LStyle: TADimLabelStyle; HorzText: Boolean; Procedure Draw(DEngine: TPCDrawEngine; isGrayed:Boolean);override; function IsPointIn(x,y: Double): boolean;override; Procedure Getbounds(var figMaxX,figMaxY,figMinX,figMinY: Double);override; Function Duplicate:TFigure; override; Procedure WriteToStream(Stream:TStream);override; Procedure SetPropertyFromStream(xCode:Byte;data:pointer;size:integer);override; class function CreateFromShadow(aOwner:TComponent;LHandle: LongInt;Shadow:TFigure): TFigure;override; class Function CreateShadow(x,y:Double): TFigure;override; Function ShadowClick(ClickIndex:Integer;x,y:Double):Boolean;override; Function ShadowTrace(ClickIndex:Integer;x,y:Double):Boolean;override; Function CreateModification: TFigure;override; Function TraceModification(CadControl: Pointer;mp:TModPoint;TraceFigure:TFigure;x,y:double;Shift: TShiftState):boolean;override; Function EndModification(CadControl: Pointer;mp:TModPoint;TraceFigure:TFigure;x,y:double;Shift: TShiftState):boolean;override; Procedure UpdateMenu(var popMenu: TPopUpMenu;var sIndex:Integer);override; Procedure MenuClicked(CommandId:integer);override; Function GetClassName:String;override; end; TCDimLine = class(TDimLine) LStyle: TCDimLabelStyle; HorzText: Boolean; InnerGuide: Boolean; OuterGuide: Boolean; Procedure Initialize;override; Procedure GetRotatePoints(ModList: TList);override; Procedure Draw(DEngine: TPCDrawEngine; isGrayed:Boolean);override; function IsPointIn(x,y: Double): boolean;override; Procedure Getbounds(var figMaxX,figMaxY,figMinX,figMinY: Double);override; Function Duplicate:TFigure; override; Procedure WriteToStream(Stream:TStream);override; Procedure SetPropertyFromStream(xCode:Byte;data:pointer;size:integer);override; class function CreateFromShadow(aOwner:TComponent;LHandle: LongInt;Shadow:TFigure): TFigure;override; class Function CreateShadow(x,y:Double): TFigure;override; Function ShadowClick(ClickIndex:Integer;x,y:Double):Boolean;override; Function ShadowTrace(ClickIndex:Integer;x,y:Double):Boolean;override; Function CreateModification: TFigure;override; Function TraceModification(CadControl: Pointer;mp:TModPoint;TraceFigure:TFigure;x,y:double;Shift: TShiftState):boolean;override; Function EndModification(CadControl: Pointer;mp:TModPoint;TraceFigure:TFigure;x,y:double;Shift: TShiftState):boolean;override; Procedure UpdateMenu(var popMenu: TPopUpMenu;var sIndex:Integer);override; Procedure MenuClicked(CommandId:integer);override; Function GetClassName:String;override; end; TArcDimLine = class(TArc) DLabel: String; Prefix: String; Suffix: String; AutoText: Boolean; TextFont: String; TextHeight: Double; TextBold: Boolean; TextItalic: Boolean; TextColor: TColor; LStyle: TArcDimLabelStyle; GuideLen: Double; DrawGuides: Boolean; Constructor Create(cx,cy,rad,a1,a2:Double;LHandle:LongInt; aDrawStyle: TDrawStyle;aOwner: TComponent); Function Edit:Boolean;override; Procedure Initialize;override; Procedure Draw(DEngine: TPCDrawEngine; isGrayed:Boolean);override; function IsPointIn(x,y: Double): boolean;override; Procedure Getbounds(var figMaxX,figMaxY,figMinX,figMinY: Double);override; //procedure getModPoints(ModList: TList);override; procedure getModPoints(ModList: TMyList);override; Function Duplicate:TFigure; override; Procedure WriteToStream(Stream:TStream);override; Procedure SetPropertyFromStream(xCode:Byte;data:pointer;size:integer);override; class function CreateFromShadow(aOwner:TComponent;LHandle: LongInt;Shadow:TFigure): TFigure;override; class Function CreateShadow(x,y:Double): TFigure;override; Function ShadowClick(ClickIndex:Integer;x,y:Double):Boolean;override; Function ShadowTrace(ClickIndex:Integer;x,y:Double):Boolean;override; Function CreateModification: TFigure;override; Function TraceModification(CadControl: Pointer;mp:TModPoint;TraceFigure:TFigure;x,y:double;Shift: TShiftState):boolean;override; Function EndModification(CadControl: Pointer;mp:TModPoint;TraceFigure:TFigure;x,y:double;Shift: TShiftState):boolean;override; Procedure UpdateMenu(var popMenu: TPopUpMenu;var sIndex:Integer);override; Procedure MenuClicked(CommandId:integer);override; Function GetClassName:String;override; Function ModifyTextAndFont(mm: TModifyMode; valueI:Double; valueS: string; valueSt: TFontStyles;ValueB:Boolean):Boolean;override; function GetAngle: Double; //06.10.2011 function SetAngle(AValue: Double): Boolean; //06.10.2011 procedure Scale(percentx, percenty: Double; rPoint: TDoublePoint); override; end; TRotate = class(TFigure) Function GetAngle:Double;virtual; constructor create(cX,cY:Double;p1,p2: TDoublepoint); procedure draw(DEngine: TPCDrawEngine; isGrayed:Boolean);override; class Function CreateShadow(x,y:Double): TFigure;override; Function ShadowClick(ClickIndex:Integer;x,y: Double):Boolean;override; Function ShadowTrace(ClickIndex:Integer;x,y: Double):Boolean;override; class function CreateFromShadow(aOwner: TComponent;LHandle: LongInt;Shadow:TFigure): TFigure;override; end; TMove = class(TFigure) constructor create(p1,p2: TDoublepoint); procedure draw(DEngine: TPCDrawEngine; isGrayed:Boolean);override; class Function CreateShadow(x,y:Double): TFigure;override; Function ShadowClick(ClickIndex:Integer;x,y: Double):Boolean;override; Function ShadowTrace(ClickIndex:Integer;x,y: Double):Boolean;override; class function CreateFromShadow(aOwner: TComponent;LHandle: LongInt;Shadow:TFigure): TFigure;override; end; TDuplicate = class(TMove) class Function CreateShadow(x,y:Double): TFigure;override; class function CreateFromShadow(aOwner: TComponent;LHandle: LongInt;Shadow:TFigure): TFigure;override; end; TDuplicateAsBezier = class(TMove) class Function CreateShadow(x,y:Double): TFigure;override; class function CreateFromShadow(aOwner: TComponent;LHandle: LongInt;Shadow:TFigure): TFigure;override; end; TMirror = class(TMove) Straight: Boolean; Procedure Initialize; Function ShadowClick(ClickIndex:Integer;x,y: Double):Boolean;override; Function ShadowTrace(ClickIndex:Integer;x,y: Double):Boolean;override; class Function CreateShadow(x,y:Double): TFigure;override; class function CreateFromShadow(aOwner: TComponent;LHandle: LongInt;Shadow:TFigure): TFigure;override; end; TKnife = class(TMove) class Function CreateShadow(x,y:Double): TFigure;override; class function CreateFromShadow(aOwner: TComponent;LHandle: LongInt;Shadow:TFigure): TFigure;override; end; TCalibrate = class(TMove) procedure draw(DEngine: TPCDrawEngine; isGrayed:Boolean);override; class Function CreateShadow(x,y:Double): TFigure;override; class function CreateFromShadow(aOwner: TComponent;LHandle: LongInt;Shadow:TFigure): TFigure;override; end; TArrayPol = class(TRotate) Function GetAngle:Double;override; class Function CreateShadow(x,y:Double): TFigure;override; class function CreateFromShadow(aOwner: TComponent;LHandle: LongInt;Shadow:TFigure): TFigure;override; end; TArrayRect = class(TFigure) constructor create(p1,p2,p3,p4,p5: TDoublepoint); procedure draw(DEngine: TPCDrawEngine; isGrayed:Boolean);override; class Function CreateShadow(x,y:Double): TFigure;override; Function ShadowClick(ClickIndex:Integer;x,y: Double):Boolean;override; Function ShadowTrace(ClickIndex:Integer;x,y: Double):Boolean;override; class function CreateFromShadow(aOwner: TComponent;LHandle: LongInt;Shadow:TFigure): TFigure;override; end; TVectorSegment = class(TMyObject) SegmentType: TVectorSegmentType; EndPoint: TDoublePoint; Cpoint1 : TDoublePoint; Cpoint2 : TDoublePoint; Constructor CreateLineSegment(ePoint: TDoublePoint); Constructor CreateBezierSegment(ePoint,cp1,cp2:TDoublepoint); Constructor CreateFromStream(Stream: TStream); Constructor CreateFromStreamOldFormat(Stream: TStream); Destructor Destroy; // Tolik 13/12/2019 -- Procedure SaveToStream(Stream:TStream); Function Duplicate: TVectorSegment; Procedure Move(dx,dy: Double); Procedure Scale(px,py: double); end; TVectorObject = class(TMyObject) ObjectType: TVectorObjectType; Values: Array of TDoublePoint; ArrayLen: Integer; Procedure GetLocalValues(LValues: TDoublePointArr;sCoord:TDoublePoint; Scale,Angle:Double); Constructor CreateLineObject(p1,p2: TDoublePoint); Constructor CreateBezierObject(p1,p2,cp1,cp2: TDoublePoint); Constructor CreateEllipseObject(p1: TDoublePoint;a,b:Double); Constructor CreateCircleObject(p1: TDoublePoint;r:Double); Constructor CreatePolyLineObject(nbrPoint: Integer; p: array of TDoublePoint); Constructor CreatePolygonObject(nbrPoint: Integer; p: array of TDoublePoint); Constructor CreatePointObject(p:TDoublepoint); Constructor CreateFromStream(Stream: TStream); Procedure SaveToStream(Stream:TStream); Function Duplicate: TVectorObject; Destructor Destroy; override; Procedure Move(dx,dy: Double); Procedure Scale(px,py: double); end; TVector = class(TMyObject) StartY: Double; Segments: TList; Objects: TList; Function AddLineSegment(ePoint:TDoublePoint):TVectorSegment; Function AddBezierSegment(ePoint:TDoublePoint; cPoint1,cPoint2: TDoublePoint):TVectorSegment; Procedure AddVectorObject(cObject: TVectorObject); Procedure Draw(DEngine:TPCDrawEngine;sCoord,eCoord:TDoublepoint;Scale:Double); Procedure DrawObjects(DEngine:TPCDrawEngine;sCoord,eCoord:TDoublepoint;Scale:Double); Constructor Create(SPointY: Double); Function Duplicate:TVector; Destructor Destroy;override; Procedure Scale(px,py: double); Procedure SaveToStream(Stream:TStream); Procedure LoadFromStream(Stream:TStream); Procedure LoadFromStreamOldFormat(Stream:TStream); Procedure MoveContent(dx,dy:Double); end; TPattern = class(TMyObject) PatName: String; Gap : Double; Vector: TVector; PWidth: Double; Constructor CreateFromFigure(aFigure: TFigure); Constructor Create(aVector: TVector;aWidth,aGap:Double); Procedure StartDraw(DEngine:TPCDrawEngine;sCoord:TDoublePoint); Procedure Scale(px,py: double); Procedure Draw(DEngine:TPCDrawEngine;sCoord,eCoord:TDoublepoint;Scale:Double); Procedure DrawObjects(DEngine:TPCDrawEngine;sCoord,eCoord:TDoublepoint;Scale:Double); Function Duplicate: TPattern; Destructor destroy;override; Procedure SaveToStream(Stream:TStream); Procedure LoadFromStream(Stream:TStream); Procedure LoadFromStreamOldFormat(Stream:Tstream); end; TPrintRect = class(TRectangle) //25.11.2011 - Для выделения области печати class function CreateFromShadow(aOwner: TComponent;LHandle: Integer; Shadow: TFigure): TFigure; override; end; Function IntersectSegments(var seg1,seg2: TPLSegment):Boolean; Function CreateAlignedDimLine(p1,p2,offp1,offp2:TDoublePoint;Owner:TComponent):TADimLine; Function CreateVerticalDimLine(p1,p2,offp1,offp2:TDoublePoint;Owner:TComponent):TVDimLine; const acadlw: array[1..10] of SmallInt = (0,5,13,18,25,30,40,53,70,90); const charsets: array [0..17] of Byte = (ANSI_CHARSET, DEFAULT_CHARSET, SYMBOL_CHARSET, SHIFTJIS_CHARSET, GB2312_CHARSET, HANGEUL_CHARSET, CHINESEBIG5_CHARSET, OEM_CHARSET, JOHAB_CHARSET, HEBREW_CHARSET, ARABIC_CHARSET, GREEK_CHARSET, TURKISH_CHARSET, THAI_CHARSET, EASTEUROPE_CHARSET, RUSSIAN_CHARSET, MAC_CHARSET, BALTIC_CHARSET); var OldPatternFormat:Boolean = False; SelFeed: Integer = 0; CalibrateUnit: Byte = 0; // 0=nm 1=mm 2=cm 3=dm 4=m 5=km PolylineKeyControl:Boolean=False; MirrorDupl: Boolean=True; ConvertRatio: Double = 1; ConvertDx : Double = 0; ConvertDy : Double = 0; implementation uses PCDrawing, Powercad, U_Common, U_BaseCommon, U_ESCADClasess, U_Constants, fplan,{Tolik 13/07/2017 } U_Cad; var TempCanvas: TCanvas; TempEngine: TPCDrawEngine; Handles:integer = 0; plPs0,plPs1,plPs2: integer; ClassIndexes: TStringList; // Tolik 24/05/2019 - - Function EditStreamInCallback(dwCookie: Longint; pbBuff: PByte; cb: Longint; var pcb: Longint): Longint; stdcall; var theStream: TStream; dataAvail: LongInt; begin theStream := TStream(dwCookie); with theStream do begin dataAvail := Size - Position; if dataAvail <= cb then begin pcb := Read(pbBuff^, dataAvail); Result := 0; end else begin pcb := Read(pbBuff^, cb); Result := pcb; end; end; end; Function EditStreamOutCallback(dwCookie: Longint; pbBuff: PByte; cb: Longint; var pcb: Longint): Longint; stdcall; var theStream: TStream; begin theStream := TStream(dwCookie); with theStream do begin If cb > 0 Then Begin pcb := Write(pbBuff^, cb); Result := pcb; End Else Result := 0; end; end; Procedure GetRTFSelection( aRichEdit: TRichEdit; intoStream: TStream ); Var editstream: TEditStream; Begin With editstream Do Begin dwCookie:= Longint(intoStream); dwError:= 0; pfnCallback:= EditStreamOutCallBack; end; // Tolik 07/11/2019 -- если юзать SFF_SELECTION, предварительно через re.SelectAll, //то каждый раз добавляет пустую строку типа "" к строкам { aRichedit.Perform( EM_STREAMOUT, SF_RTF or SFF_SELECTION, longint(@editstream));} aRichedit.Perform( EM_STREAMOUT, SF_RTF, longint(@editstream)); // End; Procedure PutRTFSelection( aRichEdit: TRichEdit; sourceStream: TStream ); Var editstream: TEditStream; Begin With editstream Do Begin dwCookie:= Longint(sourceStream); dwError:= 0; pfnCallback:= EditStreamInCallBack; end; // Tolik 07/11/2019 -- если юзать SFF_SELECTION, предварительно через re.SelectAll, //то каждый раз добавляет пустую строку типа "" к строкам {aRichedit.Perform( EM_STREAMIN, SF_RTF or SFF_SELECTION, longint(@editstream));} aRichedit.Perform( EM_STREAMIN, SF_RTF, longint(@editstream)); // End; // // Tolik 23/05/2017 -- рисовать прозрачные/полупрозрачные заливки объектов {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; } (* procedure DrawOpacityBrush(ACanvas: TCanvas; X, Y: Integer; AColor: TColor; ASize: Integer; Opacity: Byte); var Bmp: TBitmap; I, J: Integer; Pixels: PRGBQuad; ColorRgb: Integer; ColorR, ColorG, ColorB: Byte; aBlendFunc : TBlendFunction; begin Bmp := TBitmap.Create; try Bmp.PixelFormat := pf32Bit; // needed for an alpha channel Bmp.Width := ASize; Bmp.Height := ASize; // Bmp.Transparent := true; // Bmp.TransparentColor := clGreen; with Bmp.Canvas do begin Brush.Color := clFuchsia; // background color to mask out ColorRgb := ColorToRGB(Brush.Color); FillRect(Rect(0, 0, ASize, ASize)); Pen.Color := AColor; Pen.Style := psSolid; Pen.Width := ASize; MoveTo(ASize div 2, ASize div 2); LineTo(ASize div 2, ASize div 2); end; ColorR := GetRValue(ColorRgb); ColorG := GetGValue(ColorRgb); ColorB := GetBValue(ColorRgb); 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; DrawAlphaAPI(bmp, ACanvas, 100, 100, Opacity); finally Bmp.Free; end; end; *) // //****************************************************************************** // TMODPOINT IMPLEMENTATION //****************************************************************************** Constructor TModPoint.Create(aFigure: TFigure;aType: TModPointType; adType : TPointType; aColor: TColor; aDim,X,Y:Double; aSeqNbr: integer;z:Double=0); begin inherited create; Figure := aFigure; PType := aType; DType := aDType; Color := aColor; CoordX := x; CoordY := y; CoordZ := z; SeqNbr := aSeqNbr; Dim := aDim; Tag := 0; Obj1 := 0; Obj2 := 0; Obj3 := 0; Obj4 := 0; OnlyIso := False; isDraw := True; isBlink :=False; //FIsDrag := false; end; //Tolik Destructor TModPoint.Destroy; begin inherited; end; Function TModPoint.IspointIn(x,y,pdim:Double):Boolean; Begin result := false; if onlyiso then exit; If ((x <= CoordX+pdim) and (x >= CoordX-pdim)) and ((y <= CoordY+pdim) and (y >= CoordY-pdim)) then begin result := true; end; end; //****************************************************************************** // TLAYER IMPLEMETATION //****************************************************************************** constructor Tlayer.create(aname: string); begin inherited create; //Tolik 10/12/2021 - - //name := aName; name := Copy(aname, 1, 255); // ModPoints := TList.Create; visible := seen; PenColor := clBlack; BrushColor := clRed; TextColor := clBlack; Description := ''; Tag := 0; LayerWidth := 0; LayerHeight := 0; Data := nil; IsDxf := false; tmpVisible := seen; end; destructor Tlayer.destroy; var a: integer; begin try for a := 0 to modpoints.Count - 1 do TmodPoint(modpoints[a]).destroy; // ModPoints.Destroy; //Tolik ModPoints.Clear; ModPoints.Free; // if assigned(Data) then Data.Free; inherited destroy; except // on E: Exception do AddExceptionToLog(CPowerCadMessage + 'Tlayer.destroy' + E.Message); end; end; // Tolik constructor TRegionObject.create(RegionObjectOwner: TFigure); begin inherited create; CheckPointByRects := False; if Assigned(RegionObjectOwner) then RegObjOwner := RegionObjectOwner else RegObjOwner := nil; RegObjData := nil; end; destructor TRegionObject.destroy; begin {if Length(RectArray) > 0 then SetLength(RectArray, 0);} RegObjOwner := nil; if RegObjData <> nil then GlobalFreePtr(RegObjData); inherited destroy; end; Procedure TRegionObject.GetRegData(RegObjHandle: HRGN); var i: Integer; //Size, rSize: Cardinal; Size: Dword; //Header: TRegionHeader; rdhInfo: TRgnDataHeader; //rect: PRect; begin try RegObjDataLength := 0; if regObjHandle <> 0 then begin Size := 0; //Size := GetRegionData (RegObjHandle, SizeOf (RGNDATA), nil); Size := GetRegionData(RegObjHandle, 0, nil); if size <> 0 then begin RegObjDataLength := Size; if RegObjData <> nil then begin GlobalFreePtr(RegObjData); RegObjData := nil; end; RegObjData := GlobalAllocPtr(GPTR, size*sizeOf(TrgnData)); GetRegionData(RegObjHandle, size, RegObjData); end; //data := GlobalAllocPtr(GPTR, size); // GetRegionData(RegObjHandle, size, data); (* if PRgnData(Data)^.rdh.nCount <> 0 then begin // если было чего - убиваем... if Length(RectArray) > 0 then SetLength(RectArray, 0); SetLength(RectArray, PRgnData(Data)^.rdh.nCount); PRgnData(Data)^.rdh.dwSize; PRgnData(Data)^.rdh.nRgnSize; PRgnData(Data)^.rdh.rcBound if PRgnData(Data)^.rdh.iType = 1 {RDH_RECTANGLES другого, вроде как и не бывает ...} then begin for i := 0 to PRgnData(Data)^.rdh.nCount - 1 do begin rect := @PRgnData(Data)^.buffer[i*Sizeof(TRect)]; RectArray[i] := Rect^; {RectArray[i].Top := Rect^.Top; RectArray[i].Bottom := Rect^.Bottom; RectArray[i].Left := Rect^.Left; RectArray[i].Right := Rect^.Right;} end; end; end; *) end; except on E: Exception do begin AddExceptionToLog('GetRegionData Error! ' + 'TRegionObject.GetRegData' + E.Message); end; end; end; // procedure Tlayer.WriteToStream(stream: TStream;CadControl:TObject); var xByte:Byte; xStr:String; xInt: Integer; Cad: TPCDrawing; xStream: TMemoryStream; begin xStr := Name; WriteStrField(180,Stream,xStr); xStr := Description; WriteStrField(181,Stream,xStr); xByte:= ord(visible); WriteField(90,Stream,xByte,1); xInt := Tag; if xInt <> 0 then WriteField(21,Stream,xInt,4); xInt := LayerWidth; if xInt <> 0 then WriteField(22,Stream,xInt,4); xInt := LayerHeight; if xInt <> 0 then WriteField(23,Stream,xInt,4); // if IsDxf then xInt := 0 else xInt := 1; WriteField(24,Stream,xInt,4); if assigned(Data) then begin Cad := TPCDrawing(CadControl); if assigned(Cad) and assigned(Cad.OnLayerSaveData) then begin xStream := TMemoryStream.Create; Cad.OnLayerSaveData(CadControl,Self,xStream); if xStream.Size > 0 then begin xStream.Position := 0; WriteStreamField(151,Stream,xStream); end; xStream.Free; end; end; end; class function Tlayer.CreateFromStream(Stream: TStream;aDEngine: TPCDrawEngine;CadControl:TObject): TLayer; var res:TLayer; xSize,cSize: Integer; xCode: Byte; intVal: integer; byteVal: byte; strVal: string; Buffer:pByte; CStream:TStream; Cad:TPCDrawing; begin res := TLayer.create(''); res.DrawEngine := aDengine; xSize:= Stream.Size; Cad := TPCDrawing(CadControl); if assigned(Cad) and assigned(Cad.OnLayerInitData) then Cad.OnLayerInitData(Cad,res); Repeat Stream.Read(xCode,1); if (xCode >= 20) and (xCode < 90) then begin Stream.Read(intVal,4); res.SetLayerPropertyInt(xCode,intVal); end else if (xCode >= 90) and (xCode < 120) then begin Stream.Read(byteVal,1); res.SetLayerPropertyInt(xCode,byteVal); end else if (xCode >= 150) and (xCode < 180) then begin Stream.Read(cSize,4); CStream := TMemoryStream.Create; getmem(buffer,cSize); Stream.Read(buffer^,cSize); CStream.Write(pByte(buffer)^,cSize); FreeMem(Buffer,cSize); CStream.Position := 0; res.SetLayerPropertyStream(xCode,CStream,CadControl); CStream.Free; end else if (xCode >= 180) and (xCode < 220) then begin strval := ReadStringFromStream(Stream); res.SetLayerPropertyStr(xCode,strval); end; until Stream.Position = xSize; result := res; end; procedure Tlayer.SetLayerPropertyDbl(xCode: Byte; Value: Double); begin end; procedure Tlayer.SetLayerPropertyInt(xCode: Byte; Value: Integer); begin case XCode of 21: Tag := Value; 22: LayerWidth := Value; 23: LayerHeight := Value; 90: Visible := TShow(Value); 24: begin if Value = 0 then IsDxf := true else IsDxf := false; end; end; end; procedure Tlayer.SetLayerPropertyStr(xCode: Byte; Value: String); begin case XCode of 180: Name := Value; 181: Description := Value; end; end; //****************************************************************************** // END //****************************************************************************** (* ========================================================================== *) // TFIGURE IMPLEMENTATION // (* ========================================================================== *) constructor TFigure.create(LHandle:LongInt; aDrawStyle: TDrawStyle;aOwner: TComponent); var a: integer; ClassNameIndex: Integer; begin inherited create; FClassIndex := 0; //ClassNameIndex := ClassIndexes.IndexOf(ClassName); //if ClassNameIndex <> -1 then // FClassIndex := Integer(ClassIndexes.Objects[ClassNameIndex]); // Tolik TracePoint := nil; // DimLines := TList.Create; CreateDims := False; InCombined := False; FullHitTest := False; SelOrder := 0; FPointEvent := False; CustomStream := nil; Owner:= AOwner; LayerHandle:= LHandle; DrawStyle := aDrawStyle; angletoPoint := 0; angle := 0; pointcount := 0; rotPoint := DoublePoint(0,0); SetLength(Originals,0); SetLength(Actuals,0); width := -1; style := -1; rowstyle := -1; brs := -1; brc := -1; Reghandle := 0; Modified := True; Handle := LongInt (Self); selected := False; //SelPoints := TList.Create; SelPoints := TMyList.Create; // Tolik 24/12/2019 -- FirstSelected := false; Rename; SelectedPoint := 1; JoinedFigures := TList.Create; fLockMove := False; fLockModify := False; fDiagonal := False; FlockSelect := False; Deleted := False; if (owner<>nil) then begin vertZero := ord(TPCDrawing(owner).VerticalZero); horzZero := ord(TPCDrawing(owner).HorizontalZero); end; isOp := false; oldStyleLoad := false; rMode := False; Data := nil; Info := ''; DrawInfo := False; isDrawingDetail := False; ClipFigures := TList.Create; NativeFill := False; ExHatchStepSize := 2; ExTextureSize := 2; ExFillBackColor := clNone; InClip := False; Parent := nil; //28.04.2011 FBeforeAllScale := nil; //27.05.2011 FAfterAllScale := nil; //27.05.2011 //FAfterScalingBeforeEvents := nil; //23.09.2011 FScaleAllEvent := nil; //27.05.2011 FBeforeDelFromParent := nil; //22.09.2011 FAfterUndo := nil; ZeroMemory(@FBoundRect, SizeOf(TDoubleRect)); //31.10.2011 FIsLoadedBounds := false; //31.10.2011 NotNeedToDraw := False; //29.01.2014 //Tolik RegObject := nil; Transparency := 0; // Tolik 26/05/2017 -- isAutoCreatedFigure := 0; end; Class Function TFigure.ShadowType:TShadowType; begin result := stNone; end; class function TFigure.IsOneClick: Boolean; begin result := false; end; class function TFigure.InsideSelection: Boolean; begin result := false; end; procedure TFigure.Initialize; begin //Tollk 24/10/2017 -- id := -1; id_for_dellist := -1; if Self.Owner <> nil then begin Inc(TPowerCad(Self.Owner).FLastFigureId); id := TPowerCad(Self.Owner).FLastFigureId; end; {ID := CreateUniqueId;} // Icon := nil; IconX := 0; IconY := 0; IconVertPos := vposTop; IconHorzPos := hposLeft; Urc := 0; DataId := 0; PopStyle := fpsAppendCustom; CustomPops := ''; Visible := True; NativeFill := False; FIsLoadedBounds := false; //30.01.2012 end; function TFigure.Rename: String; begin Name := Copy(ClassName,2,length(classname)) + Inttostr(Handle); CName := Copy(ClassName,1,length(classname)); Result := Name; end; function TFigure.Edit: Boolean; var cad:TPCDrawing; begin result := false; if assigned(Owner) then begin Cad := TPCDrawing(Owner); if Assigned(Cad.OnFigureEdit) then begin cad.OnFigureEdit(Cad,Self); end; end; end; Class Function TFigure.CreateShadow(x, y: Double): TFigure; var points: array [0..1] of TPoint; begin result := nil; case ShadowType of stNone : result := nil; stLine: result := TLine.Create(x,y,x,y,1,1,clLime,ord(rsNone),0,dsTrace,nil); stRectangle: result := TRectangle.create(x,y,x,y,1,1,clLime,1,clWhite,0,dsTrace,nil); stCircle:result := TCircle.create(x,y,0,1,1,clLime,1,clWhite,0,dsTrace,nil); end; end; function TFigure.ShadowClick(ClickIndex:Integer;x,y: Double): Boolean; begin result := false; end; function TFigure.ShadowTrace(ClickIndex:Integer; x, y: Double): Boolean; begin end; class function TFigure.CreateFromShadow(aOwner: TComponent; LHandle: Integer; Shadow: TFigure): TFigure; begin result := nil; end; function TFigure.CreateModification: TFigure; var x1,x2,y1,y2,x3,y3,x4,y4: Double; a: integer; points: TDoublePointArr; st: TShadowType; begin x1 := ActualPoints[1].x; x2 := ActualPoints[2].x; x3 := ActualPoints[3].x; x4 := ActualPoints[4].x; y1 := ActualPoints[1].y; y2 := ActualPoints[2].y; y3 := ActualPoints[3].y; y4 := ActualPoints[4].y; if (self is TBmpObject) and TBMpObject(self).Skewed then st := stPolyline else st := ShadowType; case st of stNone : result := nil; stLine: result := TLine.Create(x1,y1,x2,y2,1,1,clLime,ord(rsNone),0,dsTrace,nil); stRectangle: begin result := TRectangle.create(x1,y1,x3,y3,1,1,clLime,1,clWhite,0,dsTrace,nil); result.actualpoints[1] := actualpoints[1]; result.actualpoints[2] := actualpoints[2]; result.actualpoints[3] := actualpoints[3]; result.actualpoints[4] := actualpoints[4]; result.DiagonalScale := DiagonalScale; end; stCircle:result := TCircle.create(x1,y1,Radius,1,1,clLime,1,clWhite,0,dsTrace,nil); stPolyline : begin SetLength(points,pointcount); for a:= 1 to PointCount do points[a-1] := ActualPoints[a]; result := TPolyline.create(points,1,1,clLime,1,clWhite,ord(rsNone),True,0,dsTrace,nil); end; end; if assigned(result) then result.RotPoint := RotPoint; end; function TFigure.TraceModification(CadControl: Pointer;mp: TModPoint;TraceFigure:TFigure;x, y: Double;Shift: TShiftState): boolean; begin if assigned (Tracefigure) then TraceFigure.TraceModification(CadControl,mp,TraceFigure,x,y,shift); end; Function TFigure.TraceRotate(CadControl: Pointer;mp:TModPoint;var TraceFigure:TFigure; x,y:Double;Shift: TShiftState):boolean; var a1,a2,a: Double; s: Integer; begin if mp.SeqNbr = 5 then begin TraceFigure.RotPoint := DoublePoint(x,y); end else begin a1 := GetRadOfLine(TraceFigure.rotPoint,DoublePoint(mp.CoordX ,mp.CoordY)); a2 := GetRadOfLine(TraceFigure.rotPoint,DoublePoint(x,y)); TraceFigure.Free; TraceFigure := CreateModification; a := a2-a1; s := sign(a); a := abs(a); if abs(a - 0) < (pi/180)*5 then a := 0; if abs(a - pi/2) < (pi/180)*5 then a := pi/2; if abs(a - pi) < (pi/180)*5 then a := pi; if abs(a - 3*(pi/2)) < (pi/180)*5 then a := 3*(pi/2); if abs(a - 2*pi) < (pi/180)*5 then a := 2*pi; TraceFigure.Rotate(s*a,TraceFigure.RotPoint); end; end; function TFigure.EndRotate(CadControl: Pointer;mp: TModPoint; TraceFigure: TFigure; x, y: Double;Shift: TShiftState): boolean; var a1,a2,a: Double; s: Integer; begin if mp.SeqNbr = 5 then begin RotPoint := TraceFigure.RotPoint; end else begin a1 := GetRadOfLine(rotPoint,DoublePoint(mp.CoordX ,mp.CoordY)); a2 := GetRadOfLine(rotPoint,DoublePoint(x,y)); a := a2-a1; s := sign(a); a := abs(a); if abs(a - 0) < (pi/180)*5 then a := 0; if abs(a - pi/2) < (pi/180)*5 then a := pi/2; if abs(a - 3*(pi/2)) < (pi/180)*5 then a := 3*(pi/2); if abs(a - pi) < (pi/180)*5 then a := pi; if abs(a - 2*pi) < (pi/180)*5 then a := 2*pi; Rotate(s*a,RotPoint); end; end; function TFigure.EndModification(CadControl: Pointer;mp: TModPoint; TraceFigure: TFigure; x, y: Double;Shift: TShiftState): boolean; var ap: TDoublepoint; a: integer; st: TShadowType; begin if (self is TBmpObject) and TBMpObject(self).Skewed then st := stPolyline else st := ShadowType; case st of stLine: begin ap := actualpoints[mp.SeqNbr]; ActualPoints[mp.SeqNbr] := DoublePoint(ActualPoints[mp.SeqNbr].x + (x-ap.x), ActualPoints[mp.SeqNbr].y + (y-ap.y)); end; stRectangle: For a := 1 to PointCount do begin ap := ActualPoints[a]; ActualPoints[a] := DoublePoint( ActualPoints[a].x+(TraceFigure.ActualPoints[a].x- ap.x), ActualPoints[a].y+(TraceFigure.ActualPoints[a].y- ap.y) ); end; stCircle: Radius := TraceFigure.Radius; stPolyline : begin ap := actualpoints[mp.SeqNbr]; ActualPoints[mp.SeqNbr] := DoublePoint(ActualPoints[mp.SeqNbr].x + (x-ap.x), ActualPoints[mp.SeqNbr].y + (y-ap.y)); end; end; ResetRegion; Modified := True; end; procedure TFigure.select; begin if selected then exit; selected := true; SelPoints.Pack; SelPoints.Clear; SelFeed := SelFeed+1; SelOrder := SelFeed; if rMode then begin GetRotatePoints(SelPoints); end else begin GetModPoints(SelPoints); end; if assigned(owner) then begin TPCDrawing(owner).FAnySelected := True; end; end; Procedure TFigure.RotateSelect; var figMaxX,figMaxY,figMinX,figMinY:Double; begin if selected then Deselect; RMode := True; getbounds(figMaxX,figMaxY,figMinX,figMinY); RotPoint := DoublePoint((figMaxX+figMinX)/2,(figMaxY+figMinY)/2); Select; end; procedure TFigure.deselect; var CControl: TPCDrawing; a: integer; begin if not selected then exit; selected := false; SelOrder := 0; FirstSelected := false; CControl := TPCDrawing(owner); try SelPoints.Pack; // Tolik 24/12/2019 -- For a := 0 to SelPoints.count - 1 do begin CControl.UnRegisterModPoint(SelPoints[a]); end; SelPoints.Pack; //// Tolik 24/12/2019 -- SelPoints.clear; except // on E: Exception do AddExceptionToLog(CPowerCadMessage + 'TFigure.deselect' + E.Message); end; end; procedure TFigure.ReSelect; var CControl: TPCDrawing; a: integer; begin if not selected then exit; CControl := TPCDrawing(owner); try SelPoints.Pack; // Tolik 24/12/2019 -- For a := 0 to SelPoints.count - 1 do begin CControl.UnRegisterModPoint(SelPoints[a]); end; SelPoints.clear; except // on E: Exception do AddExceptionToLog(CPowerCadMessage + 'TFigure.ReSelect' + E.Message); end; if rMode then GetRotatePoints(SelPoints) else GetModPoints(SelPoints); if assigned(owner) then begin TPCDrawing(owner).FAnySelected := True; end; end; Procedure TFigure.ReSelectUnsel; //02.04.2012 var CControl: TPCDrawing; a: integer; begin if not selected then exit; CControl := TPCDrawing(owner); SelPoints.Pack; // Tolik 24/12/2019 For a := 0 to SelPoints.count - 1 do begin CControl.UnRegisterModPoint(SelPoints[a]); end; SelPoints.clear; end; Procedure TFigure.ReSelectSel; //02.04.2012 begin if not selected then exit; if rMode then GetRotatePoints(SelPoints) else GetModPoints(SelPoints); if assigned(owner) then begin TPCDrawing(owner).FAnySelected := True; end; end; Procedure TFigure.drawselectionpoints(DEngine: TPCDrawEngine;isGrayed:Boolean); var a : integer; pt : TModPoint; aColor : TColor; x,y,z: Double; begin For a := 0 to SelPoints.Count -1 do begin pt := TModPoint(SelPoints[a]); if (isDrawingDetail) or (not pt.OnlyIso) then begin if isGrayed then acolor := TPCDrawing(Owner).FGrayedColor //06.08.2012 Grayedcolor else aColor := pt.Color; DrawSelPoint(DEngine,isGrayed,pt); x := pt.CoordX; y := pt.CoordY; z := pt.CoordZ; DEngine.ConvertPoint(x,y,z); if isDrawingDetail then begin pt.PixDetX := Round(x); pt.PixDetY := Round(y); end else begin pt.PixX := Round(x); pt.PixY := Round(y); end; end; end; end; procedure TFigure.DrawFigureGuides(DEngine: TPCDrawEngine); var fRect: TDoubleRect; p : TDoublePoint; Cad: TPowercad; xInfo: String; begin if assigned(Icon) then begin fRect := GetBoundRect; DEngine.DrawFigureIcon(fRect,IconX,IconY,IconVertPos,IconHorzPos,Icon); end; xInfo := Info; if assigned(owner) then begin Cad := TPowercad(Owner); if assigned(Cad.OnDrawFigureInfo) then Cad.OnDrawFigureInfo(Cad,Self,xInfo); end; if (xInfo <> '') and DrawInfo then begin fRect := GetBoundRect; p := DoublePoint(((Frect.left+frect.right)/2),frect.bottom+3); Dengine.DrawCenteredText(p,ClBlack,xInfo,'Tahoma',4.0); end; end; Procedure TFigure.ModifySelection(mm: TModifyMode; value: Integer); Begin case mm of mmPenColor : Color := value; mmPenWidth : Width := value; mmPenStyle : Style := value; mmBrushStyle : brs := value; mmBrushColor : brc := value; mmRowStyle : RowStyle := value; end; End; Function TFigure.ModifyTextAndFont(mm: TModifyMode; valueI: double; valueS: string; valueSt: TFontStyles;ValueB:Boolean):Boolean; Begin result := false; end; procedure TFigure.ResetRegion; var i: Integer; begin if RegHandle <> 0 then DeleteObject(RegHandle); RegHandle := 0; //Tolik if RegObject <> nil then begin if RegObject.RegObjData <> nil then begin GlobalFreePtr(RegObject.RegObjData); RegObject.RegObjData := nil; end; FreeAndNil(RegObject); end; // for i := 0 to ClipFigures.Count - 1 do begin TFigure(ClipFigures[i]).ResetRegion; end; end; procedure TFigure.WriteToStream(Stream: TStream); var xInt,a,LNbr: Integer; aPoints: pInt; xDouble: Double; xByte: Byte; IStream,xStream,fStream: TMemoryStream; DimLine:TFigure; fSize:Integer; begin WriteString(Stream,ClassName); try WriteString(Stream, Name); except on E: Exception do begin addExceptionToLogEx('TFigure.WriteToStream (Name)', E.Message); Name := Copy(ClassName, 2, length(classname)) + Inttostr(Handle); WriteString(Stream, Name); end; end; if assigned(Owner) then LNbr := TPCDrawing(Owner).Layers.IndexOf(Pointer(LayerHandle)) else LNbr := 0; xByte := 0; if fDiagonal then xByte := 1; WriteField(90,Stream,xByte,1); //IGOR 22/11/2019 -- if RowStyle = -1 then xByte := 255 else xByte := LoByte(LoWord(RowStyle)); // WriteField(91,Stream,xByte,1); xByte := DimLines.Count; WriteField(92,Stream,xByte,1); xByte := ord(ExHatchStyle); WriteField(93,Stream,xByte,1); xByte := ord(ExGradStyle); WriteField(94,Stream,xByte,1); xByte := ord(ExTextureStyle); WriteField(95,Stream,xByte,1); // Tolik -- 30/05/2017 -- xByte := isAutoCreatedFigure; WriteField(253,Stream,xByte,1); // xInt:= Lnbr; WriteField(21,Stream,xInt,4); xDouble:= AngleToPoint; WriteField(220,Stream,xDouble,8); xDouble:= Angle; WriteField(221,Stream,xDouble,8); xDouble:= Radius; WriteField(222,Stream,xDouble,8); xDouble:= ExHatchStepSize; WriteField(223,Stream,xDouble,8); xInt:= PointCount; WriteField(24,Stream,xInt,4); xInt:= Width; WriteField(26,Stream,xInt,4); xInt:= Color; WriteField(27,Stream,xInt,4); xInt:= Style; WriteField(28,Stream,xInt,4); xInt:= ID; WriteField(29,Stream,xInt,4); xInt:= LongInt(Data); WriteField(30,Stream,xInt,4); xInt:= DataID; WriteField(31,Stream,xInt,4); xInt:= ExFillBackColor; WriteField(32,Stream,xInt,4); xInt:= ExTextureSize; WriteField(33,Stream,xInt,4); // Tolik -- write Transparency -- begin using free indexes from 254 downto .... if needed xInt:= Transparency; WriteField(254,Stream,xInt,4); // GetMem(aPoints, PointCount * 16); For a := 1 to PointCount do begin // Tolik 26/03/2019 -- //pDouble(pChar(aPoints) + ((a - 1) * 16) + 0)^ := ActualPoints[a].x; //pDouble(pChar(aPoints) + ((a - 1) * 16) + 8)^ := ActualPoints[a].y; pDouble(pAnsiChar(aPoints) + ((a - 1) * 16) + 0)^ := ActualPoints[a].x; pDouble(pAnsiChar(aPoints) + ((a - 1) * 16) + 8)^ := ActualPoints[a].y; // end; WriteBinField(152,Stream,pByte(aPoints),PointCount*16); FreeMem(aPoints,PointCount*16); if assigned(customStream) then begin WriteStreamField(153,Stream,customStream); end; if assigned(Icon) then begin IStream := TmemoryStream.Create; Icon.SaveToStream(IStream); WriteStreamField(154,Stream,IStream); IStream.Free; end; xStream := TMemoryStream.Create; xStream.Write(DimLines.Count,4); for a := 0 to Dimlines.Count - 1 do begin fStream := TMemoryStream.Create; DimLine := TFigure(Dimlines[a]); DimLine.WriteToStream(fStream); fSize := fStream.Size; fStream.Position := 0; xStream.Write(fSize,4); StreamToStream(fStream,xStream,fSize); fStream.Free; end; WriteStreamField(155,Stream,xStream); xStream.Free; WriteStrField(181,Stream,Info); WriteStrField(182,Stream,UserClass); WriteStrField(180,Stream,'BaseEnd'); end; class function TFigure.CreateFromStream(Stream: TStream; LHandle: Integer; aDrawStyle: TDrawStyle; aOwner: TComponent): TFigure; var TypeName: string; a: integer; FigClass: TFigureClass; res: Tfigure; FigIdx: integer; begin TypeName := ReadStringFromStream(Stream); figClass := nil; //01.11.2011 {for a := 0 to FigureClasses.Count -1 do begin if TFigureClass(FigureClasses[a]).ClassName = TypeName then FigClass := TFigureClass(FigureClasses[a]); end;} FigIdx := FigureClassesSL.IndexOf(TypeName); //01.11.2011 if FigIdx <> -1 then //01.11.2011 FigClass := TFigureClass(FigureClassesSL.Objects[FigIdx]); if figclass = nil then begin result := nil; exit; end else begin res := FigClass.Create(LHandle,aDrawStyle,aOwner); res.fPointEvent := True; // Tolik - - повторная инициализация нужна, иначе будет писец ... НЕ ТРОГАТЬ!!! res.Initialize; // res.SetPropertiesFromStream(Stream); //if res.CreateDims then res.CreateDimLines; end; result := res; end; Procedure TFigure.SetPropertiesFromStream(Stream: TStream); var isOk: Boolean; xCode, xSize, a, x, y, t, cpCount: Integer; xd,yd: Double; intVal: Integer; byteVal: Byte; wordVal: Word; strVal: string; dblval: Double; LNbr: integer; xByte: pByte; Buffer: pByte; IStream, xStream: TMemoryStream; pCnt: Integer; // Tolik -- 12/10/2017 streamsize, streamPos: Integer; myStream: TfileStream; // Tolik 13/10/2017 // Что касается подъема фигуры со стрима: // Стандартно предполагается следующая последовательность кодов со значениями в один байт 90,91,92,93... // НО! Некоторые компоненты в базе записаны не так, а по-старому, и там выходит что-то типа: 90,91..а дальше 21...и что-то там еще, // но никак не 93 // вот такая вот цепочка... поэтому для проверки можно точно определиться только до третьего байта (90, 91, а потом 92 или 21) function CanLoadFigureFromStream: boolean; var CodeSequence: String; SeekCode: Integer; begin Result := False; CodeSequence := ''; SeekCode := 90; if Stream.Position >= Stream.Size - 1 then begin AddExceptionToLogEX('TFigure.SetPropertiesFromStream: ' , ' No code 90 after name (end stream)!' + #13#10 + 'CadName = ' + GCadForm.Name + #13#10 + 'FigureClassName: '+ Self.ClassName + ' FigureName: '+ Name); //Inc(GExceptionCount); exit; end; Stream.Read(xCode, 1); if xCode <> 90 then begin if (Self is TFigureGrp) then exit; AddExceptionToLogSilent('TFigure.SetPropertiesFromStream: No code 90 after name!' + #13#10 + 'CadName = ' + GCadForm.Name + #13#10 + 'FigureClassName: '+ Self.ClassName + ' FigureName: '+ Name); //Inc(GExceptionCount); //AddExceptionToLogSilent('TFigure.SetPropertiesFromStream: ' + ' No correct code sequence!' + #13#10 + 'CadName = ' + GCadForm.Name + // #13#10 + 'FigureClassName: '+ Self.ClassName + ' FigureName: '+ Name); (* StreamPos := Stream.Position; Stream.Position := 0; Mystream := TfileStream.Create('d:\stream.txt', fmCreate); Mystream.CopyFrom(Stream, StreamSize); Mystream.free; Stream.Position := StreamPos; *) While Stream.Position < (Stream.Size - 2) do begin if xCode <> 90 then begin Stream.Read(xCode, 1); end else begin StreamPos := Stream.Position; Stream.Position := Stream.Position + 1; if Stream.Position <= StreamSize - 9 then begin Stream.Read(xCode, 1); if xCode = 91 then begin Stream.Position := Stream.Position + 1; Stream.Read(xCode, 1); if (xCode = 92) or (xCode = 21) then begin //Stream.Position := Stream.Position + 1; // Stream.Read(xCode, 1); // if xCode = 93 then // begin Result := True; Stream.Position := Stream.Position - 5; // -7 exit; // end; end; end; end; Stream.Position := StreamPos; Stream.Read(xCode, 1); end; end; end else begin StreamPos := Stream.Position; Stream.Position := Stream.Position + 1; if Stream.Position <= StreamSize - 9 then begin Stream.Read(xCode, 1); if xCode = 91 then begin Stream.Position := Stream.Position + 1; Stream.Read(xCode, 1); if (xCode = 92) or (xCode = 21) then begin //Stream.Position := Stream.Position + 1; // Stream.Read(xCode, 1); // if xCode = 93 then // begin Result := True; Stream.Position := Stream.Position - 5; exit; // end; end; end; end; Stream.Position := StreamPos; Stream.Read(xCode, 1); While Stream.Position < (Stream.Size - 2) do begin if xCode <> 90 then begin Stream.Read(xCode, 1); end; if xCode = 90 then begin StreamPos := Stream.Position; Stream.Position := Stream.Position + 1; if Stream.Position <= StreamSize - 9 then begin Stream.Read(xCode, 1); if xCode = 91 then begin Stream.Position := Stream.Position + 1; Stream.Read(xCode, 1); if (xCode = 92) or (xCode = 21) then begin //Stream.Position := Stream.Position + 1; //Stream.Read(xCode, 1); //if xCode = 93 then //begin Result := True; Stream.Position := Stream.Position - 5; break; //end; end; end; end; Stream.Position := StreamPos; Stream.Read(xCode, 1); end; if Result then exit; end; end; end; // begin try isOk := False; // Tolik -- 12/10/2017 -- StreamSize := Stream.Size; StreamPos := Stream.Position; // try Name := ReadStringFromStream(Stream); LNbr := -1; xCode := 0; RegHandle := 0; {if self is TLine then begin StreamPos := Stream.Position; Stream.Position := 0; Mystream := TfileStream.Create('d:\stream_line.txt', fmCreate); Mystream.CopyFrom(Stream, StreamSize); Mystream.free; Stream.Position := StreamPos; end; if (StreamSize = 210) then xCode := 0;} // Tolik -- 12/10/2017 -- if CanLoadFigureFromStream then begin // repeat // Tolik -- 12/10/2017 -- StreamPos := Stream.Position; if StreamPos = StreamSize then begin {Stream.Position := 0; Mystream := TfileStream.Create('d:\stream.txt', fmCreate); Mystream.CopyFrom(Stream, StreamSize); Mystream.free;} AddExceptionToLogEx('TFigure.SetPropertiesFromStream:', 'Can not load Figure. The stream is corrupted (not found BaseEnd)!' + #13#10 + 'CadName = ' + GCadForm.Name + #13#10 + 'FigureClassNameName: '+ Self.ClassName + ' FigureName: '+ Name); isOk := True; break; end; // Stream.Read(xCode, 1); if (((xCode >= 20) and (xCode < 90)) or (xCode = 254)) then begin Stream.Read(intVal, 4); Case xcode of 21: Lnbr := IntVal; 22: AngleToPoint := ((intVal / 10) / 180) * pi; // in old format 23: Angle := ((intVal / 10) / 180) * pi; // in old format 24: PointCount := intVal; 25: cpCount := intval; // it was ControlPoint Count in old format 26: Width := intVal; 27: Color := intVal; 28: Style := intVal; 29: ID := intVal; 30: Data := Pointer(intVal); 31: DataId := intVal; 32: ExFillBackColor := intVal; 33: ExTextureSize := intVal; // Tolik -- Transparency 30/05/2017 -- 254: Transparency := IntVal; // end; end else if (((xCode >= 90) and (xCode < 120)) or (xCode = 253)) then begin Stream.Read(byteVal, 1); Case xcode of 90: DiagonalScale := (byteVal = 1); 91: begin if byteVal = 255 then RowStyle := -1 else RowStyle := byteVal; end; 92: if byteVal > 0 then CreateDims := True else CreateDims := False; 93: ExHatchStyle := THatchStyle(byteVal); 94: ExGradStyle := TGradStyle(byteVal); 95: ExTextureStyle := TTextureStyle(byteVal); // Tolik 30/05/2017 -*- 253: isAutoCreatedFigure := byteVal; // end; end else if (xCode >= 120) and (xCode < 150) then begin Stream.Read(wordVal, 2); end else if (xCode >= 150) and (xCode < 180) then begin Stream.Read(xSize,4); Case xcode of 150: begin // in old format OldStyleLoad := True; for a := 1 to PointCount do begin Stream.read(x,4); Stream.read(y,4); ActualPoints[a] := DoublePoint(x/10,y/10); end; end; 151: begin // was control points in old format if Self is TPolyLine then begin SetLength(fTempPoints,cpCount); for a := 1 to cpCount do begin Stream.read(x,4); Stream.read(y,4); fTempPoints[a-1] := Point(x,y); end; end else begin GetMem(xByte,xSize); Stream.read(xByte^,xSize); FreeMem(xByte,xSize); end; end; 152: begin pCnt := xSize div 16; PointCount := pCnt; for a := 1 to pCnt do begin // Tolik 22/06/2021 -- попытка исключить мусор //Stream.read(xd,8); // <--- так было ... //Stream.read(yd,8);} // <--- так было ... Stream.read(xd,8); if CompareValue(xd, 0, 0.0000001) = 0 then xd := 0; Stream.read(yd,8); if CompareValue(yd, 0, 0.0000001) = 0 then yd := 0; // ActualPoints[a] := DoublePoint(xd,yd); end; end; 153: begin CustomStream := TMemoryStream.Create; getmem(buffer,xSize); Stream.Read(buffer^,xSize); CustomStream.Write(pByte(buffer)^,xsize); FreeMem(Buffer,xSize); CustomStream.Position := 0; CustomStream.Free; end; 154: begin IStream := TMemoryStream.Create; getmem(buffer,xSize); Stream.Read(buffer^,xSize); IStream.Write(pByte(buffer)^,xsize); FreeMem(Buffer,xSize); IStream.Position := 0; Icon := Tbitmap.Create; Icon.LoadFromStream(IStream); IStream.Free; end; 155: begin XStream := TMemoryStream.Create; getmem(buffer,xSize); Stream.Read(buffer^,xSize); XStream.Write(pByte(buffer)^,xsize); FreeMem(Buffer,xSize); XStream.Position := 0; CreateDimLinesFromStream(xStream,0,Owner); xStream.Free; end; else begin try GetMem(xByte, xSize); Stream.read(xByte^, xSize); FreeMem(xByte, xSize); except isOK := True; //GProcCnt := GProcCnt + 1; end; end; end; end else if (xCode >= 180) and (xCode < 220) then begin strval := ReadStringFromStream(Stream); if xCode = 181 then Info := strval; if xCode = 182 then UserClass := strval; if strval = 'BaseEnd' then isOk := true; end else if (xCode >= 220) and (xCode < 240) then begin Stream.Read(dblval, 8); //Tolik 22/06/2021 -- сбросить мусор -- если попадется if CompareValue(dblval, 0, 0.0000001) = 0 then dblval := 0; // Case xcode of 220: AngleToPoint := dblval; 221: Angle := dblval; 222: Radius := dblval; 223: ExHatchStepSize := dblval; end; end; until isOk; end else begin AddExceptionToLogEX('TFigure.SetPropertiesFromStream: ' , 'Can not load Figure. The stream is corrupted!' + #13#10 + 'CadName = ' + GCadForm.Name + #13#10 + 'FigureClassNameName: '+ Self.ClassName + ' FigureName: '+ Name); //Inc(GExceptionCount); //Self.Select; exit; end; if (Owner <> nil) and (Lnbr >= 0) and (Lnbr < TPCDrawing(Owner).Layers.Count) then begin LayerHandle := LongInt(TPCDrawing(Owner).Layers[Lnbr]) end; SetSpecialPropertiesFromStream(Stream); except on E: Exception do addExceptionToLogEX('Exception TFigure.SetPropertiesFromStream: ' , 'Can not load Figure. The stream is corrupted!' + #13#10 + 'CadName = ' + GCadForm.Name + #13#10 + 'FigureClassNameName: '+ Self.ClassName + ' FigureName: '+ Name); end; finally // Tolik -- 25/10/2017 -- if Self.Owner <> nil then begin if TPowerCad(Self.Owner).FLastFigureIdOnLoad < Self.ID then TPowerCad(Self.Owner).FLastFigureIdOnLoad := Self.ID; end; // end; end; procedure TFigure.SetSpecialPropertiesFromStream(Stream: TStream); var xCode,xSize,a,x,y: Integer; intVal : Integer; byteVal: Byte; wordVal: Word; strVal: string; dblval: Double; Config: TRoomConfig; //p: pchar; buffer: pByte; xStream: TMemoryStream; begin xCode := 0; repeat Stream.Read(xCode,1); if (xCode >= 20) and (xCode < 90) then begin Stream.Read(intVal,4); SetPropertyFromStream(xCode,@intVal,4); end else if (xCode >= 90) and (xCode < 120) then begin Stream.Read(byteVal,1); SetPropertyFromStream(xCode,@byteVal,1); end else if (xCode >= 120) and (xCode < 150) then begin Stream.Read(wordVal,2); SetPropertyFromStream(xCode,@wordVal,2); end else if (xCode >= 150) and (xCode < 180) then begin Stream.Read(xSize,4); getmem(buffer,xSize); Stream.Read(buffer^,xSize); SetPropertyFromStream(xCode,buffer,xSize); FreeMem(Buffer,xSize); end else if (xCode >= 180) and (xCode < 220) then begin strval := ReadStringFromStream(Stream); SetPropertyFromStream(xCode,pchar(strval),0); end else if (xCode >= 220) and (xCode < 240) then begin Stream.Read(dblval,8); //Tolik 22/06/2021 -- сбросить мусор -- если попадется if CompareValue(dblval, 0, 0.0000001) = 0 then dblval := 0; // SetPropertyFromStream(xCode,@dblVal,8); end else if (xCode >= 240) and (xCode < 245) then begin Stream.Read(Config,SizeOF(Config)); SetPropertyFromStream(xCode,@Config,SizeOF(Config)); end until Stream.Position = Stream.Size; end; procedure TFigure.SetPropertyFromStream(xCode: Byte; data: pointer;size:integer); begin end; procedure TFigure.GetVectorObjects(Objects:Tlist;BaseP: TDoublePoint); begin end; Procedure TFigure.VerifyZeroPoints(orgV,orgH:Byte); var cad :TPCdrawing; h,w:Double; x,y:double; i: Integer; begin if assigned(owner) then begin cad := TPCDrawing(owner); h := Cad.WorkHeight; w := Cad.WorkWidth; if orgV <> VertZero then begin for i := 1 to PointCount do begin x := ActualPoints[i].x; y := ActualPoints[i].y; ActualPoints[i] := DoublePoint(x,h-y); OriginalPoints[i] := ActualPoints[i]; end; end; if orgH <> HorzZero then begin for i := 1 to PointCount do begin x := ActualPoints[i].x; y := ActualPoints[i].y; ActualPoints[i] := DoublePoint(w-x,y); OriginalPoints[i] := ActualPoints[i]; end; end; end; end; Function TFigure.GetOrig(index: integer): TDoublePoint; Begin if index > Length(Originals) then begin result := DoublePoint(0,0); exit; end; result := Originals[index-1]; End; Procedure TFigure.SetOrig(index: integer; xpoint: TDoublePoint); var a:integer; oSize: Integer; Begin oSize := Length(Originals); if index > OSize then begin SetLength(Originals,Index); for a := oSize to index-1 do begin Originals[a] := DoublePoint(0,0); end; end; Originals[index-1] := xpoint; end; Function TFigure.GetActual(index: integer): TDoublePoint; Begin if Length(Actuals) = 0 then begin result := DoublePOint(0,0); exit; end; if index > Length(Actuals) then begin index := 1; end; result := Actuals[index-1]; End; Procedure TFigure.SetActual(index: integer; xpoint: TDoublePoint); var a:integer; oSize: Integer; Begin oSize := Length(Actuals); if index > OSize then begin SetLength(Actuals,Index); for a := oSize to index-1 do begin Actuals[a] := DoublePoint(0,0); if fPointEvent then OnNewPoint; end; end; //31.10.2011 if FIsLoadedBounds then if (Actuals[index-1].x <> xpoint.x) or (Actuals[index-1].y <> xpoint.y) then FIsLoadedBounds := false; Actuals[index-1] := xpoint; end; procedure TFigure.GetPointArray(var Arr: TDoublePointArr); var i: Integer; begin SetLength(Arr,PointCount); for i := 0 to PointCount-1 do Arr[i] := ActualPoints[i+1]; end; procedure TFigure.GetPointArray(var Arr: TDoublePointArr; Count: Integer); var i: Integer; begin if Count > PointCount then Count := PointCount; SetLength(Arr,Count); for i := 0 to Count-1 do Arr[i] := ActualPoints[i+1]; end; function TFigure.GetPoint(index: integer): TDoublePoint; begin result := GetActual(index); end; procedure TFigure.SetPoint(Index: integer; const Value: TDoublepoint); begin SetActual(index,Value); end; Function TFigure.GetAp1: TDoublePoint; begin result := FigurePoints[1]; end; Function TFigure.GetAp2: TDoublePoint; begin result := FigurePoints[2]; end; Function TFigure.GetAp3: TDoublePoint; begin result := FigurePoints[3]; end; Function TFigure.GetAp4: TDoublePoint; begin result := FigurePoints[4]; end; Function TFigure.getP1: TDoublePoint; begin result := actualpoints[1]; end; // Tolik -- 07/07/2017 -- function TFigure.getCp: TDoublePoint; var figMaxX,figMaxY,figMinX,figMinY:Double; begin if Self is TFigureGrp then TFigureGRP(Self).GetBoundsWithoutAutoCreatedFigures(figMaxX,figMaxY,figMinX,figMinY) else if Self is TConnectorObject then TConnectorObject(Self).GetBoundsDef(figMaxX,figMaxY,figMinX,figMinY) else getbounds(figMaxX,figMaxY,figMinX,figMinY); Result := DoublePoint((figMaxX+figMinX)/2,(figMaxY+figMinY)/2); //Result := DoublePoint(Trunc(((figMaxX+figMinX)/2)*10000)/10000,Trunc(((figMaxY+figMinY)/2)*10000)/10000); end; { function TFigure.getCp: TDoublePoint; var figMaxX,figMaxY,figMinX,figMinY:Double; begin getbounds(figMaxX,figMaxY,figMinX,figMinY); Result := DoublePoint((figMaxX+figMinX)/2,(figMaxY+figMinY)/2); end; } // Procedure TFigure.move(deltax,deltay: Double); var a: integer; moveFunc: TFigMoveEvent; begin for a:= 1 to pointcount do begin originalpoints[a] := DoublePoint(originalpoints[a].x + deltax, originalpoints[a].y + deltay); Actualpoints[a] := DoublePoint(actualpoints[a].x + deltax, actualpoints[a].y + deltay); end; RotPoint := DoublePoint(RotPoint.x+deltaX,RotPoint.y+DeltaY); ResetRegion; for a := 0 to JoinedFigures.Count-1 do begin if TFigure(JoinedFigures[a]) is TLine then TLine(JoinedFigures[a]).JoinFigureMoved(self,deltax,deltay) else if TFigure(JoinedFigures[a]) is TPolyLine then TPolyLine(JoinedFigures[a]).JoinFigureMoved(self,deltax,deltay); end; if DimLines.Count > 0 then CreateDimLines; if assigned(Fill) and (assigned(Fill.Grp)) then Fill.Move(deltaX,deltaY); MoveClipFigures(deltaX,deltaY); end; Procedure TFigure.rotate(aAngle: Double; cPoint: TDoublePoint); var a: integer; point1,point2 :TPoint; begin If modified or ((cPoint.x <> rotpoint.x) or (cPoint.y <> rotpoint.y)) then begin angletoPoint := 0; for a := 1 to pointcount do originalpoints[a] := actualpoints[a]; rotpoint.x := cPoint.x; rotpoint.y := cPoint.y; end; angletoPoint := angletoPoint + Aangle; for a:= 1 to pointcount do begin actualpoints[a] := RotatePoint(cPoint,originalpoints[a],angletoPoint); end; if DimLines.Count > 0 then CreateDimLines; if assigned(Fill) then Fill.Rotate(aAngle,cPoint); ResetRegion; end; procedure TFigure.scale(px,py: Double; rPoint: TDoublepoint); var a: integer; oldcp, newcp: TDoublePoint; rt: TRichText; deltax, deltay: double; begin // если TRichText - подогнать шрифт под область // Tolik 02/11/2017 -- есди так оставить, то при попытке скейлинга групповой фигуры // поломается ее размер, т.к. ее размер не может быть меньше чем размер входящих в нее фигур // (что, в принципе, логично) т.е. скейлинг на увеличение -- вроде бы как и ничего, но на уменьшение -- // как только нужно будет сделать групповую меньше чем входящий в нее RichText -- тут же получим "бяку" { if Self.ClassName = 'TRichText' then begin // Если TRichText в группе не один if (Parent = nil) or ((Parent is TFigureGrp) and (TFigureGrp(Parent).InFigures.Count > 1) ) then //28.04.2011 begin rt := TRichText(Self); oldcp.x := (rt.ap1.x + rt.ap2.x) / 2; oldcp.y := (rt.ap1.y + rt.ap3.y) / 2; newcp := ScalePoint(rPoint, oldcp, px, py); deltax := newcp.x - oldcp.x; deltay := newcp.y - oldcp.y; for a := 1 to pointcount do begin actualpoints[a] := DoublePoint(actualpoints[a].x + deltax, actualpoints[a].y + deltay); originalpoints[a] := DoublePoint(originalpoints[a].x + deltax, originalpoints[a].y + deltay); end; exit; end; end; } for a:= 1 to pointcount do begin actualpoints[a] := ScalePoint(rPoint,actualpoints[a],px,py); originalpoints[a] := ScalePoint(rPoint,originalpoints[a],px,py); end; radius := radius * px; if DimLines.Count > 0 then CreateDimLines; if assigned(Fill) then Fill.Scale(px,py,rPoint); ResetRegion; end; Procedure TFigure.Mirror(Point1,Point2: TDoublePoint); var a:Integer; begin for a:= 1 to pointcount do begin actualpoints[a] := GetSymetricPoint(actualpoints[a],Point1,Point2); originalpoints[a] := GetSymetricPoint(originalpoints[a],Point1,Point2); end; if DimLines.Count > 0 then CreateDimLines; ResetRegion; end; procedure TFigure.draw(DEngine: TPCDrawEngine; isGrayed:Boolean); begin end; Procedure TFigure.CollectFaces(Faces:TList); var aFace: TFaceRecord; a3DPointArr: T3DPointArray; i, j: integer; Line: TOrthoLine; GetConn: TConnectorObject; InFigure: TFigure; ScaleDelta: double; begin // ScaleDelta := UOMToMetre(1000 / GCadForm.PCad.MapScale); if (self.ClassName = 'TConnectorObject') or (self.ClassName = 'TOrthoLine') then begin SetLength(a3DPointArr, length(self.actuals)); for i := 0 to length(self.actuals) - 1 do a3DPointArr[i] := self.actuals[i]; // CONNECTOR if (self.ClassName = 'TConnectorObject') then begin if (TConnectorObject(self).ConnectorType <> ct_Clear) or (TConnectorObject(Self).Name = 'Anchor') then begin for i := 0 to high(a3DPointArr) do a3DPointArr[i].z := TConnectorObject(self).ActualZOrder[i + 1] * ScaleDelta; aFace := TFaceRecord.Create(a3DPointArr, clRed, ftPipe, 0.1, False, self); Faces.Add(aFace); end; end else // ORTHOLINE begin for i := 0 to high(a3DPointArr) do a3DPointArr[i].z := TOrthoLine(self).ActualZOrder[i + 1] * ScaleDelta; Line := TOrthoLine(Self); // переназначить первую сторону if Line.JoinConnector1 <> nil then begin if TConnectorObject(Line.JoinConnector1).JoinedConnectorsList.Count = 0 then GetConn := TConnectorObject(Line.JoinConnector1) else GetConn := TConnectorObject(TConnectorObject(Line.JoinConnector1).JoinedConnectorsList[0]); if GetConn <> nil then begin a3DPointArr[0].x := GetConn.ActualPoints[1].x; a3DPointArr[0].y := GetConn.ActualPoints[1].y; end; end; // переназначить вторую сторону if Line.JoinConnector2 <> nil then begin if TConnectorObject(Line.JoinConnector2).JoinedConnectorsList.Count = 0 then GetConn := TConnectorObject(Line.JoinConnector2) else GetConn := TConnectorObject(TConnectorObject(Line.JoinConnector2).JoinedConnectorsList[0]); if GetConn <> nil then begin a3DPointArr[1].x := GetConn.ActualPoints[1].x; a3DPointArr[1].y := GetConn.ActualPoints[1].y; end; end; aFace := TFaceRecord.Create(a3DPointArr, clBlack, ftLine, 0.1, False, self); Faces.Add(aFace); end; // Tolik 24/05/2019 -- SetLength(a3DPointArr, 0); // end; // TSCSFIGUREGRP if (Self.ClassName = 'TSCSFigureGrp') then begin for j := 0 to TSCSFigureGrp(Self).InFigures.Count - 1 do begin InFigure := Tfigure(TSCSFigureGrp(Self).InFigures[j]); if (InFigure.ClassName = 'TConnectorObject') or (InFigure.ClassName = 'TOrthoLine') then begin // a3DPointArr := T3DPointArray(InFigure.actuals); SetLength(a3DPointArr, length(InFigure.actuals)); for i := 0 to length(InFigure.actuals) - 1 do a3DPointArr[i] := InFigure.actuals[i]; // CONNECTOR if (InFigure.ClassName = 'TConnectorObject') then begin if (TConnectorObject(InFigure).ConnectorType <> ct_Clear) or (TConnectorObject(InFigure).Name = 'Anchor') then begin for i := 0 to high(a3DPointArr) do a3DPointArr[i].z := TConnectorObject(InFigure).ActualZOrder[i + 1] * ScaleDelta; aFace := TFaceRecord.Create(a3DPointArr, clRed, ftPipe, 0.1, False, InFigure); Faces.Add(aFace); end; end else // ORTHOLINE begin for i := 0 to high(a3DPointArr) do a3DPointArr[i].z := TOrthoLine(InFigure).ActualZOrder[i + 1] * ScaleDelta; Line := TOrthoLine(InFigure); // переназначить первую сторону if Line.JoinConnector1 <> nil then begin if TConnectorObject(Line.JoinConnector1).JoinedConnectorsList.Count = 0 then GetConn := TConnectorObject(Line.JoinConnector1) else GetConn := TConnectorObject(TConnectorObject(Line.JoinConnector1).JoinedConnectorsList[0]); if GetConn <> nil then begin a3DPointArr[0].x := GetConn.ActualPoints[1].x; a3DPointArr[0].y := GetConn.ActualPoints[1].y; end; end; // переназначить вторую сторону if Line.JoinConnector2 <> nil then begin if TConnectorObject(Line.JoinConnector2).JoinedConnectorsList.Count = 0 then GetConn := TConnectorObject(Line.JoinConnector2) else GetConn := TConnectorObject(TConnectorObject(Line.JoinConnector2).JoinedConnectorsList[0]); if GetConn <> nil then begin a3DPointArr[1].x := GetConn.ActualPoints[1].x; a3DPointArr[1].y := GetConn.ActualPoints[1].y; end; end; aFace := TFaceRecord.Create(a3DPointArr, clBlack, ftLine, 0.1, False, InFigure); Faces.Add(aFace); end; // Tolik 24/05/2019 -- SetLength(a3DPointArr, 0); // end; end; end; // // if (self.ClassName = 'TBMPObject') then // begin // a3DPointArr := T3DPointArray(self.actuals); // for i := 0 to high(a3DPointArr) do // a3DPointArr[i].z := 0; // aFace := TFaceRecord.Create(a3DPointArr, clBlack, ftPicture, 0.1, False, self); // Faces.Add(aFace); // end; (* if (self.ClassName <> 'TBlock') and (self.ClassName <> 'TFigureGrpMod') and (self.ClassName <> 'TFigureGrpNotMod') then begin a3DPointArr := T3DPointArray(self.actuals); if (self.ClassName = 'TConnectorObject') or (self.ClassName = 'TOrthoLine') then begin for i := 0 to high(a3DPointArr) do a3DPointArr[i].z := TOrthoLine(self).ActualZOrder[i + 1] * 100 ; end; if (self.ClassName = 'TConnectorObject') then begin aFace := TFaceRecord.Create(a3DPointArr, clBlack, ftPipe); end else aFace := TFaceRecord.Create(a3DPointArr, clBlack, ftLine); Faces.Add(aFace); end; *) end; procedure TFigure.DrawRotTrace(DEngine: TPCDrawEngine;isGrayed:Boolean); var x,y,z: Double; r:HRGN; begin DEngine.Canvas.pen.mode := pmXor; x := RotPoint.x; y := RotPoint.y; z := 0; DEngine.convertPoint(x,y,z); r := 1; Dengine.DrawCirclePix(Round(x),Round(y),PointDim+3,clLime,1,ord(psSolid),0,ord(bsClear),r); Dengine.DrawCirclePix(Round(x),Round(y),PointDim,clLime,1,ord(psSolid),clLime,ord(bsSolid),r); Draw(DEngine,isGrayed); end; procedure TFigure.getRotatePoints(ModList: TList); var CControl: TPCDrawing; figMaxX, figMaxY, figMinX,figMinY:Double; p1,p2,p3,p4,p5: TDoublePoint; a: integer; begin CControl :=TPCDrawing(Owner); getbounds(figMaxX,figMaxY,figMinX,figMinY); p1 := DoublePoint(figMinX,figMinY); p2 := DoublePoint(figMaxX,figMinY); p3 := DoublePoint(figMaxX,figMaxY); p4 := DoublePoint(figMinX,figMaxY); ModList.Add(CControl.RegisterModPoint(self,ptRotPoint,ptCircle,clGreen,pointdim,p1.x,p1.y,1)); ModList.Add(CControl.RegisterModPoint(self,ptRotPoint,ptCircle,clGreen,pointdim,p2.x,p2.y,2)); ModList.Add(CControl.RegisterModPoint(self,ptRotPoint,ptCircle,clGreen,pointdim,p3.x,p3.y,3)); ModList.Add(CControl.RegisterModPoint(self,ptRotPoint,ptCircle,clGreen,pointdim,p4.x,p4.y,4)); ModList.Add(CControl.RegisterModPoint(self,ptRotCenter,ptRCenter,clRed,pointdim,RotPoint.x,RotPoint.y,5)); end; procedure TFigure.getModPoints(ModList: TMyList); var CControl: TPCDrawing; MT,MR,MB,ML : TDoublePoint; a: integer; begin CControl :=TPCDrawing(Owner); case ShadowType of stLine: begin ModList.Add(CControl.RegisterModPoint(Self,ptLineEnd,ptRect,clBlue, pointDim,ap1.x,ap1.y,1)); ModList.Add(CControl.RegisterModPoint(Self,ptLineEnd,ptRect,clBlue, pointDim,ap2.x,ap2.y,2)); end; stRectangle: begin MT := MPoint(ap1,ap2); MR := MPoint(ap2,ap3); MB := MPoint(ap3,ap4); ML := MPoint(ap4,ap1); ModList.Add(CControl.RegisterModPoint(self,ptRectPoint,ptRect,clBlue,PointDim,ap1.x,ap1.y,1)); ModList.Add(CControl.RegisterModPoint(self,ptRectPoint,ptRect,clBlue,PointDim,ap2.x,ap2.y,3)); ModList.Add(CControl.RegisterModPoint(self,ptRectPoint,ptRect,clBlue,PointDim,ap3.x,ap3.y,5)); ModList.Add(CControl.RegisterModPoint(self,ptRectPoint,ptRect,clBlue,PointDim,ap4.x,ap4.y,7)); if not fDiagonal then begin ModList.Add(CControl.RegisterModPoint(self,ptRectPoint,ptRect,clBlue,PointDim,MT.x,MT.y,2)); ModList.Add(CControl.RegisterModPoint(self,ptRectPoint,ptRect,clBlue,PointDim,MR.x,MR.y,4)); ModList.Add(CControl.RegisterModPoint(self,ptRectPoint,ptRect,clBlue,PointDim,MB.x,MB.y,6)); ModList.Add(CControl.RegisterModPoint(self,ptRectPoint,ptRect,clBlue,PointDim,ML.x,ML.y,8)); end; end; stCircle: begin ModList.Add(CControl.RegisterModPoint(self,ptCirclePoint,ptRect,clBlue,pointdim,ap1.x,ap1.y + radius,0)); ModList.Add(CControl.RegisterModPoint(self,ptCirclePoint,ptRect,clBlue,pointdim,ap1.x,ap1.y - radius,0)); ModList.Add(CControl.RegisterModPoint(self,ptCirclePoint,ptRect,clBlue,pointdim,ap1.x+radius,ap1.y,0)); ModList.Add(CControl.RegisterModPoint(self,ptCirclePoint,ptRect,clBlue,pointdim,ap1.x-radius,ap1.y,0)); end; end; end; procedure TFigure.getbounds(var figMaxX,figMaxY,figMinX,figMinY: Double); var a: integer; p1, p2: TDoublePoint; ap: TDoublePoint; begin {//16.03.2012 case ShadowType of stLine: begin if ap1.x > ap2.x then begin figMaxX := ap1.x;figMinX := ap2.x; end else begin figMaxX := ap2.x;figMinX := ap1.x; end; if ap1.y > ap2.y then begin figMaxY := ap1.y;figMinY := ap2.y; end else begin figMaxY := ap2.y; figMinY := ap1.y; end; end; stRectangle: begin figMaxX := ap1.x; figMinX := ap1.x; figMaxY := ap1.y; figMinY := ap1.y; For a := 1 to 4 do begin if actualpoints[a].x > figMaxX then figMaxX := actualpoints[a].x; if actualpoints[a].x < figMinX then figMinX := actualpoints[a].x; if actualpoints[a].y > figMaxY then figMaxY := actualpoints[a].y; if actualpoints[a].y < figMinY then figMinY := actualpoints[a].y; end; end; stCircle: begin figMaxX := ap1.x+radius; figMinX := ap1.x-radius; figMaxY := ap1.y+radius; figMinY := ap1.y-radius; end; end;} case ShadowType of stLine: begin p1 := ap1; p2 := ap2; if p1.x > p2.x then begin figMaxX := p1.x; figMinX := p2.x; end else begin figMaxX := p2.x; figMinX := p1.x; end; if p1.y > p2.y then begin figMaxY := p1.y; figMinY := p2.y; end else begin figMaxY := p2.y; figMinY := p1.y; end; end; stRectangle: begin p1 := ap1; figMaxX := p1.x; figMinX := p1.x; figMaxY := p1.y; figMinY := p1.y; For a := 1 to 4 do begin ap := actualpoints[a]; if ap.x > figMaxX then figMaxX := ap.x; if ap.x < figMinX then figMinX := ap.x; if ap.y > figMaxY then figMaxY := ap.y; if ap.y < figMinY then figMinY := ap.y; end; end; stCircle: begin p1 := ap1; figMaxX := p1.x+radius; figMinX := p1.x-radius; figMaxY := p1.y+radius; figMinY := p1.y-radius; end; end; end; function TFigure.getboundRect: TDoubleRect; var figMaxX,figMaxY,figMinX,figMinY: Double; begin getbounds(figMaxX,figMaxY,figMinX,figMinY); //result := Rect(figMinX,figMaxY,figMaxX,FigMinY); result := DoubleRect(figMinX,figMinY,figMaxX,FigMaxY); end; function TFigure.GetBoundRect(UseGRpSize: boolean): TDoubleRect; var figMaxX,figMaxY,figMinX,figMinY: Double; FigLayerHandle: LongInt; begin FigLayerHandle := -1; if not UseGRpSize then begin // Tolik 24/10/2017 -- на всякий if assigned(Self.Owner) then begin FigLayerHandle := LongInt(TPowerCad(Self.Owner).Layers[2]); end; if Self.LayerHandle <> FigLayerHandle then UseGRpSize := true; // end; if UseGRpSize then //на всяк случай пускай бедет getbounds(figMaxX,figMaxY,figMinX,figMinY) else getboundsWithoutGrpSize(figMaxX,figMaxY,figMinX,figMinY); result := DoubleRect(figMinX,figMinY,figMaxX,FigMaxY); end; procedure TFigure.GetRegionBounds(var figMaxX, figMaxY, figMinX, figMinY: Double); var rx: Trect; r: TDoubleRect; CControl:TPCdrawing; z: Double; //Tolik CanGetBounds: Boolean; begin // Tolik CanGetBounds := False; if RegHandle = 0 then begin if RegObject <> nil then begin CanGetBounds := GetRegionBox(rx) > 0; end; end else CanGetBounds := GetRgnBox(RegHandle,rx) <> 0; //if GetRgnBox(RegHandle,rx) <> 0 then // if CanGetBounds then begin if owner <> nil then begin r := DoubleRect(rx.left,rx.top,rx.right,rx.bottom); CControl := TPCDrawing(Owner); z := 0; CControl.DEngine.DeConvertPoint(r.left,r.top,z); CControl.DEngine.DeConvertPoint(r.right,r.bottom,z); if r.left > r.right then begin figMaxX := r.Left; figMinX := r.Right; end else begin figMinX := r.Left; figMaxX := r.Right; end; if r.bottom > r.top then begin figMaxY:= r.bottom; figMinY := r.top; end else begin figMinY := r.bottom; figMaxY := r.top; end; end; end; end; procedure TFigure.getRegionPoints(var points: array of TDoublePoint); begin end; function TFigure.isPointIn(x,y:Double): boolean; var //apoint : TDoublePoint; a: integer; nx,ny,z: Double; ctrl: Double; ap,p1,p2,p3,p4: TDoublePoint; DEngine: TPCDrawEngine; result1 : Boolean; begin result := false; // Tolik 28/08/2019 -- //apoint := DoublePoint(x,y); ap := aPoint; ap := DoublePoint(x,y); ap.z := 0; // p1 := ap1; p2 := ap2; p3 := ap3; p4 := ap4; if assigned(Owner) then begin z:= 0; DEngine := TPCDrawing(Owner).DEngine; DEngine.ConvertPoint(ap.x,ap.y,z); DEngine.ConvertPoint(p1.x,p1.y,z); DEngine.ConvertPoint(p2.x,p2.y,z); DEngine.ConvertPoint(p3.x,p3.y,z); DEngine.ConvertPoint(p4.x,p4.y,z); end; if FullHitTest then begin // if isPointInRegion(x,y) then result := true; //Tolik if IsPointInRegionByRegObj(x,y) then result := true; // if result then exit; end; case ShadowType of stLine: begin if ispointinLine(p1,p2,ap,width) then result := true; end; stRectangle: begin if ( ispointinLine(p1,p2,ap,width) or ispointinLine(p2,p3,ap,width) or ispointinLine(p3,p4,ap,width) or ispointinLine(p4,p1,ap,width) ) then begin result := true; exit; end; if TBrushStyle(brs) <> bsClear then begin //result := isPointInRegion(x,y); //Tolik result := IsPointInRegionByRegObj(x,y); // end; end; stCircle: begin nx := x-ap1.x; ny := y-ap1.y; if (radius = 0) then exit; ctrl := ((nx*nx)/(radius*radius))+((ny*ny)/(radius*radius)); if (ctrl < 1.1) and (ctrl > 0.9) then result := true; if TBrushStyle(brs) <> bsClear then begin //if isPointInRegion(x,y) then result := true; //Tolik if IsPointInRegionByRegObj(x,y) then result := true; // end; end; end; end; function TFigure.isPointInRegion(x, y: Double): Boolean; var CCOntrol:TPCDrawing; z : Double; isPoint: Integer; begin result := false; if owner <> nil then begin CControl := TPCDrawing(Owner); z := 0; CControl.DEngine.ConvertPoint(X,Y,z); //Tolik // if ptInRegion(RegHandle,Round(x),Round(y)) then result := true; if RegObject = nil then begin if RegHandle <> 0 then begin GetRegObject; if RegObject <> nil then begin if TBrushStyle(brs) <> bsClear then RegObject.CheckPointByRects := true; DeleteObject(RegHandle); RegHandle := 0; end; end; end; if RegObject <> nil then begin result := IsPointInRegionByRegObj(Round(x),Round(y)); end else // перебор, но, на всякий....а то хз... if RegHandle <> 0 then result := PtInRegion(RegHandle, Round(x), Round(y)); end; end; function TFigure.IsPointInRegion(x, y: Double; reg: Integer): Boolean; var CCOntrol:TPCDrawing; z: Double; begin result := false; if owner <> nil then begin CControl := TPCDrawing(Owner); z := 0; CControl.DEngine.ConvertPoint(X,Y,Z); //if ptInRegion(reg,Round(x),Round(y)) then result := true; //Tolik if IsPointInRegionByRegObj(Round(x),Round(y)) then result := true; // end; end; Function TFigure.CheckifInArea(area: TDoubleRect): boolean; var bound : TDoubleRect; AreaMaxX,AreaMaxY,AreaMinX,AreaMinY : Double; boundMaxX,boundMaxY,boundMinX,boundMinY : Double; begin result := false; getbounds(boundMaxX,boundMaxY,boundMinX,boundMinY); if area.left > area.right then begin areaMaxX := area.left; areaMinX := area.right; end else begin areaMaxX := area.right; areaMinX := area.left; end; if area.top > area.bottom then begin areaMaxY := area.top; areaMinY := area.bottom; end else begin areaMaxY := area.bottom; areaMinY := area.top; end; if (areaMaxX >= boundMaxX) and (areaMaxY >= boundMaxY) and (areaMinX <= boundMinX) and (areaMinY <= boundMinY) then begin result := true; end; end; //Tolik // юзает объект регион фигуры Function TFigure.IsPointInRegionByRegObj(x, y: Double): Boolean; begin result := ptInRegionByRegObj(x, y, Self.RegObject); end; // юзает объет регион хер какой фигуры Function TFigure.IsPointInRegionByRegObj(x, y: Double; RegObj: TRegionObject): Boolean; begin result := ptInRegionByRegObj(x, y, RegObj); end; function TFigure.ptInRegionByRegObj(x,y: Double; RegObj: TRegionObject): Boolean; var a, i: Integer; p: TDoublePoint; z: Double; CControl: TPCDrawing; RectArray: array of TDoubleRect; Rect: PRect; nx, ny, ctrl: double; ap,p1,p2,p3,p4: TDoublePoint; apoint : TDoublePoint; pp: Pbyte; //pp: PAnsiChar; function PointInPOlygonByPoints(x,y: Double): Integer; var i, j, cnt: Integer; d, d2, d3: double; ip, ipNext: TDoublePoint; begin result := 0; cnt := TFigure(RegObj.RegObjOwner).PointCount + 1; if cnt < 3 then Exit; ip := TFigure(RegObj.RegObjOwner).FigurePoints[1]; for i := 2 to cnt do begin if i < cnt then ipNext := TFigure(RegObj.RegObjOwner).FigurePoints[i] else ipNext := TFigure(RegObj.RegObjOwner).FigurePoints[1]; if (ipNext.Y = Y) then begin if (ipNext.X = X) or ((ip.Y = Y) and ((ipNext.X > X) = (ip.X < X))) then begin result := -1; Exit; end; end; if ((ip.Y < Y) <> (ipNext.Y < Y)) then begin if (ip.X >= X) then begin if (ipNext.X > X) then result := 1 - result else begin d2 := (ip.X - X); d3 := (ipNext.X - X); d := d2 * (ipNext.Y - Y) - d3 * (ip.Y - Y); if (d = 0) then begin result := -1; Exit; end; if ((d > 0) = (ipNext.Y > ip.Y)) then result := 1 - result; end; end else begin if (ipNext.X > X) then begin d2 := (ip.X - X); d3 := (ipNext.X - X); d := d2 * (ipNext.Y - Y) - d3 * (ip.Y - Y); if (d = 0) then begin result := -1; Exit; end; if ((d > 0) = (ipNext.Y > ip.Y)) then result := 1 - result; end; end; end; ip := ipNext; end; end; function PointInPolygonByRects(x,y: Double): boolean; var i, j: Integer; ip: TDoublePoint; z: double; // CControl: TPCDrawing; begin result := false; j := Length(RectArray) - 1; ip.x := x; ip.y := y; z := 0; if RegObj.RegObjData^.rdh.nCount > 0 then // Tolik 29/08/2019 -- begin j := RegObj.RegObjData^.rdh.nCount - 1; rect := Prect(@RegObj.RegObjData^.buffer); // Tolik 24/11/2019 -- здесь начинаются прямоугольники for i := 0 to j do begin {if PointInRect(ip, RectArray[i]) then begin Result := True; break; end;} // 24/11/2019 -- //rect := @RegObj.RegObjData^.buffer[i*Sizeof(TRect)]; // if PointInRect(ip, DoubleRect(Rect^.Left,Rect^.Top, Rect^.Right,Rect^.Bottom)) then begin Result := True; break; end; inc(rect,1); end; end; end; begin result := False; if RegObject = nil then EXIT; if RegObj.RegObjData <> nil then begin // all the rectangles of Region if RegObj.RegObjData^.rdh.iType = 1 {RDH_RECTANGLES другого, вроде как и не бывает ...} then begin //SetLength(RectArray, PRgnData(Data)^.rdh.nCount); { for i := 0 to PRgnData(Data)^.rdh.nCount - 1 do begin rect := @PRgnData(Data)^.buffer[i*Sizeof(TRect)]; //RectArray[i] := Rect^; RectArray[i].Top := Rect^.Top; RectArray[i].Bottom := Rect^.Bottom; RectArray[i].Left := Rect^.Left; RectArray[i].Right := Rect^.Right; end;} end; if RegObj.CheckPointByRects then begin if Owner <> nil then begin CControl := TPCDrawing(Owner); p.x := x; p.y := y; z := 0; CControl.DEngine.ConvertPoint(p.X,p.Y, z); Result := PointInPolygonByRects(p.x,p.y); end; end else begin i := PointInPOlygonByPoints(x,y); if i <> 0 then result := True; end; end; // по контурам { var apoint : TDoublePoint; a: integer; nx,ny,z: Double; ctrl: Double; ap,p1,p2,p3,p4: TDoublePoint; DEngine: TPCDrawEngine; result1 : Boolean; begin result := false; apoint := DoublePoint(x,y); ap := aPoint; p1 := ap1; p2 := ap2; p3 := ap3; p4 := ap4; if assigned(Owner) then begin z:= 0; DEngine := TPCDrawing(Owner).DEngine; DEngine.ConvertPoint(ap.x,ap.y,z); DEngine.ConvertPoint(p1.x,p1.y,z); DEngine.ConvertPoint(p2.x,p2.y,z); DEngine.ConvertPoint(p3.x,p3.y,z); DEngine.ConvertPoint(p4.x,p4.y,z); end; } if not Result then begin apoint := DoublePoint(x,y); ap := aPoint; p1 := ap1; p2 := ap2; p3 := ap3; p4 := ap4; if assigned(Owner) then begin z:= 0; CControl := TPCDrawing(Owner); CControl.DEngine.ConvertPoint(ap.x,ap.y,z); CControl.DEngine.ConvertPoint(p1.x,p1.y,z); CControl.DEngine.ConvertPoint(p2.x,p2.y,z); CControl.DEngine.ConvertPoint(p3.x,p3.y,z); CControl.DEngine.ConvertPoint(p4.x,p4.y,z); end; case ShadowType of stLine: begin if ispointinLine(p1,p2,ap,width) then result := true; end; stRectangle: begin if ( ispointinLine(p1,p2,ap,width) or ispointinLine(p2,p3,ap,width) or ispointinLine(p3,p4,ap,width) or ispointinLine(p4,p1,ap,width) ) then begin result := true; exit; end; end; stCircle: begin nx := x-ap1.x; ny := y-ap1.y; if (radius = 0) then exit; ctrl := ((nx*nx)/(radius*radius))+((ny*ny)/(radius*radius)); if (ctrl < 1.1) and (ctrl > 0.9) then result := true; end; end; end; end; Function TFigure.GetRegionBox(var r: TRect): Integer; var rect: PRect; begin Result := 0; if RegObject <> nil then begin rect := @RegObject.RegObjData.Rdh.rcBound; r := rect^; Result := 1; end; end; Procedure TFigure.ResetRegObject; begin if RegObject <> nil then begin if RegObject.RegObjData <> nil then begin GlobalFreePtr(RegObject.RegObjData); RegObject.RegObjData := nil; end; FreeAndNil(regObject); end; end; procedure TFigure.GetRegObject; begin if RegObject = nil then RegObject := TRegionObject.Create(Self); if RegHandle <> 0 then RegObject.GetRegData(RegHandle); end; // Function TFigure.duplicate: TFigure; var fStream:TMemoryStream; begin result := nil; fStream := TMemoryStream.Create; Self.WriteToStream(fStream); fStream.Position := 0; result := TFigure.CreateFromStream(fStream,LayerHandle,mydsNormal,Owner); fStream.Free; end; procedure TFigure.CopyProperties(Figure: TFigure); var a: integer; begin Figure.LayerHandle := LayerHandle; Figure.AngletoPoint := AngleToPoint; Figure.Angle := Angle; Figure.PointCount := PointCount; Figure.Width := Width; Figure.Color := Color; Figure.Style := Style; For a := 1 to PointCount do begin Figure.ActualPoints[a] := ActualPoints[a]; Figure.OriginalPoints[a] := OriginalPoints[a]; end; end; procedure TFigure.ClearPoints; begin SetLength(originals,0); SetLength(actuals,0); PointCount := 0; end; procedure TFigure.RedimenPoints; begin SetLength(originals,PointCount); SetLength(actuals,PointCount); end; destructor TFigure.Destroy; var a : integer; begin try // Tolik 29/04/2021 -- если идет закрытие када - нех там деселектить .... //deselect; if Assigned(Owner) then if assigned(Owner.Owner) then if not TF_Cad(Owner.Owner).FCadClose then deselect; // SelPoints.Clear; SelPoints.Free; // //selpoints.Destroy; //deleteobject(RegHandle); SetLength(originals, 0); SetLength(actuals, 0); ClearBounds; //Tolik 24/03/2017 -- TracePoint нигде явно не создается, а будет присваиваться из списка ModPoints PCada // поэтому уничтожать его здесь не нужно и неправильно {if TracePoint <> nil then FreeAndNil(TracePoint);} // // JoinedFigures.destroy; if JoinedFigures <> nil then begin JoinedFigures.Clear; FreeAndNil(JoinedFigures); end; //JoinedFigures.Clear; // if assigned(CustomStream) then CustomStream.Free; ClearDimLines; DimLines.Clear; DimLines.Free; if assigned(Fill) then Fill.Free; //Tolik ResetRegObject; // на всякий... if RegHandle <> 0 then begin DeleteObject(RegHandle); end; if Icon <> nil then begin Icon.FreeImage; end; SetLength(FTempPoints, 0); // ClearClipFigures; ClipFigures.Free; //Tolik if Assigned(data) then begin FreeMem(data); data := nil; end; // inherited; except // on E: Exception do AddExceptionToLog('TFigure.Destroy (DrawObject)' + E.Message); end; // FClassIndex := 0; end; Procedure TFigure.ClearBounds; var ln: TLine; pln: TPolyLine; f: Tfigure; i: Integer; begin if Self is TLine then begin ln := TLine(self); if assigned(ln.JoinFigure1) then ln.JoinFigure1.JoinedFigures.Remove(self); if assigned(ln.JoinFigure2) then ln.JoinFigure2.JoinedFigures.Remove(self); end else if Self is TPolyLine then begin pln := TPolyLine(self); if assigned(pln.JoinFigure1) then pln.JoinFigure1.JoinedFigures.Remove(self); if assigned(pln.JoinFigure2) then pln.JoinFigure2.JoinedFigures.Remove(self); end; for i := 0 to JoinedFigures.Count - 1 do begin f := TFigure(JoinedFigures[i]); if f is TLine then begin ln := TLine(f); if ln.Joinfigure1 = Self then ln.JoinFigure1 := nil; if ln.Joinfigure2 = Self then ln.JoinFigure2 := nil; end else if f is TPolyLine then begin pln := TPolyLine(f); if pln.Joinfigure1 = Self then pln.JoinFigure1 := nil; if pln.Joinfigure2 = Self then pln.JoinFigure2 := nil; end; end; end; procedure TFigure.UpdateMenu(var popMenu: TPopUpMenu; var sIndex: Integer); begin end; procedure TFigure.MenuClicked(commandID:integer); begin end; procedure TFigure.OnNewPoint; begin end; procedure TFigure.OnFigureModified; begin // Tolik 30/11/2015 if not Modified then begin // if DimLines.Count > 0 then CreateDimLines; if assigned(Owner) then begin if assigned(TPCDrawing(Owner).OnFigureModify) then TPCDrawing(Owner).OnFigureModify(Owner,Self); end; end; end; (* ========================================================================== *) // TLINE IMPLEMENTATION // (* ========================================================================== *) constructor Tline.create( aX1,aY1,aX2,aY2: Double; w,s,c:integer;row: integer; LHandle: LongInt; aDrawStyle:TDrawStyle;aOwner: TComponent); begin inherited create(LHandle,aDrawStyle,aOwner); initialize; RowStyle := row; originalpoints[1] := DoublePoint(ax1,ay1); originalpoints[2] := DoublePoint(ax2,ay2); actualpoints[1] := DoublePoint(ax1,ay1); actualpoints[2] := DoublePoint(ax2,ay2); width := w; color := c; style := s; end; //Tolik destructor TLine.destroy; begin inherited; end; class function TLine.ShadowType:TShadowType; begin Result := stLine; end; procedure TLine.Initialize; begin inherited; pointcount := 2; JoinFigure1 := nil; JoinFigure2 := nil; rowL := 3.5; rowH := 1.2; RowWhite := False; KeepAngle := False; EndMod := False; end; function TLine.ShadowClick(ClickIndex:Integer;x,y: Double): Boolean; begin result := false; if clickIndex = 2 then begin ActualPoints[2] := DoublePoint(x,y); Result := True; end; end; function TLine.ShadowTrace(ClickIndex: Integer; x, y:Double): Boolean; var oAngle,Angle,delta,step: Double; stepCnt,i:Integer; p: TDoublePoint; begin if clickIndex = 1 then begin (* p := DoublePoint(x,y); Angle := GetRadOfLine(ap1,p); delta := pi*15/180; // the snap distance angle step := pi/4; //0 45 90 135 180 215 270 315 160 // for more acc change the step value ex:step := pi/18; stepCnt := Trunc(2*pi/step); oAngle := angle; for i := 0 to StepCnt do begin if abs(angle-(i*step)) nil then jf.JoinedFigures.Add(self); end; procedure TLine.SetJFigure2(jf: TFigure); begin if jf = JoinFigure2 then exit; if jf = nil then JoinFigure2.JoinedFigures.Remove(self); JoinFigure2 := jf; if jf <> nil then jf.JoinedFigures.Add(self); end; procedure TLine.JoinFigureMoved(Sender: TFigure; dx, dy: double); begin if (inMoveList) and ((JoinFigure1 = nil) or (JoinFigure2 = nil)) then exit; if sender = JoinFigure1 then ActualPoints[1] := DoublePoint(ActualPoints[1].x + dx ,ActualPoints[1].y + dy) else if sender = JoinFigure2 then ActualPoints[2] := DoublePoint(ActualPoints[2].x + dx ,ActualPoints[2].y + dy); end; procedure TLine.UnBound; begin SetJFigure1(nil); SetJFigure2(nil); end; Procedure TLine.SetPropertyFromStream(xCode:Byte;data:pointer;size:integer); var ByteVal: Byte; begin Case xcode of 220: rowH := pDouble(data)^; 221: rowL := pDouble(data)^; end; end; procedure TLine.WriteToStream(Stream: TStream); var xdbl: Double; begin inherited; xDbl := RowH; WriteField(220,Stream,xDbl,8); xDbl := RowL; WriteField(221,Stream,xDbl,8); end; procedure Tline.draw(DEngine: TPCDrawEngine;isGrayed:Boolean); //const // FlatPenStyle = PS_DashDot; var acolor : Tcolor; // LogBrush: TLOGBRUSH; aawidth: integer; begin aawidth := width; if width > 1 then begin if TPCDrawing(owner).ZoomScale < 100 then begin aawidth := Trunc(width * (TPCDrawing(owner).ZoomScale / 100)); if aawidth = 0 then aawidth := 1; end; end; aColor := Color; if (aColor = -255) and (LayerHandle <> 0) then begin aColor := TLayer(LayerHandle).PenColor; end; if isGrayed then acolor := TPCDrawing(Owner).FGrayedColor; //06.08.2012 GrayedColor; if DrawStyle = dsTrace then DEngine.Canvas.pen.mode := pmXor else DEngine.canvas.pen.mode := pmCopy; // LogBrush.lbStyle := BS_Solid; // LogBrush.lbColor := aColor; // LogBrush.lbHatch := 0; // DEngine.canvas.pen.Handle := ExtCreatePen(FlatPenStyle, Width, LogBrush, 0, nil); DEngine.drawline(ap1.x,ap1.y,ap2.x,ap2.y,acolor, aawidth,style,ord(RowStyle),rowL,rowH,rowWhite); end; procedure TLine.DrawFigureGuides(DEngine: TPCDrawEngine); begin inherited; if DrawStyle = dsTrace then DEngine.Canvas.pen.mode := pmXor else DEngine.canvas.pen.mode := pmCopy; if JoinFigure1 <> nil then DEngine.drawselectionpoint(ap1.x,ap1.y,ap1.z,ptCross,pointdim,clRed); if JoinFigure2 <> nil then DEngine.drawselectionpoint(ap2.x,ap2.y,ap1.z,ptCross,pointdim,clRed); end; procedure Tline.getModPoints(ModList: TMyList); var CControl: TPCDrawing; begin CControl :=TPCDrawing(Owner); if not EndMod then ModList.Add(CControl.RegisterModPoint(Self,ptLineEnd,ptRect,clBlue,pointDim,ap1.x,ap1.y,1)); ModList.Add(CControl.RegisterModPoint(Self,ptLineEnd,ptRect,clBlue,pointDim,ap2.x,ap2.y,2)); end; procedure TLine.getbounds(var figMaxX,figMaxY,figMinX,figMinY: double); var p1, p2: TDoublePoint; begin { //16.03.2012 if ap1.x > ap2.x then begin figMaxX := ap1.x; figMinX := ap2.x; end else begin figMaxX := ap2.x; figMinX := ap1.x; end; if ap1.y > ap2.y then begin figMaxY := ap1.y; figMinY := ap2.y; end else begin figMaxY := ap2.y; figMinY := ap1.y; end;} p1 := GetActual(1); p2 := GetActual(2); if p1.x > p2.x then begin figMaxX := p1.x; figMinX := p2.x; end else begin figMaxX := p2.x; figMinX := p1.x; end; if p1.y > p2.y then begin figMaxY := p1.y; figMinY := p2.y; end else begin figMaxY := p2.y; figMinY := p1.y; end; end; function Tline.isPointIn(x,y:double): boolean; var apoint,p1,p2: TDoublepoint; DEngine: TPCDrawEngine; z: Double; begin result := false; result := inherited isPointIn(x,y); if result then exit; apoint := DoublePoint(x,y); p1 := ap1; p2 := ap2; if assigned(Owner) then begin DEngine := TPCDrawing(Owner).DEngine; z := 0; DEngine.ConvertPoint(apoint.x,apoint.y,z); DEngine.ConvertPoint(p1.x,p1.y,z); DEngine.ConvertPoint(p2.x,p2.y,z); end; if ispointinLine(p1,p2,apoint,width) then result := true; end; function TLine.DuplicateAsBezier: TFigure; var points: TDoublePointArr; cp1,cp2: TDoublePoint; begin SetLength(Points,4); cp1 := MPoint(ap1,ap2); cp1 := MPoint(ap1,cp1); cp2 := MPoint(ap1,ap2); cp2 := MPoint(ap2,cp2); points[0] := ap1; points[1] := cp1; points[2] := cp2; points[3] := ap2; result := TPolyline.CreateFromBezierPoints(points,width,style,color, 0,0,rowStyle,false,LayerHandle,mydsNormal,owner); SetLength(Points,0); end; function Tline.duplicate: TFigure; var res : TLine; begin res := Tline.create( originalpoints[1].x, originalpoints[1].y, originalpoints[2].x, originalpoints[2].y, width, style, color, RowStyle, LayerHandle, DrawStyle,Owner); res.angle := angle; res.actualpoints[1] := actualpoints[1]; res.actualpoints[2] := actualpoints[2]; res.actualpoints[1] := actualpoints[1]; res.actualpoints[2] := actualpoints[2]; res.rotpoint.x := rotpoint.x ; res.rotpoint.y := rotpoint.y ; res.AngleToPoint := AngleToPoint; res.RowH := RowH; res.RowL := RowL; result := res; end; function TLine.BreakByPoint(p: TdoublePoint; var Figures: TList): boolean; var fig: Tfigure; begin result := false; if isPointIn(p.x,p.y) then begin fig := TLine.create(ap1.x,ap1.y,p.x,p.y,width,style,color, rowStyle,LayerHandle,mydsNormal,Owner); Figures.Add(fig); fig := TLine.create(p.x,p.y,ap2.x,ap2.y,width,style,color, rowStyle,LayerHandle,mydsNormal,Owner); Figures.Add(fig); result := true; end; end; function TLine.GetLinearInterSections(p1, p2: TDoublePoint; var pArr: TDoublePointArr): Boolean; var p: TDoublePoint; begin result := false; if GetInterSectionPoint(ap1,ap2,p1,p2,p,False) then begin SetLength(pArr,1); pArr[0] := p; result := true; end; end; procedure TLine.GetVectorObjects(Objects: Tlist;BaseP: TDoublePoint); var obj: TvectorObject; p1,p2: TDoublePoint; begin p1 := ap1; p2 := ap2; p1 := DoublePoint(p1.x-baseP.x,p1.y-baseP.y); p2 := DoublePoint(p2.x-baseP.x,p2.y-baseP.y); obj := TVectorObject.CreateLineObject(p1,p2); Objects.Add(obj); end; (* ========================================================================== *) // TVertex IMPLEMENTATION // (* ========================================================================== *) constructor TVertex.create(aX,aY:Double; LHandle:LongInt; aDrawStyle: TDrawStyle;aOwner: TComponent); begin inherited create(LHandle,aDrawStyle,aOwner); initialize; originalpoints[1] := DoublePoint(ax,ay); actualpoints[1] := DoublePoint(ax,ay); end; procedure TVertex.Initialize; begin inherited; PointCount := 1; end; function TVertex.CreateModification: TFigure; begin Result := TVertex.create(ap1.x,ap1.y,0,dsTrace,nil); if assigned(Result) then Result.RotPoint := RotPoint; end; class function TVertex.CreateShadow(x,y: Double): TFigure; begin CreateShadow := TVertex.create(x,y,0,dsTrace,nil); end; function TVertex.ShadowClick(ClickIndex:Integer;x,y:Double): Boolean; begin result := false; if clickindex = 1 then result := true; end; class function TVertex.CreateFromShadow(aOwner: TComponent; LHandle: Integer; Shadow: TFigure): TFigure; begin result := TVertex.create(shadow.ap1.x,shadow.ap1.y,LHandle,mydsNormal,aOwner); end; procedure TVertex.WriteToStream(Stream: TStream); begin inherited; end; Procedure TVertex.Draw(DEngine: TPCDrawEngine;isGrayed:Boolean); var Layer: TLayer; acolor : Tcolor; Begin aColor := clRed; if (isGrayed) then acolor := TPCDrawing(Owner).FGrayedColor; //06.08.2012 GrayedColor; if DrawStyle = dsTrace then DEngine.Canvas.pen.mode := pmXor else DEngine.canvas.pen.mode := pmCopy; Dengine.DrawPoint(ap1,clBlue); exit; DEngine.drawline( ap1.x-1,ap1.y,ap1.x+1,ap1.y,aColor,1,0,0); DEngine.drawline( ap1.x,ap1.y-1,ap1.x,ap1.y+1,aColor,1,0,0); DEngine.drawline( ap1.x-1,ap1.y-1,ap1.x+1,ap1.y+1,aColor,1,0,0); DEngine.drawline( ap1.x+1,ap1.y-1,ap1.x-1,ap1.y+1,aColor,1,0,0); End; procedure TVertex.getModPoints(ModList: TMyList); var CControl: TPCdrawing; Begin CControl := TPCDrawing(Owner); ModList.Add(CControl.RegisterModPoint(self,ptUndefined,ptCross,clBlue, pointDim,ap1.x,ap1.y,0)); End; function TVertex.isPointIn(x,y:double): boolean; Begin result := false; result := inherited isPointIn(x,y); if result then exit; if ((x < (ap1.x+1)) and ( x > (ap1.x - 1))) and ((y < (ap1.y+1)) and ( y > (ap1.y - 1))) then result := true; End; procedure TVertex.getbounds(var figMaxX,figMaxY,figMinX,figMinY:double); Begin figMaxX := ap1.x + 1; figMaxY := ap1.y + 1; figMinX := ap1.x - 1; figMinY := ap1.y - 1; End; Function TVertex.duplicate:TFigure; Begin result := TVertex.create(originalpoints[1].x, originalpoints[1].y, LayerHandle, DrawStyle,Owner); result.actualpoints[1] := actualpoints[1]; result.AngleToPoint := AngleToPoint; End; procedure TVertex.GetVectorObjects(Objects: Tlist; BaseP: TDoublePoint); var obj: TvectorObject; p1 : TDoublePoint; begin p1 := ap1; p1 := DoublePoint(p1.x-baseP.x,p1.y-baseP.y); obj := TVectorObject.CreatePointObject(p1); Objects.Add(obj); end; (* ========================================================================== *) // TPolyLine IMPLEMENTATION // (* ========================================================================== *) { TPlSegment } constructor TPlSegment.Create(aIndex: Integer; aType: TSegmentType; cp1, cp2: TDoublepoint); begin inherited create; Index := aIndex; Stype := aType; CPoint1 := cp1; CPoint2 := cp2; TangentKnot := True; Inverted:= False; end; Destructor TPlSegment.Destroy; begin inherited; end; procedure TPlSegment.SetVals(aType: TSegmentType; cp1, cp2: TDoublePoint); begin Stype := aType; CPoint1 := cp1; CPoint2 := cp2; end; Procedure TPlSegment.Move(deltax,deltay: double); begin CPoint1.x := CPoint1.x+deltax; CPoint2.x := CPoint2.x+deltax; CPoint1.y := CPoint1.y+deltay; CPoint2.y := CPoint2.y+deltay; end; Procedure TPlSegment.Rotate(aAngle: double; cPoint: TDoublePoint); begin CPoint1 := RotatePoint(cPoint,CPoint1,aAngle); CPoint2 := RotatePoint(cPoint,CPoint2,aAngle); end; Procedure TPlSegment.Mirror(Point1,Point2: TDoublePoint); begin CPoint1 := GetSymetricPoint(CPoint1,Point1,Point2); CPoint2 := GetSymetricPoint(CPoint2,Point1,Point2); inverted := not inverted; end; Procedure TPlSegment.Scale(percentx, percenty: double; rPoint: TDoublepoint); begin CPoint1 := ScalePoint(rPoint,cPoint1,percentx,percenty); CPoint2 := ScalePoint(rPoint,cPoint2,percentx,percenty); end; function TPlSegment.Duplicate: TPlSegment; begin result := TPlSegment.Create(Index,sType,Cpoint1,CPoint2); result.TangentKnot := TangentKnot; result.Inverted := Inverted; end; function TPlSegment.BreakByPoint(knot1, knot2, bp: TDoublePoint; var seg1,seg2: TPLsegment;Knifing:Boolean; kp1,kp2:TDoublePoint): Boolean; var dPoint,cp1,cp2,cp3,cp4,cp:TDoublePoint; dista,a,a1,a2,at,rad:Double; ts: Double; res: Boolean; begin result := false; case sType of sLine: begin if isPointInLine(knot1,knot2,bp,2) then begin seg1 := TPLSegment.Create(0,sLine,knot1,bp); seg1.tp1 := knot1; seg1.tp2 := bp;; seg2 := TPLSegment.Create(0,sLine,bp,knot2); seg2.tp1 := bp; seg2.tp2 := knot2; result := true; end; end; sCurve: begin if isPointInBezier(knot1,cpoint1,cpoint2,knot2,bp) then begin dPoint := bp; ts := -1; if Knifing then begin res := SubBezier(knot1,cpoint1,cpoint2,knot2,dPoint,cp1,cp2,cp3,cp4,-1,kp1,kp2); end else begin res := SubBezier(knot1,cpoint1,cpoint2,knot2,dPoint,cp1,cp2,cp3,cp4,-1); end; if res then begin seg1 := TPLSegment.Create(0,sCurve,cp1,cp2); seg1.tp1 := knot1; seg1.tp2 := dPoint; seg2 := TPLSegment.Create(0,sCurve,cp3,cp4); seg2.tp1 := dPoint; seg2.tp2 := knot2; result := true; end; end; end; sArc: begin cp := Cpoint1; rad := getLineLenght(knot1,cp); a1 := GetRadOfLine(cp,knot1); a2 := GetRadOfLine(cp,knot2); if a2 = 0 then a2 := 2*pi; if a1>a2 then distA := 2*pi - a1+a2 else distA := a2-a1; if Inverted then begin at := a1; a1 := a2; a2 := at; end; if isPointInArc(bp,cp,rad,0,a1,a2) then begin Seg1 := TPlSegment.Create(0,sArc,cp,cp); seg1.tp1 := knot1; seg1.tp2 := dPoint; Seg2 := TPlSegment.Create(0,sArc,cp,cp); seg2.tp1 := dPoint; seg2.tp2 := knot2; result := true; end; end; end; end; ////////////// constructor TPolyLine.create(Points: TDoublepointArr;w,s,c,abrs,abrc:integer; row: integer; aClosed: Boolean; LHandle:LongInt;aDrawStyle: TDrawStyle;aOwner: TComponent); var a: integer; begin inherited create(0,0,0,0,0,0,0,0,LHandle,aDrawStyle,aOwner); NeedBounds := True; //Tolik 02/08/2021 -- ClearPoints; FPointEvent := True; //initialize; // Tolik 29/07/2021 pointCount := Length(Points); RowStyle := row; SetLength(Originals, pointCount); SetLength(Actuals, pointCount); // Tolik 02/05/2019-- for a := 0 to pointCount-1 do begin // if ABS(points[a].z) <> 0 then if ABS(points[a].x) < 0.000001 then points[a].x := 0; if ABS(points[a].y) < 0.000001 then points[a].y := 0; if ABS(points[a].z) < 0.000001 then points[a].z := 0; end; // for a := 0 to pointCount-1 do begin originalpoints[a+1]:= points[a]; Actuals[a] := DoublePoint(0,0); if fPointEvent then OnNewPoint; actualpoints[a+1] := points[a]; end; width := w; color := c; style := s; brs:= abrs; brc:= abrc; closed := aClosed; end; class function TPolyline.CreateFromBezierPoints(Points: TDoublePointArr; w, s, c, abrs, abrc, row: integer; aClosed: Boolean; LHandle: Integer; aDrawStyle: TDrawStyle; aOwner: TComponent): TPolyline; var pcnt,cnt,i: Integer; p,p1,p2: TDoublePoint; pp: TDoublePointArr; res: TPolyline; segOk: boolean; begin cnt := Length(Points); pcnt := 0; for i := 0 to cnt-1 do begin p := DoublePoint(Points[i].x,Points[i].y); if (i mod 3) = 0 then begin pCnt := pCnt+1; SetLength(pp,pCnt); pp[pcnt-1] := p; end; end; if (aclosed) and (EQDP(pp[0],pp[pCnt-1])) then begin pCnt := pCnt-1; SetLength(pp,pCnt); end; res := Create(pp,w,s,c,aBrs,aBrc,row,aclosed,LHandle,aDrawStyle,aOwner); // Tolik 24/05/2019 -- SetLength(pp, 0); // res.ConvertToBezier; pCnt := 0; for i := 0 to cnt-1 do begin p := DoublePoint(Points[i].x,Points[i].y); if (i mod 3) = 1 then p1 := p; if (i mod 3) = 2 then p2 := p; segOk := False; if ((i mod 3) = 0) and (i >0) then begin pCnt := pCnt+1; res.SetControlPointsOfSegment(pCnt,p1,p2); segOk := True; end; end; if not SegOk then begin pCnt := pCnt+1; res.SetControlPointsOfSegment(pCnt,p1,p2); end; result := res; end; procedure TPolyline.Initialize; begin inherited; PointCount := 0; SelectedPoint := 1; Tracing := false; Segments := TList.Create; PenPattern := nil; BrushBitmap := nil; SetLength(HatchLines,0); HatchSeg := -1; SavedfigMaxX := -$FFFFFF; SavedfigMaxY := -$FFFFFF; SavedfigMinX := -$FFFFFF; SavedfigMinY := -$FFFFFF; SavedStateFig := ''; //NeedBounds := True; // Tolik 02/08/2021 -- end; procedure TPolyline.AssignPenPattern(MasterPattern: TPattern); begin if assigned(PenPattern) then PenPattern.Free; if assigned(MasterPattern) then Penpattern := MasterPattern.Duplicate else Penpattern := nil; end; procedure TPolyline.OnNewPoint; begin inherited; Segments.Add(TPlSegment.Create(PointCount,sLine,DoublePoint(0,0),DoublePoint(0,0))); NeedBounds := True; //Tolik 02/08/2021 -- end; procedure TPolyline.ArrangeSegment(SegNbr: integer; SegType: TSegmentType); var Seg : TPLSegment; i1,i2,i3: integer; cp1,cp2,p1,p2: TDoublePoint; mp : TDoublePoint; preSeg,postSeg: integer; mx,my: Double; rad,rad1,rad2: DOuble; begin if SegNbr = 0 then exit; Seg := Segments[SegNbr-1]; if assigned(seg) then seg.SType := SegType; if SegType = sCurve then begin i2 := SegNbr; if i2 = 1 then i1 := PointCount else i1 := i2-1; if i2 = PointCount then i3 := 1 else i3 := i2+1; if i2 = 1 then PreSeg := PointCount else preSeg := i2-1; if TPLSegment(Segments[PreSeg-1]).SType = sCurve then begin cp1 := TPLSegment(Segments[i1-1]).Cpoint2; mp := actualpoints[i2]; cp2 := RotatePoint(mp,cp1,pi); end else GenerateBezierCPoints(actualpoints[i1], actualpoints[i2], actualpoints[i3], cp1,cp2,false); Seg.CPoint1 := cp2; if SegNbr = PointCount then i2 := 1 else i2 := SegNbr+1; if i2 = 1 then i1 := PointCount else i1 := i2-1; if i2 = PointCount then i3 := 1 else i3 := i2+1; PostSeg := i2;; if TPLSegment(Segments[PostSeg-1]).SType = sCurve then begin cp2 := TPLSegment(Segments[PostSeg-1]).Cpoint1; mp := actualpoints[i2]; cp1 := RotatePoint(mp,cp2,pi); end else GenerateBezierCPoints(actualpoints[i1], actualpoints[i2], actualpoints[i3], cp1,cp2,false); Seg.CPoint2 := cp1; end else if SegType = sArc then begin //Get Prev Line if SegNbr = 1 then p1 := actualpoints[PointCount] else p1 := actualpoints[SegNbr-1]; p2 := actualpoints[SegNbr]; rad1 := getRadOfLine(p1,p2); //Get Next Line if SegNbr = PointCount then i1 := 1 else i1 := segnbr+1; p1 := actualpoints[i1]; if i1 = PointCount then i2 := 1 else i2 := i1+1; p2 := actualpoints[i2]; rad2 := getRadOfLine(p1,p2); rad := rad1-rad2; p1 := actualpoints[SegNbr]; if SegNbr = PointCount then p2 := actualpoints[1] else p2 := actualpoints[SegNbr+1]; cp1 := GetArcCenter(p1,p2,rad); Seg.CPoint1 := cp1; Seg.CPoint2 := cp1; if vertzero = 0 then seg.Inverted := true; end; ResetRegion; NeedBounds := True; //Tolik 02/08/2021 -- end; procedure TPolyline.ClearSegments; var Segment: TPlSegment; a: integer; begin try for a := 0 to Segments.Count - 1 do begin Segment := TPlSegment(Segments[a]); Segment.Free; end; Segments.Clear; except // on E: Exception do AddExceptionToLog(CPowerCadMessage + 'TPolyline.ClearSegments' + E.Message); end; NeedBounds := True; //Tolik 02/08/2021 -- end; procedure TPolyline.ArrangeSelectedSegment(SegType: TSegmentType); begin ArrangeSegment(SelectedPoint,SegType); end; procedure TPolyline.InsertKnot(SegNbr: Integer); var Seg : TPLSegment; NewSeg: TPLSegment; i: Integer; begin if SegNbr = 0 then exit; Seg := Segments[SegNbr-1]; if assigned(seg) then begin PointCount := PointCount+1; ActualPoints[PointCount] := ActualPoints[PointCount-1]; OriginalPoints[PointCount] := OriginalPoints[PointCount-1]; for i := PointCount downto SegNbr+1 do begin ActualPoints[i] := ActualPoints[i-1]; OriginalPoints[i] := OriginalPoints[i-1]; end; if SegNbr+1 = PointCount then begin ActualPoints[SegNbr+1] := MPoint(ActualPoints[SegNbr],ActualPoints[1]); OriginalPoints[Segnbr+1] := MPoint(OriginalPoints[SegNbr],OriginalPoints[1]); end else begin ActualPoints[SegNbr+1] := MPoint(ActualPoints[SegNbr],ActualPoints[SegNbr+2]); OriginalPoints[Segnbr+1] := MPoint(OriginalPoints[SegNbr],OriginalPoints[SegNbr+2]); end; SegMents.Move(PointCount-1,SegNbr); Seg := Segments[SegNbr-1]; ArrangeSegment(SegNbr, Seg.SType); ArrangeSegment(SegNbr+1, Seg.SType); NeedBounds := True; //Tolik 02/08/2021 -- end; end; procedure TPolyline.DeleteKnot(SegNbr: Integer); var Seg : TPLSegment; NewSeg: TPLSegment; i: Integer; begin if SegNbr = 0 then exit; if PointCount < 3 then exit; Seg := Segments[SegNbr - 1]; if assigned(seg) then begin for i := segNbr to PointCount - 1 do begin ActualPoints[i] := ActualPoints[i+1]; OriginalPoints[i] := OriginalPoints[i+1]; end; PointCount := PointCount-1; ReDimenPoints; Segments.Remove(seg); Seg.Free; NeedBounds := True; //Tolik 02/08/2021 -- end; end; procedure TPolyline.MoveControlPointsOfKnot(KnotNbr: Integer; DeltaX, DeltaY: Double); var s1,s2: integer; Seg: TPlSegment; begin if KnotNbr =1 then s1 := PointCount else s1 := KnotNbr-1; s2 := KnotNbr; seg := TPlSegment(Segments[s1-1]); if seg.SType = sCurve then begin seg.CPoint2.x := seg.CPoint2.x +Deltax; seg.CPoint2.y := seg.CPoint2.y +Deltay; end else if seg.sType = sArc then begin ArrangeSegment(s1,sArc); end; seg := TPlSegment(Segments[s2-1]); if seg.SType = sCurve then begin seg.CPoint1.x := seg.CPoint1.x +Deltax; seg.CPoint1.y := seg.CPoint1.y +Deltay; end else if seg.SType = sArc then begin ArrangeSegment(s2,sArc); end; NeedBounds := True; //Tolik 02/08/2021 -- end; procedure TPolyline.GetControlPointsOfKnot(KnotNbr: integer; var cp1, cp2: TDoublePoint); var s1,s2: integer; Seg: TPlSegment; begin if KnotNbr =1 then s1 := PointCount else s1 := KnotNbr-1; s2 := KnotNbr; seg := TPlSegment(Segments[s1-1]); cp1 := seg.CPoint2; seg := TPlSegment(Segments[s2-1]); cp2 := seg.CPoint1; end; procedure TPolyline.GetControlPointsOfSegment(SegNbr: integer; var cp1, cp2: TDoublePoint); var Seg: TPlSegment; begin seg := TPlSegment(Segments[SegNbr-1]); cp1 := seg.CPoint1; cp2 := seg.CPoint2; end; procedure TPolyline.SetControlPointsOfKnot(KnotNbr: integer; cp1, cp2: TDoublePoint); var s1,s2: integer; Seg: TPlSegment; begin if KnotNbr =1 then s1 := PointCount else s1 := KnotNbr-1; s2 := KnotNbr; seg := TPlSegment(Segments[s1-1]); seg.CPoint2 := cp1; seg := TPlSegment(Segments[s2-1]); seg.CPoint1 := cp2; end; procedure TPolyline.SetControlPointsOfSegment(SegNbr: integer; cp1, cp2: TDoublePoint); var Seg: TPlSegment; begin seg := TPlSegment(Segments[SegNbr-1]); seg.CPoint1 := cp1; seg.CPoint2 := cp2; end; procedure TPolyline.BreakControlLine(KnotNbr: Integer); begin TPLSegment(Segments[KnotNbr-1]).TangentKnot := False; end; procedure TPolyline.TangentControlLine(KnotNbr: Integer); var Seg: TPLSegment; ap,cp1,cp2: TDoublePoint; PreSeg: integer; begin Seg := Segments[KnotNbr-1]; Seg.TangentKnot := True; cp1 := Seg.CPoint1; ap := ActualPoints[KnotNbr]; cp2 := RotatePoint(ap,cp1,pi); if KnotNbr = 1 then Preseg := PointCount else PreSeg := KnotNbr-1; Seg := Segments[Preseg-1]; Seg.Cpoint2 := cp2; end; procedure TPolyline.InvertSegment(KnotNbr: Integer); begin TPLSegment(Segments[KnotNbr-1]).Inverted := not TPLSegment(Segments[KnotNbr-1]).Inverted; end; function TPolyline.IsKnotTangent(KnotNbr: Integer): Boolean; begin result := TPLSegment(Segments[KnotNbr-1]).TangentKnot; end; function TPolyline.TypeOfSegment(SegNbr: Integer): TSegmentType; begin result := TPLSegment(Segments[SegNbr-1]).sType; end; procedure TPolyline.Mirror(Point1, Point2: TDoublePoint); var a: integer; begin inherited; for a := 0 to segments.count-1 do TPlSegment(Segments[a]).Mirror(Point1,Point2); if Self.Parent <> nil then if Self.Parent.Parent <> nil then if Self.Parent.Parent.Cname = 'TFigureGrpMod' then SavedStateFig := 'no state'; end; Procedure TPolyline.VerifyZeroPoints(orgV,orgH:Byte); var cad :TPCdrawing; h,w:Double; x,y:double; i: Integer; Seg: TPlSegment; begin inherited; if assigned(owner) then begin cad := TPCDrawing(owner); h := Cad.WorkHeight; w := Cad.WorkWidth; if (orgV <> VertZero) or (orgH <> HorzZero) then begin for i := 0 to segments.count-1 do begin Seg := TPlSegment(Segments[i]); if orgV <> VertZero then begin Seg.CPoint1.y := h - Seg.CPoint1.y; Seg.CPoint2.y := h - Seg.CPoint2.y; if Seg.SType = sArc then Seg.Inverted := not Seg.Inverted; end; if orgH <> HorzZero then begin Seg.CPoint1.x := w - Seg.CPoint1.x; Seg.CPoint2.x := w - Seg.CPoint2.x; if Seg.SType = sArc then Seg.Inverted := not Seg.Inverted; end; end; end; end; end; procedure TPolyline.Move(deltax, deltay: double); var a: integer; begin InMoveList := False; if (JoinFigure1 = nil) or (JoinFigure2 = nil) then begin inherited; for a := 0 to Segments.count-1 do TPlSegment(Segments[a]).Move(deltaX,deltaY); end else begin for a:= 2 to pointcount-1 do begin originalpoints[a] := DoublePoint(originalpoints[a].x + deltax, originalpoints[a].y + deltay); Actualpoints[a] := DoublePoint(actualpoints[a].x + deltax, actualpoints[a].y + deltay); end; for a := 0 to Segments.count-1 do TPlSegment(Segments[a]).Move(deltaX,deltaY); end; if Self.Parent <> nil then if Self.Parent.Parent <> nil then if Self.Parent.Parent.Cname = 'TFigureGrpMod' then SavedStateFig := 'no state'; NeedBounds := True; //Tolik 02/08/2021 -- end; procedure TPolyline.Rotate(aAngle: double; cPoint: TDoublePoint); var a: integer; begin inherited; for a := 0 to segments.count-1 do TPlSegment(Segments[a]).Rotate(aAngle,cPoint); if Self.Parent <> nil then if Self.Parent.Parent <> nil then if Self.Parent.Parent.Cname = 'TFigureGrpMod' then SavedStateFig := 'no state'; NeedBounds := True; //Tolik 02/08/2021 -- end; procedure TPolyline.scale(percentx, percenty: double; rPoint: TDoublePoint); var a: integer; begin inherited; for a := 0 to segments.count-1 do TPlSegment(Segments[a]).Scale(percentx,percenty,rPoint); if Self.Parent <> nil then if Self.Parent.Parent <> nil then if Self.Parent.Parent.Cname = 'TFigureGrpMod' then SavedStateFig := 'no state'; NeedBounds := True; //Tolik 02/08/2021 -- end; Procedure TPolyline.UpdateMenu(var PopMenu: TPopUpMenu; var sIndex: integer); var mnItem,mnSub: TMenuItem; Seg: TPLSegment; Cad: TPCDrawing; i:Integer; xPattern:TPattern; begin Seg := TPLSegment(Segments[SelectedPoint-1]); menuIndex:= sIndex; mnItem := TMenuItem.Create(PopMenu); mnItem.Tag := sIndex; mnItem.Caption := fmCurveAll; PopMenu.Items.Add(mnItem); mnItem := TMenuItem.Create(PopMenu); mnItem.Tag := sIndex; mnItem.Tag := sIndex+1; mnItem.Caption := fmLineAll; PopMenu.Items.Add(mnItem); mnItem := TMenuItem.Create(PopMenu); if Closed then begin mnItem.Tag := sIndex+2; mnItem.Caption := fmOpenFigure; end else begin mnItem.Tag := sIndex+3; mnItem.Caption := fmCloseFigure; end; PopMenu.Items.Add(mnItem); mnItem := TMenuItem.Create(PopMenu); mnItem.Caption := fmControlLine; mnItem.Tag := sIndex+4; PopMenu.Items.Add(mnItem); mnSub := TMenuItem.Create(PopMenu); mnSub.Caption := fmTangentLine; mnSub.Tag := sIndex+5; if Seg.TangentKnot then mnSub.Checked := True; mnItem.Add(mnSub); mnSub := TMenuItem.Create(PopMenu); mnSub.Caption := fmBrokenLegs; mnSub.Tag := sIndex+6; if not Seg.TangentKnot then mnSub.Checked := True; mnItem.Add(mnSub); mnItem := TMenuItem.Create(PopMenu); mnItem.Caption := fmInsertKnot; mnItem.Tag := sIndex+7; PopMenu.Items.Add(mnItem); mnItem := TMenuItem.Create(PopMenu); mnItem.Caption := fmDeleteKnot; mnItem.Tag := sIndex+8; PopMenu.Items.Add(mnItem); mnItem := TMenuItem.Create(PopMenu); mnItem.Caption := fmSegment; mnItem.Tag := 0; PopMenu.Items.Add(mnItem); mnSub := TMenuItem.Create(PopMenu); mnSub.Caption := fmLinear; mnSub.Tag := sIndex+9; if Seg.SType = sLine then mnSub.Checked := True; mnItem.Add(mnSub); mnSub := TMenuItem.Create(PopMenu); mnSub.Caption := fmCurve; mnSub.Tag := sIndex+10; if Seg.SType = sCurve then mnSub.Checked := True; mnItem.Add(mnSub); mnSub := TMenuItem.Create(PopMenu); mnSub.Caption := fmArc; mnSub.Tag := sIndex+11; if Seg.SType = sArc then mnSub.Checked := True; mnItem.Add(mnSub); if Seg.SType = sArc then begin mnSub := TMenuItem.Create(PopMenu); mnSub.Caption := '-'; mnItem.Add(mnSub); mnSub := TMenuItem.Create(PopMenu); mnSub.Caption := fmInvertArcSegment; mnSub.Tag := sIndex+12; mnItem.Add(mnSub); end; mnSub := TMenuItem.Create(PopMenu); mnSub.Caption := '-'; mnItem.Add(mnSub); mnSub := TMenuItem.Create(PopMenu); mnSub.Caption := fmDimensionLine; mnSub.Tag := sIndex+15; mnSub.Checked := Seg.ShowDim; mnItem.Add(mnSub); mnItem := TMenuItem.Create(PopMenu); mnItem.Caption := fmDivideTo3; mnItem.Tag := sIndex+14; PopMenu.Items.Add(mnItem); mnItem := TMenuItem.Create(PopMenu); mnItem.Caption := fmRoundCorner; mnItem.Tag := sIndex+16; PopMenu.Items.Add(mnItem); mnItem := TMenuItem.Create(PopMenu); mnItem.Caption := fmPenPattern; mnItem.Tag := 0; PopMenu.Items.Add(mnItem); mnSub := TMenuItem.Create(PopMenu); mnSub.Caption := fmNoPattern; mnSub.Tag := sIndex+13; if PenPattern = nil then mnSub.Checked := True; mnItem.Add(mnSub); if assigned(owner) then begin Cad := TPCDrawing(Owner); for i := 0 to Cad.PenPatternCount-1 do begin xPattern := Cad.PenPattern[i]; mnSub := TMenuItem.Create(PopMenu); mnSub.Caption := xpattern.Patname; mnSub.Tag := sIndex+17+i; if Assigned(PenPattern) and (PenPattern.PatName = xPattern.PatName) then mnSub.Checked := True; mnItem.Add(mnSub); end; end; mnItem := TMenuItem.Create(PopMenu); mnItem.Caption := fmBrushPattern; mnItem.Tag := 0; PopMenu.Items.Add(mnItem); mnSub := TMenuItem.Create(PopMenu); mnSub.Caption := fmNoBPattern; mnSub.Tag := sIndex+100; if PenPattern = nil then mnSub.Checked := True; mnItem.Add(mnSub); if assigned(owner) then begin Cad := TPCDrawing(Owner); for i := 0 to Cad.BrushPatternCount-1 do begin mnSub := TMenuItem.Create(PopMenu); mnSub.Caption := 'Brush'+inttostr(i+1); mnSub.Tag := sIndex+101+i; mnItem.Add(mnSub); end; end; sIndex := sIndex+200; end; procedure TPolyline.MenuClicked(commandID:integer); var idx: integer; i: Integer; Cad: TPCDrawing; rad: Double; begin idx := commandID-menuIndex; case idx of 0: ConvertToBezier; 1: ConvertToPolyLine; 2: Closed := false; 3: Closed := true; 5: TangentControlLine(SelectedPoint); 6: BreakControlLine(SelectedPoint); 7: begin InsertKnot(SelectedPoint); if SelectedPoint = PointCount then SelectedPoint :=1 else SelectedPoint :=SelectedPoint+1; end; 8: begin if PointCount < 3 then exit; DeleteKnot(SelectedPoint); if SelectedPoint > PointCount then SelectedPoint := PointCount else if SelectedPoint > 1 then SelectedPoint := SelectedPoint-1; end; 9: ArrangeSegment(SelectedPoint,sLine); 10: ArrangeSegment(SelectedPoint,sCurve); 11: ArrangeSegment(Selectedpoint,sArc); 12: InvertSegment(Selectedpoint); 13: AssignPenPattern(nil); 14: begin DivideSegment(SelectedPoint,3); if SelectedPoint = PointCount then SelectedPoint :=1 else SelectedPoint :=SelectedPoint+1; end; 15: begin ToggleSegmentDimension(SelectedPoint-1); end; 16: begin Rad := 5; if InputDouble('Round Corner By Arc','Ener Arc Corner',Rad) then begin RoundCornerByArc(SelectedPoint,Rad); end; end; end; if (idx > 16) and (idx < 100) then begin i := idx -17; if assigned(Owner) then begin Cad := TPCDrawing(Owner); AssignPenPattern(Cad.PenPattern[i]); end; end; if (idx >=100) then begin if idx = 100 then begin BrushBitmap := nil end else if assigned(owner) then begin i := idx -101; Cad := TPCDrawing(Owner); BrushBitmap := (Cad.BrushList[i]); end; end; end; class function TPolyline.CreateShadow(x, y: double): TFigure; var points: TDoublePointArr; begin SetLength(points,2); points[0] := DoublePoint(x,y); points[1] := DoublePoint(x,y); Result := TPolyLine.create(Points,1,1,clLime,0,0,ord(rsNone),false,0,dsTrace,nil); TPolyLine(Result).KeyControl := PolylineKeyControl; PolylineKeyControl := False; end; function TPolyline.ShadowClick(ClickIndex:Integer; x, y: Double): Boolean; var dx,dy: Double; xp: TDoublePoint; Snapped: Boolean; begin result := false; if KeyControl then begin Snapped := False; dx := ABS(actualPoints[1].x - x); dy := ABS(actualPoints[1].y - y); if (PointCount > 2) and (dx < 3) and (dy < 3) then begin x := actualPoints[1].x; y := actualPoints[1].y; Snapped := True; end; xp := actualpoints[PointCount-1]; dx := x- xp.x; dy := y- xp.y; if abs(dx) > abs(dy) then begin if Snapped then actualpoints[PointCount-1] := DoublePoint(actualpoints[PointCount-1].x,y) else y := xp.y; end else begin if Snapped then actualpoints[PointCount-1] := DoublePoint(x,actualpoints[PointCount-1].y) else x := xp.x; end; end else begin dx := ABS(actualPoints[1].x - x); dy := ABS(actualPoints[1].y - y); if (PointCount > 2) and (dx < 3) and (dy < 3) then begin x := actualPoints[1].x; y := actualPoints[1].y; end; end; if clickindex > 1 then begin PointCount := PointCount+1; actualPoints[clickIndex] := DoublePoint(x,y); actualPoints[clickIndex+1] := DoublePoint(x,y); if (ActualPoints[1].x = x) and (ActualPoints[1].y = y) and (ClickIndex > 2) then begin result := True; Closed := True; end; end; end; Function TPolyline.ShadowTrace(ClickIndex:Integer; x, y: double): Boolean; var dx,dy: Double; xp: TDoublePOint; snapped: Boolean; begin if KeyControl then begin if ClickIndex = 1 then exit; Snapped := False; dx := ABS(actualPoints[1].x - x); dy := ABS(actualPoints[1].y - y); if (PointCount > 2) and (dx < 3) and (dy < 3) then begin x := actualPoints[1].x; y := actualPoints[1].y; Snapped := True; end; xp := actualpoints[PointCount-1]; dx := x- xp.x; dy := y- xp.y; if abs(dx) > abs(dy) then begin if Snapped then actualPoints[PointCount-1] := DoublePoint(actualPoints[PointCount-1].x,y) else y := xp.y; end else begin if Snapped then actualPoints[PointCount-1] := DoublePoint(x,actualPoints[PointCount-1].y) else x := xp.x; end; end else begin dx := ABS(actualPoints[1].x - x); dy := ABS(actualPoints[1].y - y); if (PointCount > 2) and (dx < 3) and (dy < 3) then begin x := actualPoints[1].x; y := actualPoints[1].y; end; end; actualPoints[clickindex+1] := DoublePoint(x,y); result := false; end; class function TPolyline.CreateFromShadow(aOwner: TComponent; LHandle: Integer; Shadow: TFigure): TFigure; var cad: TPCDrawing; points: TDoublePointArr; a: integer; begin result := nil; cad := TPCDrawing(aOwner); if Shadow.PointCount < 4 then exit; SetLength(points,Shadow.PointCount-2); for a := 1 to Shadow.PointCount-2 do begin points[a-1] := Shadow.ActualPoints[a]; end; result := TPolyLine.create(points, cad.DefaultPenWidth, ord(cad.DefaultPenStyle), cad.DefaultPenColor, ord(cad.DefaultBrushStyle), cad.DefaultBrushColor, ord(cad.DefaultRowStyle), TPolyline(Shadow).Closed or Cad.DefaultPLineClosed, LHandle,mydsNormal,aOwner); end; function TPolyline.CreateModification: TFigure; var points: TDoublePointArr; a: integer; Res: TPolyLine; p: PPoint; ps: TBezierPoint; begin SetLength(points,PointCount); for a := 1 to PointCount do begin points[a-1] := ActualPoints[a]; end; Res := TPolyLine.create(points,1,1,clLime,0,0,0,closed,0,dsTrace,nil); Res.Segments.Clear; for a := 0 to Segments.Count -1 do Res.Segments.Add(TPlSegment(Segments[a]).Duplicate); res.SelectedPoint := SelectedPoint; if assigned(res) then res.RotPoint := RotPoint; CreateModification := res; // Tolik 24/05/2019 - - SetLength(points, 0); // end; function TPolyline.TraceModification(CadControl: Pointer;mp: TModPoint; TraceFigure:TFigure;x,y: double;Shift: TShiftState): boolean; var cp1,cp2: TDoublePoint; xp,p1,p2: TDoublePoint; ptIndex: integer; cIndex,r1 : integer; ang1,ang2: double; isTan: Boolean; rad1,rad2: double; a,b: double; begin TPolyLine(TraceFigure).Tracing := true; if (mp.PType = ptPolyPoint) or (mp.PType = ptRectPoint) then begin p1 := TraceFigure.ActualPoints[mp.SeqNbr]; TraceFigure.ActualPoints[mp.SeqNbr]:= DoublePoint(x,y); TPolyLine(TraceFigure).MoveControlPointsOfKnot(mp.SeqNbr,x-p1.x,y-p1.y); end else if mp.PType = ptControlPoint then begin ptIndex := (mp.SeqNbr div 10); cIndex := (mp.SeqNbr mod 10); isTan := TPolyLine(TraceFigure).IsKnotTangent(ptIndex); p1 := TraceFigure.ActualPoints[ptIndex]; TPolyline(TraceFigure).GetControlPointsOfKnot(ptIndex,cp1,cp2); if cIndex = 1 then begin ang1 := GetRadOfLine(p1,cp1); cp1 := DoublePoint(x,y); if isTan and (TPolyline(TraceFigure).TypeOfSegment(ptIndex) = sCurve) then begin ang2 := GetRadOfLine(p1,cp1); cp2 := RotatePoint(p1,cp2,ang2-ang1); end; end else if cIndex = 2 then begin ang1 := GetRadOfLine(p1,cp2); cp2 := DoublePoint(x,y); if ptIndex = 1 then cIndex := PointCount else cIndex := ptIndex-1; if isTan and (TPolyline(TraceFigure).TypeOfSegment(cIndex) = sCurve) then begin ang2 := GetRadOfLine(p1,cp2); cp1 := RotatePoint(p1,cp1,ang2-ang1); end; end; TPolyline(TraceFigure).SetControlPointsOfKnot(ptIndex,cp1,cp2); end else if mp.PType = ptArcControl then begin ptIndex := mp.SeqNbr; p1 := TraceFigure.ActualPoints[ptIndex]; if ptIndex <> PointCount then p2 := TraceFigure.ActualPoints[ptIndex+1] else p2 := TraceFigure.ActualPoints[1]; GetControlPointsOfKnot(ptIndex,cp1,cp2); xp := DoublePoint((p1.x+p2.x) / 2,(p1.y+p2.y) / 2); if (xp.x = cp2.x) and (xp.y = cp2.y) then begin PointTo90Line(p1,p2,x,y); end else PointToLine(xp,cp2,x,y); cp2 := DoublePoint(x,y); TPolyline(TraceFigure).SetControlPointsOfKnot(ptIndex,cp1,cp2); end; end; function TPolyline.EndModification(CadControl: Pointer;mp: TModPoint; TraceFigure: TFigure; x,y: double;Shift: TShiftState): boolean; var xp,p1,p2: TDoublePoint; cp1,cp2: TDoublePoint; ptIndex: integer; cindex,r1 : integer; ang1,ang2: double; Cad: TPCdrawing; isTan:Boolean; rad1,rad2: double; begin Tracing := false; Cad := TPCDrawing(CadControl); if (mp.PType = ptPolyPoint) or (mp.PType = ptRectPoint) then begin p1 := ActualPoints[MP.SeqNbr]; ActualPoints[MP.SeqNbr] := DoublePoint(ActualPoints[MP.SeqNbr].x + (x-p1.x), ActualPoints[MP.SeqNbr].y + (y-p1.y)); MoveControlPointsOfKnot(mp.SeqNbr,x-p1.x,y-p1.y); end else if mp.PType = ptControlPoint then begin ptIndex := (mp.SeqNbr div 10); cIndex := (mp.SeqNbr mod 10); isTan := IsKnotTangent(ptIndex); p1 := ActualPoints[ptIndex]; GetControlPointsofKnot(ptIndex,cp1,cp2); if cIndex = 1 then begin ang1 := GetRadOfLine(p1,cp1); cp1 := DoublePoint(x,y); if isTan and (TypeOfSegment(ptIndex) = sCurve) then begin ang2 := GetRadOfLine(p1,cp1); cp2 := RotatePoint(p1,cp2,ang2-ang1); end; end else if cIndex = 2 then begin ang1 := GetRadOfLine(p1,cp2); cp2 := DoublePoint(x,y); if ptIndex = 1 then cIndex := PointCount else cIndex := ptIndex-1; if isTan and (TypeOfSegment(cIndex) = sCurve) then begin ang2 := GetradOfLine(p1,cp2); cp1 := RotatePoint(p1,cp1,ang2-ang1); end; end; SetControlPointsofKnot(ptIndex,cp1,cp2); end else if mp.PType = ptArcControl then begin ptIndex := mp.SeqNbr; p1 := ActualPoints[ptIndex]; if ptIndex <> PointCount then p2 := ActualPoints[ptIndex+1] else p2 := ActualPoints[1]; GetControlPointsOfKnot(ptIndex,cp1,cp2); xp := DoublePoint((p1.x+p2.x) / 2,(p1.y+p2.y) / 2); if (xp.x = cp2.x) and (xp.y = cp2.y) then begin PointTo90Line(p1,p2,x,y); end else PointToLine(xp,cp2,x,y); cp2 := DoublePoint(x,y); SetControlPointsOfKnot(ptIndex,cp1,cp2); end; if ((MP.SeqNbr = 1) or (MP.SeqNbr = PointCount )) and (ssCtrl in Shift) and (ssShift in Shift) then begin Cad.BoundLinePoint(self.Handle,MP.SeqNbr,DoublePoint(x,y)); end; ResetRegion; Modified := True; NeedBounds := True; //Tolik 02/08/2021 -- end; procedure TPolyline.setClosed(const Value: Boolean); begin fClosed := Value; end; Procedure TPolyline.ConvertToBezier; var a: integer; begin for a := 1 to pointcount do ArrangeSegment(a,sCurve); NeedBounds := True; //Tolik 02/08/2021 -- end; Procedure TPolyline.ConvertToPolyLine; var a: integer; begin for a := 1 to pointcount do ArrangeSegment(a,sLine); NeedBounds := True; //Tolik 02/08/2021 -- end; procedure TPolyline.JoinFigureMoved(Sender: TFigure; dx, dy: double); begin if inMoveList then exit; if sender = JoinFigure1 then ActualPoints[1] := DoublePoint(ap1.x + dx ,ap1.y + dy); if sender = JoinFigure2 then ActualPoints[PointCount] := DoublePoint(ActualPoints[PointCount].x + dx , ActualPoints[PointCount].y + dy); NeedBounds := True; //Tolik 02/08/2021 -- end; procedure TPolyline.SetJFigure1(jf: TFigure); begin if jf = JoinFigure1 then exit; if jf = nil then JoinFigure1.JoinedFigures.Remove(self); JoinFigure1 := jf; if jf <> nil then jf.JoinedFigures.Add(self); end; procedure TPolyline.SetJFigure2(jf: TFigure); begin if jf = JoinFigure2 then exit; if jf = nil then JoinFigure2.JoinedFigures.Remove(self); JoinFigure2 := jf; if jf <> nil then jf.JoinedFigures.Add(self); end; procedure TPolyline.UnBound; begin JoinFigure1 := nil; JoinFigure2 := nil; end; procedure TPolyline.WriteToStream(Stream: TStream); var xByte: Byte; xInt,a: Integer; xDbl: Double; xStr: String; ps: TBezierPoint; Seg: TPlSegment; sType: Byte; SegStream: TMemoryStream; begin inherited; //Tolik 22/11/2019-- //xByte := RowStyle; if RowStyle = -1 then xByte := 255 else xByte := LoByte(LoWord(RowStyle)); WriteField(90,Stream,xByte,1); //xByte := brs; if brs = -1 then xByte := 255 else xByte := LoByte(LoWord(brs)); // WriteField(91,Stream,xByte,1); // Tolik 22/11/219 -- if closed then xByte := 1 else xByte := 0; WriteField(92,Stream,xByte,1); {if closed then begin xByte := 1; WriteField(92,Stream,xByte,1); end else begin xByte := 0; WriteField(92,Stream,xByte,1); end;} // xInt := brc; WriteField(20,Stream,xInt,4); xInt := HatchSeg; WriteField(21,Stream,xInt,4); xDbl := HatchDist; WriteField(220,Stream,xDbl,8); SegStream := TMemoryStream.Create; SegmentsToStream(SegStream); if SegStream.Size > 0 then begin WriteStreamField(151,Stream,SegStream); end; SegStream.Free; if assigned(PenPattern) then begin SegStream := TMemoryStream.Create; Penpattern.SaveToStream(SegStream); WriteStreamField(152,Stream,SegStream); SegStream.Free; end; end; Procedure TPolyLine.SetPropertyFromStream(xCode:Byte;data:pointer;size:integer); var ByteVal: Byte; a,cpIndex: integer; SegStr: TMemoryStream; preSeg,Seg: TPlSegment; cp: TPoint; pStyle1,pStyle2: Byte; pStyles: array of Byte; pIdx: Integer; cp1,cp2,cp11,cp22: TPoint; ap1,ap2: TDoublePoint; begin Case xcode of 20: brc := pInt(data)^; 21: HatchSeg := pInt(data)^; 90: begin if pByte(data)^ = 255 then RowStyle := -1 else RowStyle := pByte(data)^; end; 91: begin if pByte(data)^ = 255 then brs := -1 else brs := pByte(data)^; end; 92: closed := (pByte(data)^ = 1); 220: HatchDist := pDouble(data)^; 150: begin // old style polyline - stored pointstyles pIdx := 0; Setlength(pStyles,Size); for a := 1 to Size do begin // Tolik 26/03/2019 -- pStyles[a-1] := pByte(pChar(data)+a-1)^; // pStyles[a-1] := pByte(pAnsiChar(data)+a-1)^; // end; for a := 1 to Size do begin pStyle1 := pStyles[a-1]; ap1 := ActualPoints[a]; if a = Size then pStyle2 := pStyles[0] else pStyle2 := pStyles[a]; if a = Size then ap2 := ActualPoints[1] else ap2 := ActualPoints[a+1]; if pStyle1 <> 0 then begin cp1 := fTempPoints[pIdx];inc(pIdx); cp2 := fTempPoints[pIdx];inc(pIdx); end; if pStyle2 <> 0 then begin cp11 := fTempPoints[pIdx]; cp22 := fTempPoints[pIdx+1]; end; if (pStyle1 = 0) and (pStyle2 = 0) then begin TPLSegment(Segments[a-1]).SType := sLine ; end else if (pStyle1 = 0) and (pStyle2 <> 0) then begin TPLSegment(Segments[a-1]).SType := sCurve; TPLSegment(Segments[a-1]).CPoint1 := ap1; TPLSegment(Segments[a-1]).CPoint2 := DoublePoint(cp11.x/10,cp11.y/10); end else if (pStyle1 <> 0) and (pStyle2 = 0) then begin TPLSegment(Segments[a-1]).SType := sCurve; TPLSegment(Segments[a-1]).CPoint2 := ap2; TPLSegment(Segments[a-1]).CPoint1 := DoublePoint(cp2.x/10,cp2.y/10); TPLSegment(Segments[a-1]).TangentKnot := (pStyle1 = 1); end else if (pStyle1 <> 0) and (pStyle2 <> 0) then begin TPLSegment(Segments[a-1]).SType := sCurve; TPLSegment(Segments[a-1]).CPoint1 := DoublePoint(cp2.x/10,cp2.y/10); TPLSegment(Segments[a-1]).CPoint2 := DoublePoint(cp11.x/10,cp11.y/10); TPLSegment(Segments[a-1]).TangentKnot := (pStyle1 = 1); end; end; // Tolik 24/05/2019 - - Setlength(pStyles, 0); // end; 151: begin // new style polyline - stored segments SegStr := TMemoryStream.Create; SegStr.Write(pByte(data)^,size); SegStr.Position := 0; SegmentsFromStream(SegStr); SegStr.Free; end; 152: begin // pattern SegStr := TMemoryStream.Create; SegStr.Write(pByte(data)^,size); SegStr.Position := 0; PenPattern := Tpattern.Create(nil,0,0); if oldPatternFormat then PenPattern.LoadFromStreamOldFormat(SegStr) else PenPattern.LoadFromStream(SegStr); SegStr.Free; end; end; end; procedure TPolyline.SegmentsFromStream(xStream: TStream); var sType: Byte; index: Integer; Seg: TPlSegment; cx,cy: Double; ix,iy: Integer; xByte: Byte; begin repeat xStream.Read(Index,4); Seg := TPlSegment(Segments[Index-1]); xStream.Read(sType,1); Seg.Stype := TSegmentType(sType); if Seg.sType = sCurve then begin if oldStyleLoad then begin xStream.Read(ix,4); xStream.Read(iy,4); Seg.CPoint1.x := ix/10; Seg.CPoint1.y := iy/10; xStream.Read(ix,4); xStream.Read(iy,4); Seg.CPoint2.x := ix/10; Seg.CPoint2.y := iy/10; end else begin xStream.Read(cx,8); if CompareValue(cx, 0, 0.0000001) = 0 then // Tolik 23/06/2021 -- cx := 0; xStream.Read(cy,8); if CompareValue(cy, 0, 0.0000001) = 0 then // Tolik 23/06/2021 -- cy := 0; Seg.CPoint1.x := cx; Seg.CPoint1.y := cy; xStream.Read(cx,8); if CompareValue(cx, 0, 0.0000001) = 0 then // Tolik 23/06/2021 -- cx := 0; xStream.Read(cy,8); if CompareValue(cy, 0, 0.0000001) = 0 then // Tolik 23/06/2021 -- cy := 0; Seg.CPoint2.x := cx; Seg.CPoint2.y := cy; end; xStream.Read(xByte,1); Seg.TangentKnot := (xByte = 1); end else if Seg.sType = sArc then begin if oldStyleLoad then begin xStream.Read(ix,4); xStream.Read(iy,4); Seg.CPoint1.x := ix/10; Seg.CPoint1.y := iy/10; end else begin xStream.Read(cx,8); if CompareValue(cx, 0, 0.0000001) = 0 then // Tolik 23/06/2021 -- cx := 0; xStream.Read(cy,8); if CompareValue(cy, 0, 0.0000001) = 0 then // Tolik 23/06/2021 -- cy := 0; Seg.CPoint1.x := cx; Seg.CPoint1.y := cy; end; xStream.Read(xByte,1); Seg.Inverted := (xByte = 1); end; until xStream.Position >= xStream.Size; end; procedure TPolyline.SegmentsToStream(xStream: TStream); var xByte: Byte; sType: Byte; a: integer; Seg: TPlSegment; begin For a := 1 to PointCount do begin Seg := TPlSegment(Segments[a-1]); sType := ord(Seg.sType); if sType = ord(sCurve) then begin // Index | Type | c1 | c2 | isTangent xStream.Write(a,4); xStream.Write(sType,1); xStream.Write(seg.Cpoint1.x,8); xStream.Write(seg.Cpoint1.y,8); xStream.Write(seg.Cpoint2.x,8); xStream.Write(seg.Cpoint2.y,8); if Seg.TangentKnot then xByte := 1 else xByte := 0; xStream.Write(xByte,1); end else if sType = ord(sArc) then begin // Index | Type | c1 | Inverted xStream.Write(a,4); xStream.Write(sType,1); xStream.Write(seg.Cpoint1.x,8); xStream.Write(seg.Cpoint1.y,8); if Seg.Inverted then xByte := 1 else xByte := 0; xStream.Write(xByte,1); end; end; end; procedure TPolyLine.CollectPolyBezierPoints(var pdPoints: TDoublePointArr); var rpS1,rpS2,rpE1,rpE2:TDoublePoint; fLine,lLine:Boolean; begin CollectPolyBezierPoints(pdPoints,rpS1,rpS2,rpE1,rpE2,fLine,lLine); end; procedure TPolyLine.CollectPolyBezierPoints(var pdPoints: TDoublePointArr; var rpS1,rpS2,rpE1,rpE2:TDoublePoint; var fLine,lLine:Boolean); var a,ax: integer; cp1,cp2,c1,c2: TDoublePoint; p1,p2: TDoublePoint; ps1,ps2: TBezierPoint; pcnt: integer; pIdx: integer; Segment: TPLSegment; lp: integer; a1,a2,at,distA: double; radius: Double; cnt,i,ix: integer; Fpoints : T2DPointArray; Inverted: Boolean; valid:Boolean; begin if Closed then lp := PointCount else lp := PointCount-1; pIdx := 0; fLine := False; lLine := False; ax := 0; For a := 1 to lp do begin Segment := TPlSegment(Segments[a-1]); p1 := actualpoints[a]; if a = PointCount then p2 := actualpoints[1] else p2 := actualpoints[a+1]; valid := not EQDP(p1,p2); if valid then begin ax := ax+1; if (Segment.SType = sLine) then begin if ax = 1 then begin SetLength(pdPoints,pIdx+4); pdPoints[pIdx] := p1;inc(pIdx); rpS1 := p1; rps2 := p2; fLine := True; end else SetLength(pdPoints,pIdx+3); if a = PointCount-1 then begin rpE1 := p1; rpE2 := p2; lLine := True; end; pdPoints[pIdx] := p1;inc(pIdx); pdPoints[pIdx] := p2;inc(pIdx); pdPoints[pIdx] := p2;inc(pIdx); end else if (Segment.SType = sArc) then begin c1 := Segment.CPoint1; a1 := GetRadOfLine(c1,p1); a2 := GetRadOfLine(c1,p2); if a2 = 0 then a2 := 2*pi; if a1>a2 then distA := 2*pi - a1+a2 else distA := a2-a1; Inverted := Segment.Inverted; if Inverted then begin at := a1; a1 := a2; a2 := at; end; radius := GetLineLenght(p1,c1); BezierArcPoints(FPoints,c1.x,c1.y,Radius,a1,a2); cnt := Length(FPoints); if a = 1 then begin SetLength(pdPoints,pIdx+cnt); pdPoints[pIdx] := p1;inc(pIdx); end else SetLength(pdPoints,pIdx+cnt-1); for I := 1 to cnt-1 do begin if Inverted then ix := cnt-I-1 else ix := i; pdPoints[pIdx] := DoublePoint(FPoints[Ix].X, FPoints[Ix].Y); inc(pIdx); end; // Tolik 24/05/2019 -- SetLength(Fpoints, 0); // end else if Segment.SType = sCurve then begin c1 := Segment.CPoint1; c2 := Segment.CPoint2; if a = 1 then begin SetLength(pdPoints,pIdx+4); pdPoints[pIdx] := p1;inc(pIdx); end else SetLength(pdPoints,pIdx+3); pdPoints[pIdx] := c1;inc(pIdx); pdPoints[pIdx] := c2;inc(pIdx); pdPoints[pIdx] := p2;inc(pIdx); end; end; end; end; procedure TPolyline.OffSetSegments(var NewSegs: TList; w: Double); var a: integer; cp1,cp2,c1,c2: TDoublePoint; p1,p2,np1,np2: TDoublePoint; Segment: TPLSegment; lp,i: integer; ww: Double; xSeg: TPLSegment; seg1,seg2: TPLSegment; valid: Boolean; bArr: TDoublePOintArr; begin if Closed then lp := PointCount else lp := PointCount-1; For a := 1 to lp do begin Segment := TPlSegment(Segments[a-1]); p1 := actualpoints[a]; if a = PointCount then p2 := actualpoints[1] else p2 := actualpoints[a+1]; valid := not EQDP(p1,p2); if valid then begin if (Segment.SType = sLine) then begin GetParallelPoints(p1,p2,np1,np2,w); xSeg := TPLSegment.Create(0,sLine,np1,np2); xSeg.tp1 := np1; xSeg.tp2 := np2; NewSegs.Add(xSeg); end else if (Segment.SType = sArc) then begin c1 := Segment.CPoint1; ww := w; if Segment.Inverted then ww := -w; OffsetPoint(p1,c1,np1,ww); OffsetPoint(p2,c1,np2,ww); xSeg := TPLSegment.Create(0,sArc,c1,c1); xSeg.tp1 := np1; xSeg.tp2 := np2; xSeg.Inverted := Segment.Inverted; NewSegs.Add(xSeg); end else if Segment.SType = sCurve then begin cp1 := Segment.CPoint1; cp2 := Segment.CPoint2; DoubleBezier(p1,cp1,cp2,p2,bArr,w); for i:= 0 to Length(bArr)-2 do begin np1 := bArr[i]; np2 := bArr[i+1]; xSeg := TPLSegment.Create(0,sLine,np1,np2); xSeg.tp1 := np1; xSeg.tp2 := np2; NewSegs.Add(xSeg); end; SetLength(bArr,0); end; end; end; if Closed then lp := NewSegs.Count else lp := NewSegs.Count-1; i := 1; while i <= lp do begin Seg1 := TPlSegment(NewSegs[i-1]); if i > NewSegs.Count-1 then Seg2 := TPlSegment(NewSegs[0]) else Seg2 := TPlSegment(NewSegs[i]); if not IntersectSegments(seg1,seg2) then begin xSeg := TPLSegment.Create(0,sLine,Seg1.tp2 ,Seg2.tp1); xSeg.tp1 := Seg1.tp2; xSeg.tp2 := Seg2.tp1; NewSegs.Insert(i,xSeg); lp := lp+1; end; i := i +1; end; end; procedure TPolyLine.OffsetPolyBezierPoints(var pdPoints: TDoublePointArr;W:Double); var tSegments: TList; a: Integer; Segment: TPlSegment; pIdx,cnt,I,Ix: Integer; a1,a2,at,distA: Double; c1,c2,p1,p2: TdoublePoint; Inverted:Boolean; FPoints: T2DPointArray; begin tSegments := Tlist.Create; OffsetSegments(tSegments,w); pIdx := 0; For a := 1 to tSegments.Count do begin Segment := TPlSegment(TSegments[a-1]); p1 := Segment.tp1; p2 := Segment.tp2; if (Segment.SType = sLine) then begin if a = 1 then begin SetLength(pdPoints,pIdx+4); pdPoints[pIdx] := p1;inc(pIdx); end else SetLength(pdPoints,pIdx+3); pdPoints[pIdx] := p1;inc(pIdx); pdPoints[pIdx] := p2;inc(pIdx); pdPoints[pIdx] := p2;inc(pIdx); end else if (Segment.SType = sArc) then begin c1 := Segment.CPoint1; a1 := GetRadOfLine(c1,p1); a2 := GetRadOfLine(c1,p2); if a2 = 0 then a2 := 2*pi; if a1>a2 then distA := 2*pi - a1+a2 else distA := a2-a1; Inverted := Segment.Inverted; if Inverted then begin at := a1; a1 := a2; a2 := at; end; radius := GetLineLenght(p1,c1); BezierArcPoints(FPoints,c1.x,c1.y,Radius,a1,a2); cnt := Length(FPoints); if a = 1 then begin SetLength(pdPoints,pIdx+cnt); pdPoints[pIdx] := p1;inc(pIdx); end else SetLength(pdPoints,pIdx+cnt-1); for I := 1 to cnt-1 do begin if Inverted then ix := cnt-I-1 else ix := i; pdPoints[pIdx] := DoublePoint(FPoints[Ix].X, FPoints[Ix].Y); inc(pIdx); end; end else if Segment.SType = sCurve then begin c1 := Segment.CPoint1; c2 := Segment.CPoint2; if a = 1 then begin SetLength(pdPoints,pIdx+4); pdPoints[pIdx] := p1;inc(pIdx); end else SetLength(pdPoints,pIdx+3); pdPoints[pIdx] := c1;inc(pIdx); pdPoints[pIdx] := c2;inc(pIdx); pdPoints[pIdx] := p2;inc(pIdx); end; end; try for i := 0 to TSegments.Count-1 do begin Segment := TPlSegment(TSegments[i]); Segment.Free; end; TSegments.Free; except // on E: Exception do AddExceptionToLog(CPowerCadMessage + 'TPolyLine.OffsetPolyBezierPoints' + E.Message); end; end; Function IntersectSegments(var seg1,seg2: TPLSegment):Boolean; var p1,p2,p3,p4,np,cp1,cp2,cp3,cp4,np1,np2: TDoublePoint; radius,rad1,rad2: Double; iCnt:Integer; begin p1 := Seg1.tp1;p2 := Seg1.tp2; p3 := Seg2.tp1;p4 := Seg2.tp2; cp1 := Seg1.Cpoint1;cp2 := Seg1.Cpoint2; cp3 := Seg2.Cpoint1;cp4 := Seg2.Cpoint2; result := false; if (seg1.SType = sLine) and (seg2.SType = sLine) then begin if GetInterSectionPoint(p1,p2,p3,p4,np) then begin Seg1.tp2 := np; Seg2.tp1 := np; result := True; end; end else if (seg1.SType = sLine) and (seg2.SType = sArc) then begin radius := GetLineLenght(p3,cp3); if GetLineCircleIntersection(p1,p2,cp3,radius,np1,np2,iCnt) then begin if icnt = 1 then np := np1 else np := GetClosePoint(p2,np1,np2); Seg1.tp2 := np; Seg2.tp1 := np; result := True; end; end else if (seg1.SType = sArc) and (seg2.SType = sLine) then begin radius := GetLineLenght(p1,cp1); if GetLineCircleIntersection(p3,p4,cp1,radius,np1,np2,iCnt) then begin if icnt = 1 then np := np1 else np := GetClosePoint(p3,np1,np2); Seg1.tp2 := np; Seg2.tp1 := np; result := True; end; end else if (seg1.SType = sArc) and (seg2.SType = sArc) then begin rad1 := GetLineLenght(p1,cp1); rad2 := GetLineLenght(p3,cp3); if GetCircleCircleIntersection(cp1,rad1,cp3,rad2,np1,np2,iCnt) then begin if icnt = 1 then np := np1 else np := GetClosePoint(p2,np1,np2); Seg1.tp2 := np; Seg2.tp1 := np; result := True; end; end; end; procedure TPolyLine.draw(DEngine: TPCDrawEngine;isGrayed:Boolean); var Layer: TLayer; acolor,bColor : Tcolor; FirstLine,LastLine:boolean; Grayedd : boolean; rpS1,rps2: TDoublepoint; rpE1,rpE2: TDoublepoint; pdPoints: TDoublePointArr; Segment: TPLSegment; c1,c2,p1,p2,cp: TdoublePoint; tPoints: TDoublePointArr; i,cnt1,cnt2,k,cnt3: Integer; valid: Boolean; mp:TDoublePoint; Curved: Boolean; xp1,xp2: TDoublePoint; aawidth: integer; begin aawidth := width; if width > 1 then begin if TPCDrawing(owner).ZoomScale < 100 then begin aawidth := Trunc(width * (TPCDrawing(owner).ZoomScale / 100)); if aawidth = 0 then aawidth := 1; end; end; aColor := Color; if (aColor = -255) and (LayerHandle <> 0) then begin aColor := TLayer(LayerHandle).PenColor; end; bColor := brc; if (bColor = -255) and (LayerHandle <> 0) then begin bColor := TLayer(LayerHandle).BrushColor; end; Grayedd := false; if (isGrayed) then begin acolor := TPCDrawing(Owner).FGrayedColor; //06.08.2012 GrayedColor; bColor := TPCDrawing(Owner).FGrayedColor; //06.08.2012 GrayedColor; Grayedd := true; end; if drawStyle = dsTrace then DEngine.Canvas.Pen.Mode := pmXor else DEngine.Canvas.Pen.Mode := pmCopy; Curved := False; for i := 0 to Segments.Count - 1 do if TPLSegment(Segments[i]).SType <> sLine then Curved := True; if assigned(PenPattern) then Curved := True; if (not curved) and (Pointcount > 2) then begin if (actualpoints[1].x = 0) then begin //actualpoints[1] := actualpoints[PointCount]; end; if (actualpoints[PointCount].x = 0) and (actualpoints[PointCount].y = 0) then begin // actualpoints[PointCount] := actualpoints[1]; end; end; if Curved then begin CollectPolyBezierPoints(pdPoints,rpS1,rps2,rpE1,rpE2,firstLine,LastLine); valid := Length(pdPoints) > 3; end else begin CollectPolyLinePoints(pdPoints); valid := Length(pdPoints) > 1; end; if valid then begin if Curved then begin DEngine.drawbezier(pdpoints,Length(pdPoints),aColor, aawidth,style,bColor,GDIbrs, closed and (drawStyle = mydsNormal) and (brs <> ord(bsClear)), InCombined,PenPattern,RegHandle,RowStyle,rowL,rowH,BrushBitmap); end else begin if closed then DEngine.drawpolygon(pdPoints,acolor, aawidth,style,brc,GDIbrs,RegHandle,BrushBitmap) else Dengine.drawpolyline(pdPoints,acolor, aawidth,style,RowStyle); end; //Tolik if Closed then DrawFill(Dengine,isGrayed); DrawClipFigures(Dengine,isGrayed); if modified and closed and (HatchSeg > -1) then begin HatchBySegment(HatchSeg,HatchDist); end else if closed and (HatchSeg > -1) and (Length(HatchLines) = 0) then begin HatchBySegment(HatchSeg,HatchDist); end; if Closed and (HatchSeg > -1) then begin //Tolik if RegHandle = 0 then begin if RegObject <> nil then begin RegHandle := ExtCreateRegion(nil, RegObject.RegObjDataLength, RegObject.RegObjData^); end; end; if RegHandle <> 0 then begin // Dengine.ClipAnd(RegHandle); for i := 0 to (Length(HatchLines) div 2)-1 do begin xp1 := HatchLines[i*2]; xp2 := HatchLines[i*2+1]; DEngine.drawline(xp1,xp2,brc,1,ord(psSolid),0); end; Dengine.ClipBack; // end; // end; end; if (drawStyle = dsTrace) and (PointCount > 2) and (ap1.x = ActualPoints[PointCount].x) and (ap1.y = ActualPoints[PointCount].y) then begin DEngine.drawselectionpoint(ap1.x,ap1.y,ap1.z,ptECircle,6,clLime,True); end; if (drawStyle = dsTrace) then DEngine.drawselectionpoint(ap1.x,ap1.y,ap1.z,ptECircle,3,clLime,True); if tracing and (SelectedPoint > 0) then begin p1 := ActualPoints[SelectedPoint]; Segment := TPLSegment(Segments[SelectedPoint-1]); c1 := Segment.CPoint1; c2 := Segment.CPoint2; if (Segment.SType = sCurve) then DEngine.drawline(c1.x,c1.y,p1.x,p1.y,clLime,1,1,0) else if (Segment.SType = sArc) then begin DEngine.drawline(c1.x,c1.y,p1.x,p1.y,clLime,1,1,0); c2 := ActualPoints[SelectedPoint+1]; DEngine.drawline(c1.x,c1.y,c2.x,c2.y,clLime,1,1,0); end; if SelectedPoint = 1 then Segment := TPLSegment(Segments[PointCount-1]) else Segment := TPLSegment(Segments[SelectedPoint-2]); c2 := Segment.CPoint2; if Segment.SType = sCurve then DEngine.drawline(c2.x,c2.y,p1.x,p1.y,clLime,1,1,0); end; //Tolik if RegHandle <> 0 then begin GetRegObject; deleteObject(RegHandle); RegHandle := 0; end; // end; Procedure TPolyline.DrawRows(DEngine: TPCDrawEngine;xColor: TColor; rpS1,rpS2,rpE1,rpE2:TDoublePoint;firstLine,lastLine:Boolean); begin if (not Closed) and (drawStyle = mydsNormal) then begin DEngine.Canvas.Brush.Style := bsSolid; DEngine.Canvas.Brush.Color := xColor; DEngine.Canvas.Pen.Color := xColor; DEngine.Canvas.Pen.Style := psSolid; if FirstLine then begin if (RowStyle = 2) or (RowStyle = 3) then Dengine.drawrow(Round(rps2.x),Round(rps2.y),Round(rps1.x),Round(rps1.y),true); if (RowStyle = 5) or (RowStyle = 6) then Dengine.drawrow(Round(rps2.x),Round(rps2.y),Round(rps1.x),Round(rps1.y),false); end; If LastLine then begin if (RowStyle = 1) or (RowStyle = 3) then Dengine.drawrow(Round(rpe1.x),Round(rpe1.y),Round(rpe2.x),Round(rpe2.y),true); if (RowStyle = 4) or (RowStyle = 6) then Dengine.drawrow(Round(rpe1.x),Round(rpe1.y),Round(rpe2.x),Round(rpe2.y),false); end; end; end; procedure TPolyline.DrawFigureGuides(DEngine: TPCDrawEngine); var acolor : Tcolor; pdPoints: TDoublePointArr; r: HRGN; begin inherited; if drawStyle = dsTrace then DEngine.Canvas.Pen.Mode := pmXor else DEngine.Canvas.Pen.Mode := pmCopy; if JoinFigure1 <> nil then DEngine.drawselectionpoint(actualpoints[1].x,actualpoints[1].y,actualpoints[1].z,ptCross,pointdim,clRed); if JoinFigure2 <> nil then DEngine.drawselectionpoint(actualpoints[pointcount].x,actualpoints[pointcount].y,actualpoints[pointcount].z,ptCross,pointdim,clRed); if assigned(PenPattern) and (drawStyle = mydsNormal) and (selected) then begin aColor := clRed; DEngine.Canvas.Pen.Mode := pmCopy; CollectPolyBezierPoints(pdPoints); r := 1; DEngine.drawbezier(pdpoints,Length(pdPoints),aColor,width,style,aColor,brs,false,false, nil,r,0,rowL,rowH); end; end; procedure TPolyline.drawselectionpoints(DEngine: TPCDrawEngine;isGrayed:Boolean); var Layer: TLayer; a : integer; pt : TModPoint; aColor : TColor; fKnot:TPoint; lColor: integer; idx: Integer; x,y,z: Double; ap: TDoublePoint; begin if rMode then begin inherited; exit; end; // Tolik 24/21/2019 -- //For a := 0 to SelPoints.Count -1 do for a := SelPoints.Count -1 downto 0 do // begin pt := TModPoint(SelPoints[a]); if pt = nil then SelPoints.delete(a) else begin if isGrayed then acolor := TPCDrawing(Owner).FGrayedColor //06.08.2012 Grayedcolor else aColor := pt.Color; if isGrayed then lcolor := TPCDrawing(Owner).FGrayedColor //06.08.2012 Grayedcolor else lColor := clred; if pt.pType = ptPolyPoint then begin if selectedpoint = pt.SeqNbr then begin aColor := clRed; if SelectedPoint = PointCount then ap := ActualPoints[1] else ap := ActualPoints[selectedpoint+1]; DEngine.DrawLine(pt.CoordX,pt.CoordY,ap.x,ap.y,lcolor,1,ord(psDot),0); end; DrawSelPoint(DEngine,isGrayed,pt); end else if pt.PType = ptControlPoint then begin idx := pt.SeqNbr div 10; if idx = SelectedPoint then begin DrawSelPoint(DEngine,isGrayed,pt); ap := ActualPoints[idx]; DEngine.DrawLine(pt.CoordX,pt.CoordY,ap.x,ap.y,lcolor,1,style,0); end; end else if pt.PType = ptArcControl then begin DrawSelPoint(DEngine,isGrayed,pt); ap := ActualPoints[pt.SeqNbr]; DEngine.DrawLine(pt.CoordX,pt.CoordY,ap.x,ap.y,lcolor,1,style,0); if pt.SeqNbr = PointCount then idx := 1 else idx := pt.SeqNbr+1; ap := ActualPoints[idx]; DEngine.DrawLine(pt.CoordX,pt.CoordY,ap.x,ap.y,lcolor,1,style,0); end; x := pt.CoordX; y := pt.CoordY; z := pt.CoordY; DEngine.ConvertPoint(x,y,z); pt.PixX := Round(x); pt.PixY := Round(y); end; end; end; procedure TPolyLine.getModPoints(ModList: TMyList); var Layer: TLayer; ap : TDoublepoint; a: integer; ps1,ps2: TBezierPoint; cp1,cp2: TDoublePoint; cpx: integer; CControl:TPCdrawing; Segment: TPlSegment; begin CControl := TPCDrawing(Owner); cpx := 0; For a := 1 to PointCount do begin ap := actualpoints[a]; Segment := TPlSegment(Segments[a-1]); if (Segment.SType = sCurve) and not ((a = PointCount) and (not closed)) then begin cp1 := Segment.Cpoint1; cp2 := Segment.Cpoint2; cpx := (a*10)+2; ModList.Add(CControl.RegisterModPoint(self,ptControlPoint,ptRect,clRed,2, cp1.x,cp1.y,cpx)); if a = PointCount then cpx := ((1)*10)+1 else cpx := ((a+1)*10)+1; ModList.Add(CControl.RegisterModPoint(self,ptControlPoint,ptRect,clRed,2,cp2.x,cp2.y,cpx)); end else if (Segment.SType = sArc) then begin cp1 := Segment.Cpoint1; cpx := a; ModList.Add(CControl.RegisterModPoint(self,ptArcControl,ptRect,clGreen,2, cp1.x,cp1.y,cpx)); end; ModList.Add(CControl.RegisterModPoint(self,ptPolyPoint,ptCircle,clBlue,2,ap.x,ap.y,a)); end; end; //Tolik 02/08/2021 -- старая закомменчена - см ниже Procedure TPolyLine.getbounds(var figMaxX,figMaxY,figMinX,figMinY:double); var p1,p2 : TDoublePoint; a : integer; c1,c2: TDoublePoint; bfigMaxX,bfigMaxY,bfigMinX,bfigMinY: double; lp: integer; Segment: TPLSegment; a1,a2,at: double; radius: double; //aStateFig: string; begin // Tolik 02/05/2019 Try // {aStateFig := ''; try if Self.Parent <> nil then if Self.Parent.Parent <> nil then if Self.Parent.Parent.Cname = 'TFigureGrpMod' then aStateFig := SavedStateFig; except end; if (aStateFig = '') or (aStateFig = 'no state') then begin if Closed then lp := PointCount else lp := PointCount - 1; For a := 1 to lp do begin Segment := TPLSegment(Segments[a-1]); c1.x := 0; c1.y := 0; c1.z := 0; c2.x := 0; c2.y := 0; c2.z := 0; p1 := actualpoints[a]; if a = pointcount then p2 := actualpoints[1] else p2 := actualpoints[a+1]; aStateFig := aStateFig + '#' + FloatToStr(p1.x) + '*' + FloatToStr(p1.y) + '*' + FloatToStr(p1.z) + '*' + FloatToStr(p2.x) + '*' + FloatToStr(p2.y) + '*' + FloatToStr(p2.z); if Segment.SType = sLine then begin aStateFig := aStateFig + '*sLine'; end else if Segment.SType = sCurve then begin c1 := Segment.CPoint1; c2 := Segment.CPoint2; aStateFig := aStateFig + '*sCurve'; end else if Segment.SType = sArc then begin c1 := Segment.CPoint1; if Segment.Inverted then aStateFig := aStateFig + '*sArcInv' else aStateFig := aStateFig + '*sArc'; end; aStateFig := aStateFig + '*' + FloatToStr(c1.x) + '*' + FloatToStr(c1.y) + '*' + FloatToStr(c1.z) + '*' + FloatToStr(c2.x) + '*' + FloatToStr(c2.y) + '*' + FloatToStr(c2.z); end; end; } if (SavedfigMaxX = -$FFFFFF) and (SavedfigMaxY = -$FFFFFF) and (SavedfigMinX = -$FFFFFF) and (SavedfigMinY = -$FFFFFF) then begin //SavedStateFig := 'no state'; NeedBounds := True; end; //if (aStateFig <> SavedStateFig) or (aStateFig = '') or (aStateFig = 'no state') then if NeedBounds then begin figMaxX := ap1.x; figMinX := ap2.x; figMaxY := ap1.y; figMinY := ap2.y; if Closed then lp := PointCount else lp := PointCount -1; For a := 1 to lp do begin Segment := TPLSegment(Segments[a-1]); p1 := actualpoints[a]; if a = pointcount then p2 := actualpoints[1] else p2 := actualpoints[a+1]; if Segment.SType = sLine then begin if p1.x > figMaxX then figMaxX := p1.x; if p1.x < figMinX then figMinX := p1.x; if p1.y > figMaxY then figMaxY := p1.y; if p1.y < figMinY then figMinY := p1.y; if p2.x > figMaxX then figMaxX := p2.x; if p2.x < figMinX then figMinX := p2.x; if p2.y > figMaxY then figMaxY := p2.y; if p2.y < figMinY then figMinY := p2.y; end else if Segment.SType = sCurve then begin c1 := Segment.CPoint1; c2 := Segment.CPoint2; GetBezierBounds(p1,c1,c2,p2,bfigMaxX,bfigMaxY,bfigMinX,bfigMinY); if bfigMaxX > figMaxX then figMaxX := bfigMaxX; if bfigMinX < figMinX then figMinX := bfigMinX; if bfigMaxY > figMaxY then figMaxY := bfigMaxY; if bfigMinY < figMinY then figMinY := bfigMinY; end else if Segment.SType = sArc then begin c1 := Segment.CPoint1; a1 := GetRadOfLine(c1,p1); a2 := GetRadOfLine(c1,p2); if Segment.Inverted then begin at := a1; a1 := a2; a2 := at; end; radius := GetLineLenght(p1,c1); GetArcBounds(c1,radius,radius,0,a1,a2,0,bfigMaxX,bfigMaxY,bfigMinX,bfigMinY); if bfigMaxX > figMaxX then figMaxX := bfigMaxX; if bfigMinX < figMinX then figMinX := bfigMinX; if bfigMaxY > figMaxY then figMaxY := bfigMaxY; if bfigMinY < figMinY then figMinY := bfigMinY; end; end; //SavedStateFig := aStateFig; // Tolik 29/07/2021 -- SavedfigMaxX := figMaxX; SavedfigMinX := figMinX; SavedfigMaxY := figMaxY; SavedfigMinY := figMinY; NeedBounds := False; end else begin figMaxX := SavedfigMaxX; figMinX := SavedfigMinX; figMaxY := SavedfigMaxY; figMinY := SavedfigMinY; end; Except On E:Exception do begin AddExceptionToLog('TPolyLine.GetBouns Error = ' + E.Message); //ShowMessage('PolyLine Get Bouns Error. Id = ' + Inttostr(Id)); figMaxX := 0; figMinX := 0; figMaxY := 0; figMinY := 0; end; End; //aStateFig := '';//Tolik 29/07/2021 -- end; (* Procedure TPolyLine.getbounds(var figMaxX,figMaxY,figMinX,figMinY:double); var p1,p2 : TDoublePoint; a : integer; c1,c2: TDoublePoint; bfigMaxX,bfigMaxY,bfigMinX,bfigMinY: double; lp: integer; Segment: TPLSegment; a1,a2,at: double; radius: double; aStateFig: string; begin // Tolik 02/05/2019 Try // aStateFig := ''; try if Self.Parent <> nil then if Self.Parent.Parent <> nil then if Self.Parent.Parent.Cname = 'TFigureGrpMod' then aStateFig := SavedStateFig; except end; if (aStateFig = '') or (aStateFig = 'no state') then begin if Closed then lp := PointCount else lp := PointCount - 1; For a := 1 to lp do begin Segment := TPLSegment(Segments[a-1]); c1.x := 0; c1.y := 0; c1.z := 0; c2.x := 0; c2.y := 0; c2.z := 0; p1 := actualpoints[a]; if a = pointcount then p2 := actualpoints[1] else p2 := actualpoints[a+1]; aStateFig := aStateFig + '#' + FloatToStr(p1.x) + '*' + FloatToStr(p1.y) + '*' + FloatToStr(p1.z) + '*' + FloatToStr(p2.x) + '*' + FloatToStr(p2.y) + '*' + FloatToStr(p2.z); if Segment.SType = sLine then begin aStateFig := aStateFig + '*sLine'; end else if Segment.SType = sCurve then begin c1 := Segment.CPoint1; c2 := Segment.CPoint2; aStateFig := aStateFig + '*sCurve'; end else if Segment.SType = sArc then begin c1 := Segment.CPoint1; if Segment.Inverted then aStateFig := aStateFig + '*sArcInv' else aStateFig := aStateFig + '*sArc'; end; aStateFig := aStateFig + '*' + FloatToStr(c1.x) + '*' + FloatToStr(c1.y) + '*' + FloatToStr(c1.z) + '*' + FloatToStr(c2.x) + '*' + FloatToStr(c2.y) + '*' + FloatToStr(c2.z); end; end; if (SavedfigMaxX = -$FFFFFF) and (SavedfigMaxY = -$FFFFFF) and (SavedfigMinX = -$FFFFFF) and (SavedfigMinY = -$FFFFFF) then begin SavedStateFig := 'no state'; end; if (aStateFig <> SavedStateFig) or (aStateFig = '') or (aStateFig = 'no state') then begin figMaxX := ap1.x; figMinX := ap2.x; figMaxY := ap1.y; figMinY := ap2.y; if Closed then lp := PointCount else lp := PointCount -1; For a := 1 to lp do begin Segment := TPLSegment(Segments[a-1]); p1 := actualpoints[a]; if a = pointcount then p2 := actualpoints[1] else p2 := actualpoints[a+1]; if Segment.SType = sLine then begin if p1.x > figMaxX then figMaxX := p1.x; if p1.x < figMinX then figMinX := p1.x; if p1.y > figMaxY then figMaxY := p1.y; if p1.y < figMinY then figMinY := p1.y; if p2.x > figMaxX then figMaxX := p2.x; if p2.x < figMinX then figMinX := p2.x; if p2.y > figMaxY then figMaxY := p2.y; if p2.y < figMinY then figMinY := p2.y; end else if Segment.SType = sCurve then begin c1 := Segment.CPoint1; c2 := Segment.CPoint2; GetBezierBounds(p1,c1,c2,p2,bfigMaxX,bfigMaxY,bfigMinX,bfigMinY); if bfigMaxX > figMaxX then figMaxX := bfigMaxX; if bfigMinX < figMinX then figMinX := bfigMinX; if bfigMaxY > figMaxY then figMaxY := bfigMaxY; if bfigMinY < figMinY then figMinY := bfigMinY; end else if Segment.SType = sArc then begin c1 := Segment.CPoint1; a1 := GetRadOfLine(c1,p1); a2 := GetRadOfLine(c1,p2); if Segment.Inverted then begin at := a1; a1 := a2; a2 := at; end; radius := GetLineLenght(p1,c1); GetArcBounds(c1,radius,radius,0,a1,a2,0,bfigMaxX,bfigMaxY,bfigMinX,bfigMinY); if bfigMaxX > figMaxX then figMaxX := bfigMaxX; if bfigMinX < figMinX then figMinX := bfigMinX; if bfigMaxY > figMaxY then figMaxY := bfigMaxY; if bfigMinY < figMinY then figMinY := bfigMinY; end; end; //SavedStateFig := aStateFig; // Tolik 29/07/2021 -- SavedfigMaxX := figMaxX; SavedfigMinX := figMinX; SavedfigMaxY := figMaxY; SavedfigMinY := figMinY; end else begin figMaxX := SavedfigMaxX; figMinX := SavedfigMinX; figMaxY := SavedfigMaxY; figMinY := SavedfigMinY; end; Except On E:Exception do begin //ShowMessage('PolyLine Get Bouns Error. Id = ' + Inttostr(Id)); figMaxX := 0; figMinX := 0; figMaxY := 0; figMinY := 0; end; End; aStateFig := '';//Tolik 29/07/2021 -- end; *) function TPolyLine.isPointIn(x,y:double): boolean; var a : integer; lp: Integer; begin result := false; if ((TBrushStyle(brs) <> bsClear) or (brushbitmap <> nil) or (HatchSeg > -1) ) and (closed) then begin {if IsPointInRegion(x,y) then result := true;} //Tolik if IsPointInRegionByRegObj(x,y) then result := True; // end; if result = true then exit; if closed then lp := PointCount else lp := pointcount-1; For a := 1 to lp do begin if IsPointInSegment(a, x, y) then begin result := true; SelectedPoint := a; exit; end; end; end; function TPolyLine.isPointInSegment(SegNbr: Integer; x, y: Double): boolean; var p1,p2 : TDoublePoint; c1,c2 : TDoublePoint; Segment: TPLSegment; a1,a2,at,z: Double; Radius: Double; DEngine : TPCDrawEngine; begin result := false; Segment := TPLSegment(Segments[SegNbr-1]); p1 := actualpoints[SegNbr]; if SegNbr = PointCount then p2 := actualpoints[1] else p2 := actualpoints[SegNbr+1]; if Segment.SType = sLine then begin if assigned(owner) then begin DEngine := TPCDrawing(owner).DEngine; z := 0; Dengine.ConvertPoint(p1.x,p1.y,z); Dengine.ConvertPoint(p2.x,p2.y,z); Dengine.ConvertPoint(x,y,z); end; if ispointinLine(p1,p2,DoublePoint(x,y),width) then begin result := true; end; end else if Segment.SType = sCurve then begin c1 := Segment.CPoint1; c2 := Segment.CPoint2; if ispointinBezier(p1,c1,c2,p2,DoublePoint(x,y)) then begin result := true; end; end else if Segment.SType = sArc then begin c1 := Segment.CPoint1; a1 := GetRadOfLine(c1,p1); a2 := GetRadOfLine(c1,p2); if Segment.Inverted then begin at := a1; a1 := a2; a2 := at; end; radius := GetLineLenght(p1,c1); if IspointInArc(DoublePoint(x,y),c1,Radius,0,a1,a2) then result := true; end; end; function TPolyline.Knife(p1, p2: TdoublePoint; Figures: TList): Boolean; begin KnifePoint1 := p1; KnifePoint2 := p2; Knifing := True; result := inherited Knife(p1,p2,Figures); Knifing := False; NeedBounds := True; //Tolik 02/08/2021 -- end; function TPolyline.BreakByPoint(p: TdoublePoint;var Figures: TList): boolean; var lCnt,pCnt: Integer; xp1,xp2,xp3,xp4: TdoublePoint; pArr: TDoublePointArr; i,k,idx,oIndex: Integer; Fig: TPolyline; res: boolean; segment,seg1,seg2,xSeg,ySeg: TPLSegment; begin if closed then lCnt := PointCount else lCnt := PointCount-1; result := false; pCnt := 0; for i := 1 to lcnt do begin xp1 := ActualPoints[i]; xp2 := ActualPoints[i+1]; segment := TPLSegment(Segments[i-1]); if segment.BreakByPoint(xp1,xp2,p,seg1,seg2,knifing,knifepoint1,knifepoint2) then begin result := true; if closed then begin pCnt := PointCount +2; SetLength(pArr,pCnt); pArr[0] := p; idx := 0; for k := i+1 to PointCount do begin idx := idx+1; pArr[idx] := ActualPoints[k]; end; for k := 1 to i do begin idx := idx+1; pArr[idx] := ActualPoints[k]; end; pArr[pCnt-1] := p; fig := TPolyline.create(pArr,width,style,color,brs,brc,ord(rowstyle),false,LayerHandle,mydsNormal,owner); Figures.Add(fig); xSeg := TPlSegment(fig.Segments[0]); xSeg.CopyFrom(seg2); for k := 2 to fig.PointCount-2 do begin xSeg := TPlSegment(fig.Segments[k-1]); oIndex := i+k-1; if oIndex > PointCount then oIndex := oIndex-PointCount; ySeg := Segments[oIndex-1]; xSeg.CopyFrom(ySeg); end; xSeg := TPlSegment(fig.Segments[fig.PointCount-2]); xSeg.CopyFrom(seg1); end else begin pCnt := PointCount - i +1; SetLength(pArr,pCnt); pArr[0] := p; for k := i+1 to PointCount do pArr[k-i] := ActualPoints[k]; fig := TPolyline.create(pArr,width,style,color,brs,brc,ord(rowstyle),false,LayerHandle,mydsNormal,owner); Figures.Add(fig); xSeg := TPlSegment(fig.Segments[0]); xSeg.CopyFrom(seg2); for k := 2 to fig.PointCount-1 do begin xSeg := TPlSegment(fig.Segments[k-1]); oIndex := i+k-1; if oIndex > PointCount then oIndex := oIndex-PointCount; ySeg := Segments[oIndex-1]; xSeg.CopyFrom(ySeg); end; pCnt := i+1; SetLength(pArr,pCnt); pArr[pCnt-1] := p; for k := 1 to i do pArr[k-1] := ActualPoints[k]; fig := TPolyline.create(pArr,width,style,color,brs,brc,ord(rowstyle),false,LayerHandle,mydsNormal,owner); Figures.Add(fig); for k := 1 to fig.PointCount-2 do begin xSeg := TPlSegment(fig.Segments[k-1]); oIndex := k; ySeg := Segments[oIndex-1]; xSeg.CopyFrom(ySeg); end; xSeg := TPlSegment(fig.Segments[fig.PointCount-2]); xSeg.CopyFrom(seg1); end; end; end; //Tolik 24/05/2019 -- SetLength(pArr, 0); // end; function TPolyline.GetLinearInterSections(p1, p2: TDoublePoint; var pArr: TDoublePointArr): Boolean; var lCnt,pCnt,i,k,iCnt: Integer; xp1,xp2,xp3,xp4,p,cp,np1,np2: TdoublePoint; ires: Boolean; pbArr: TDoublePointArr; a,rad: Double; seg: TPLsegment; function isAngleIn(ang:Double):Boolean; begin result := true; end; begin if closed then lCnt := PointCount else lCnt := PointCount-1; pCnt := 0; for i := 1 to lcnt do begin xp1 := ActualPoints[i]; xp2 := ActualPoints[i+1]; ires := false; seg := TPLSegment(Segments[i-1]); if seg.SType = sLine then begin ires := GetIntersectionPoint(p1,p2,xp1,xp2,p,false); if ires then begin pCnt := pCnt+1; SetLength(pArr,pCnt); pArr[pCnt-1] := p; end; end else if seg.SType = sCurve then begin xp4 := xp2; xp2 := TPLSegment(Segments[i-1]).CPoint1; xp3 := TPLSegment(Segments[i-1]).CPoint2; SetLength(pbArr,0); ires := GetLineBezierIntersection(p1,p2,xp1,xp2,xp3,xp4,pbArr,iCnt,false); if ires then begin pCnt := pCnt+iCnt; SetLength(pArr,pCnt); for k := 1 to iCnt do pArr[pCnt-k] := pbArr[iCnt-k]; end; end else begin cp := seg.CPoint1; rad := GetLineLenght(xp1,cp); if GetLineCircleIntersection(p1,p2,cp,rad,np1,np2,icnt,false) then begin if iCnt > 0 then begin a := GetradOfLine(cp,np1); if isPointInSegment(i,np1.x,np1.y) then begin pCnt := pCnt+1; SetLength(pArr,pCnt); pArr[pCnt-1] := np1; end; end; if iCnt > 1 then begin if isPointInSegment(i,np2.x,np2.y) then begin pCnt := pCnt+1; SetLength(pArr,pCnt); pArr[pCnt-1] := np2; end; end; end; end; end; result := (pCnt > 0); // Tolik 24/05/2019- - SetLength(pbArr, 0); // end; function TPolyLine.duplicate:TFigure; var res : TPolyLine; newpoints : TDoublePointArr; a: integer; ps: TBezierPoint; begin SetLength(newPoints,2); newPoints[0] := ap1; newPoints[1] := ap2; res := TPolyLine.create( newPoints, width, style, color, brs, brc, RowStyle, Closed, LayerHandle, DrawStyle,Owner); res.angle := angle; res.PointCount := PointCount; for a := 1 to PointCount do begin res.originalpoints[a] := originalpoints[a]; res.actualpoints[a] := actualpoints[a] ; end; res.ClearSegments; for a := 0 to Segments.Count-1 do res.Segments.Add(TplSegment(segments[a]).Duplicate); res.rotPoint.x := rotpoint.x ; res.rotPoint.y := rotpoint.y ; res.AngleToPoint := AngleToPoint; if assigned(PenPattern) then res.PenPattern := PenPattern.Duplicate else res.PenPattern := nil; result := res; // Tolik 24/05/2019- - SetLength(NewPoints, 0); // end; destructor TPolyline.Destroy; begin SavedStateFig := '';//Tolik 29/07/2021 -- ClearSegments; Segments.free; // Tolik 16/01/2020 //Tolik if PenPattern <> nil then FreeAndNil(PenPattern); // // Tolik 24/05/2019 -- SetLength(HatchLines, 0); // inherited; end; procedure TPolyline.GetVectorObjects(Objects: Tlist; BaseP: TDoublePoint); var obj: TvectorObject; p: array of TDoublePoint; p1: TDoublePoint; i: Integer; seg: TPlSegment; begin SetLength(p,PointCount); for i := 1 to pointcount do begin p1 := ActualPoints[i]; p1 := DoublePoint(p1.x-baseP.x,p1.y-baseP.y); p[i-1] := p1; end; if closed then obj := TVectorObject.CreatePolygonObject(PointCount,p) else obj := TVectorObject.CreatePolylineObject(PointCount,p); Objects.Add(obj); // Tolik 24/05/2019 -- SetLength(p, 0); // end; (* ========================================================================== *) // TELLIPSE IMPLEMENTATION // (* ========================================================================== *) constructor TEllipse.create(cX,cY,len1,len2,aAngle:Double; w,s,c,abrs,abrc:integer;LHandle:LongInt; aDrawStyle: TDrawStyle;aOwner: TComponent); begin inherited create(LHandle, aDrawStyle,aOwner); initialize; alen := len1; blen := len2; actualpoints[1] := DoublePoint(cx,cy); originalpoints[1] := DoublePoint(cx,cy); originalpoints[2] := RotatePoint(ap1,DoublePoint(ap1.x + aLen,ap1.y),aAngle); actualpoints[2] := originalpoints[2]; width := w; color := c; style := s; brs := abrs; brc := abrc; angle := aAngle; //RefreshBounds; end; (* Constructor TEllipse.create3P(cX,cY,x1,y1,x2,y2:Double;w,s,c,abrs,abrc:integer; LHandle:LongInt;aDrawStyle : TDrawStyle;aOwner: TComponent); begin inherited create(LHandle,aDrawStyle,aOwner); initialize; originalpoints[1] := DoublePoint(cx,cy); originalpoints[2] := DoublePoint(x1,y1); originalpoints[3] := DoublePoint(x2,y2); actualpoints[1] := originalpoints[1]; actualpoints[2] := originalpoints[2]; actualpoints[3] := originalpoints[3]; width := w; color := c; style := s; brs := abrs; brc := abrc; //RefreshBounds; end; *) class Function TEllipse.CreateShadow(x,y:Double): TFigure; begin result := TEllipse.create(x,y,0,0,0,1,1,clLime,0,0,0,dsTrace,nil); end; Function Tellipse.CreateModification: TFigure; begin result := TEllipse.create(ap1.x,ap1.y,ALen,Blen,angle,1,1,clLime,0,0,0,dsTrace,nil); if assigned(result) then result.RotPoint := RotPoint; end; procedure TEllipse.Initialize; begin inherited; pointcount := 2; end; function TEllipse.EndModification(CadControl: Pointer;mp: TModPoint; TraceFigure: TFigure; x, y: Double;Shift: TShiftState): boolean; var xAngle: Double; p1: TDoublePOint; begin if mp.SeqNbr = 2 then ALen := sqrt( sqr(x - ap1.x)+sqr(y - ap1.y) ) else if mp.SeqNbr = 3 then BLen := sqrt( sqr(x - ap1.x)+sqr(y - ap1.y) ) else if (mp.SeqNbr = 4) then begin p1 := DoublePoint(x,y); xAngle := GetRadOfLine(ap1,p1); p1 := DoublePoint(ap1.x-ALen,ap1.y); ActualPoints[2] := RotatePoint(ap1,p1,xAngle); end; ResetRegion; Modified := True; end; function TEllipse.ShadowClick(ClickIndex:Integer;x,y:Double): Boolean; var cp,p1: TDoublePoint; begin result := false; if clickIndex = 2 then begin ALen := sqrt(sqr(x - ap1.x)+ sqr(y - ap1.y)); BLen := ALen; end else if clickIndex = 3 then begin BLen := sqrt(sqr(x - ap1.x)+ sqr(y - ap1.y)); result := True; end; end; class function TEllipse.CreateFromShadow(aOwner: TComponent; LHandle: Integer; Shadow: TFigure): TFigure; var cad: TPCDrawing; begin cad := TPCDrawing(aOwner); Result := TEllipse.create(shadow.ap1.x,shadow.ap1.y, TEllipse(shadow).aLen, TEllipse(shadow).bLen,0, cad.DefaultPenWidth, ord(cad.DefaultPenStyle), cad.DefaultPenColor, ord(cad.DefaultBrushStyle), cad.DefaultBrushColor, LHandle, mydsNormal,aOwner); end; function TEllipse.ShadowTrace(ClickIndex:Integer;x, y: Double): Boolean; var rad:Double; begin If ClickIndex = 1 then begin rad := sqrt(sqr(x - ap1.x)+ sqr(y - ap1.y)); ALen := rad; BLen := rad; end else If ClickIndex = 2 then begin rad := sqrt(sqr(x - ap1.x)+ sqr(y - ap1.y)); BLen := Rad; end; end; function TEllipse.TraceModification(CadControl: Pointer;mp: TModPoint;TraceFigure:TFigure; x, y: Double;Shift: TShiftState): boolean; var xAngle: Double; p1: TDoublePOint; begin if (mp.SeqNbr = 2) then begin TEllipse(TraceFigure).Alen := sqrt( sqr(x - ap1.x)+sqr(y - ap1.y)); end else if (mp.SeqNbr = 3) then begin TEllipse(TraceFigure).BLen := sqrt( sqr(x - ap1.x)+sqr(y - ap1.y)); end else if (mp.SeqNbr = 4) then begin p1 := DoublePoint(x,y); xAngle := GetRadOfLine(ap1,p1); p1 := DoublePoint(ap1.x-ALen,ap1.y); TEllipse(TraceFigure).ActualPoints[2] := RotatePoint(ap1,p1,xAngle); end; end; procedure TEllipse.WriteToStream(Stream: TStream); var xByte: Byte; xInt: Integer; xDbl: Double; begin inherited; // Tolik 22/11/2019 -- //xByte := brs; if brs = -1 then xByte := 255 else xByte := LoByte(LoWord(brs)); // WriteField(90,Stream,xByte,1); xInt := brc; WriteField(20,Stream,xInt,4); xDbl := alen; WriteField(220,Stream,xDbl,8); xDbl := bLen; WriteField(221,Stream,xDbl,8); end; Procedure TEllipse.SetPropertyFromStream(xCode:Byte;data:pointer;size:integer); var ByteVal: Byte; begin Case xcode of 20: brc := pInt(data)^; 21: aLen := pInt(data)^/10; 22: bLen := pInt(data)^/10; 90: begin if pByte(data)^ = 255 then brs := -1 else brs := pByte(data)^; end; 220: aLen := pDouble(data)^; 221: bLen := pDouble(data)^; end; end; procedure TEllipse.SetSpecialPropertiesFromStream(Stream: TStream); var p1: TDOublePoint; begin inherited; if PointCount = 3 then begin // old format PointCount := 2; RedimenPoints; p1 := DoublePoint(ap1.x-ALen,ap1.y); ActualPoints[2] := RotatePoint(ap1,p1,Angle); end; end; function TEllipse.DuplicateAsBezier: TFigure; var Points: T2DPointArray; cnt,i: Integer; p: TDoublePoint; pp: TDoublePointArr; res: TPolyline; begin if (ap2.y = ap1.y) then if (ap2.x > ap1.x) then angle := 0 else angle := pi else if (ap2.x = ap1.x) then if (ap2.y > ap1.y) then angle := -1*(pi/2) else angle := pi/2 else begin Angle := GetRadOfLine(ap1,ap2); end; BezierElpArcPoints(Points,ap1.x,ap1.y,ALen,Blen,angle,0,2*pi); cnt := Length(Points); SetLength(pp,cnt); for i := 0 to cnt-1 do begin p := DoublePoint(Points[i].x,Points[i].y); pp[i] := p; end; SetLength(Points,0); result := TPolyline.createFromBezierPoints(pp,Width,Style,color,Brs,Brc,0, True,Layerhandle,mydsNormal,owner); // Tolik 24/05/2019 -- SetLength(pp,0); // end; function TEllipse.GetLinearInterSections(p1, p2: TDoublePoint; var pArr: TDoublePointArr): Boolean; var np1,np2: TDoublePoint; icnt: Integer; begin result := false; if GetLineEllipseIntersection(p1,p2,ap1,aLen,bLen,Angle,np1,np2,icnt,false) then begin SetLength(pArr,iCnt); if icnt > 0 then pArr[0] := np1; if icnt > 1 then pArr[1] := np2; result:= true; end; end; function TEllipse.BreakByPoint(p: TdoublePoint; var Figures: TList): boolean; var a1:Double; fig: TFigure; pt: TDoublePoint; begin result := false; pt := DoublePoint(p.x,p.y); pt := RotatePoint(ap1,pt,-1*angle); a1 := GetRadOfLine(ap1,pt); if isPointInEllipse(p.x,p.y,ap1.x,ap1.y,Alen,Blen,Angle) then begin result := true; fig := TElpArc.create(ap1.x,ap1.y,aLen,Blen,a1,a1,Angle,width,style,color, brs,brc,0,LayerHandle,mydsNormal,owner); Figures.Add(fig); end; end; procedure TEllipse.draw(DEngine:TPCDrawEngine;isGrayed:Boolean); var acolor,bcolor : Tcolor; nbrPoints : integer; a: Integer; aawidth: integer; begin aawidth := width; if width > 1 then begin if TPCDrawing(owner).ZoomScale < 100 then begin aawidth := Trunc(width * (TPCDrawing(owner).ZoomScale / 100)); if aawidth = 0 then aawidth := 1; end; end; acolor := color; if (aColor = -255) and (LayerHandle <> 0) then begin aColor := TLayer(LayerHandle).PenColor; end; bColor := brc; if (bColor = -255) and (LayerHandle <> 0) then begin bColor := TLayer(LayerHandle).BrushColor; end; if (isGrayed) then begin acolor := TPCDrawing(Owner).FGrayedColor; //06.08.2012 GrayedColor; bcolor := TPCDrawing(Owner).FGrayedColor; //06.08.2012 GrayedColor; end; if dRawStyle = dsTrace then DEngine.canvas.pen.mode := pmXor else DEngine.canvas.pen.mode := pmCopy; if (ap2.y = ap1.y) then if (ap2.x > ap1.x) then angle := 0 else angle := pi else if (ap2.x = ap1.x) then if (ap2.y > ap1.y) then angle := -1*(pi/2) else angle := pi/2 else begin Angle := GetRadOfLine(ap1,ap2); end; if NeedRegion then DEngine.drawbezierEllipse(ap1.x,ap1.y,alen,blen,angle,acolor, aawidth,style, bcolor,GDIbrs,regHandle,InCombined); DrawFill(Dengine,isGrayed); DrawClipFigures(Dengine,isGrayed); DEngine.drawbezierEllipse(ap1.x,ap1.y,alen,blen,angle,acolor, aawidth,style, bcolor,GDIbrs,regHandle,InCombined); //Tolik if RegHandle <> 0 then begin GetRegObject; deleteObject(RegHandle); RegHandle := 0; end; end; Procedure TEllipse.Scale(percentx,percenty: double; rPoint: TDoublepoint); var p1,p2:TDoublePoint; cp: TDoublePOint; Begin cp := ap1; Inherited; p1 := DoublePoint(cp.x+Alen,cp.y); p2 := DoublePoint(cp.x,cp.y+Blen); p1 := RotatePoint(cp,p1,Angle); p2 := RotatePoint(cp,p2,Angle); p1 := ScalePoint(rPoint,p1,percentx,percenty); p2 := ScalePoint(rPoint,p2,percentx,percenty); ALen := GetLineLenght(ap1,p1); Blen := GetLineLenght(ap1,p2); End; procedure TEllipse.Mirror(Point1, Point2: TDoublepoint); begin inherited; //RefreshBounds; end; procedure TEllipse.Move(deltax, deltay: Double); begin inherited; //RefreshBounds; end; procedure TEllipse.Rotate(aAngle: double; cPoint: TDoublepoint); begin inherited; //RefreshBounds; end; procedure TEllipse.getModPoints(ModList: TMyList); var p4,p5,p6: TDoublePoint; CControl: TPCDrawing; begin CControl := TPCDrawing(Owner); p4 := DoublePoint(ap1.x+Alen,ap1.y); p5 := DoublePoint(ap1.x,ap1.y+Blen); p6 := DoublePoint(ap1.x-Alen,ap1.y); p4 := RotatePoint(ap1,p4,Angle); p5 := RotatePoint(ap1,p5,Angle); p6 := RotatePoint(ap1,p6,Angle); if (Alen = 0) and (Blen = 0) then begin ModList.Add(CControl.RegisterModPoint(self,ptArcEnd,ptCircle,clRed,2,p4.x,p4.y,4)); end else begin ModList.Add(CControl.RegisterModPoint(self,ptUndefined,ptCross,clBlue,pointdim,ap1.x,ap1.y,1)); ModList.Add(CControl.RegisterModPoint(self,ptArcEnd,ptRect,clRed,2,p4.x,p4.y,2)); ModList.Add(CControl.RegisterModPoint(self,ptArcEnd,ptRect,clRed,2,p5.x,p5.y,3)); ModList.Add(CControl.RegisterModPoint(self,ptArcEnd,ptCircle,clGreen,4,p6.x,p6.y,4)); end; end; procedure TEllipse.VerifyZeroPoints(orgV, orgH: Byte); begin inherited; //RefreshBounds; end; (* procedure TEllipse.RefreshBounds; var DeltaX,Deltay: Double; begin if (ap2.y = ap1.y) then if (ap2.x > ap1.x) then angle := 0 else angle := pi else if (ap2.x = ap1.x) then if (ap2.y > ap1.y) then angle := -1*(pi/2) else angle := pi/2 else begin DeltaX := (ap2.x - ap1.x); DeltaY := (ap2.y - ap1.y); Angle := GetRadOfLine(ap1,ap2); end; ALen := sqrt(sqr(ap2.x-ap1.x)+sqr(ap2.y-ap1.y)); BLen := sqrt(sqr(ap3.x-ap1.x)+sqr(ap3.y-ap1.y)); GetEllipseBounds(ap1.x,ap1.y,alen,blen,-1*angle,elpRes,ElpBounds); end; *) procedure TEllipse.getbounds(var figMaxX,figMaxY,figMinX,figMinY: Double); begin GetArcBounds(ap1,Alen,Blen,0,0,2*pi,Angle,figMaxX,figMaxY,figMinX,figMinY); end; function TEllipse.isPointIn(x,y:Double):boolean; var cx,cy,nx,ny: Double; ctrl: real; p2,pt,pc : TDoublePoint; begin result := false; result := inherited isPointIn(x,y); if result then exit; result := isPointInellipse(x,y,ap1.x,ap1.y,Alen,Blen,Angle); if (not result) and (TBrushStyle(brs) <> bsClear) then if IsPointInRegion(x,y) then result := true; //Tolik if (not result) and (TBrushStyle(brs) <> bsClear) then // if IsPointInRegion(x,y) then result := true; if IsPointInRegionByRegObj(x,y) then result := true; // end; function TEllipse.duplicate:TFigure; var res : TEllipse; begin res := TEllipse.create( originalpoints[1].x, originalpoints[1].y, alen, blen, angle, width, style, color, brs, brc, LayerHandle, DrawStyle,Owner); res.angle := angle; res.actualpoints[1] := actualpoints[1]; res.actualpoints[2] := actualpoints[2]; res.rotPoint.x := rotPoint.x ; res.rotPoint.y := rotPoint.y ; res.AngleToPoint := AngleToPoint; result := res; end; procedure TEllipse.GetVectorObjects(Objects: Tlist; BaseP: TDoublePoint); var obj: TvectorObject; p1: TDoublePoint; begin p1 := DoublePoint(ap1.x-baseP.x,ap1.y-baseP.y); obj := TVectorObject.CreateEllipseObject(p1,aLen,bLen); Objects.Add(obj); end; (* ========================================================================== *) // TCIRCLE IMPLEMENTATION // (* ========================================================================== *) constructor TCircle.create(cX,cY,rad: Double;w,s,c,abrs,abrc:integer; LHandle:LongInt; aDrawStyle: TDrawStyle;aOwner: TComponent); begin inherited create(LHandle,aDrawStyle,aOwner); Initialize; originalpoints[1] := DoublePoint(cx,cy); actualpoints[1] := DoublePoint(cx,cy); radius := rad; width := w; color := c; style := s; brs := abrs; brc := abrc; Hatched := False; end; class function TCircle.ShadowType:TShadowType; begin result := stCircle; end; procedure TCircle.Initialize; begin inherited; pointcount := 1; end; procedure TCircle.scale(percentx, percenty: double; rPoint: Tdoublepoint); var cad: TPCDrawing; Index: Integer; elp: TEllipse; begin if percentx <> percenty then begin if assigned(owner) then begin Cad := TPCdrawing(owner); Index := Cad.Figures.IndexOf(Self); if Index <> -1 then begin elp := TEllipse.create(ap1.x,ap1.y,radius,radius,0,Width,Style, Color,brs,brc,LayerHandle,mydsNormal,Owner); elp.Scale(percentx,percenty,rPoint); Cad.Figures[Index] := elp; Destroy; end; end; end else inherited; end; function TCircle.EndModification(CadControl: Pointer;mp: TModPoint; TraceFigure: TFigure; x,y: Double;Shift: TShiftState): boolean; begin Radius := TCircle(TraceFigure).Radius; ResetRegion; Modified := True; end; function TCircle.ShadowClick(ClickIndex:Integer;x, y: Double): Boolean; begin result := false; if clickindex = 2 then result := true; end; class function TCircle.CreateFromShadow(aOwner: TComponent; LHandle: Integer; Shadow: TFigure): TFigure; var cad: TPCDrawing; begin cad := TPCDrawing(aOwner); Result := TCircle.create(shadow.ap1.x,shadow.ap1.y, shadow.radius, cad.DefaultPenWidth, ord(cad.DefaultPenStyle), cad.DefaultPenColor, ord(cad.DefaultBrushStyle), cad.DefaultBrushColor, LHandle, mydsNormal,aOwner); end; function TCircle.ShadowTrace(ClickIndex:Integer;x,y: Double): Boolean; begin radius := sqrt( sqr(x - ap1.x)+ sqr(y - ap1.y)); end; function TCircle.TraceModification(CadControl: Pointer;mp: TModPoint; TraceFigure:TFigure; x, y: Double;Shift: TShiftState): boolean; begin TraceFigure.Radius := sqrt( sqr(x - TraceFigure.ap1.x)+ sqr(y - TraceFigure.ap1.y) ); end; procedure TCircle.WriteToStream(Stream: TStream); var xByte: Byte; xInt: Integer; xDbl: Double; begin inherited; // Tolik 22/11/2019 -- //xByte := brs; if brs = -1 then xByte := 255 else xByte := LoByte(LoWord(brs)); // WriteField(90,Stream,xByte,1); xInt := brc; WriteField(20,Stream,xInt,4); xDbl := Radius; WriteField(220,Stream,xDbl,8); end; Procedure TCircle.SetPropertyFromStream(xCode:Byte;data:pointer;size:integer); begin Case xcode of 20: brc := pInt(data)^; 21: Radius := pInt(data)^/10; 90: begin if pByte(data)^ = 255 then brs := -1 else brs := pByte(data)^; end; 220: Radius := pDouble(data)^; end; end; procedure TCircle.draw(DEngine: TPCDrawEngine;isGrayed:Boolean); var acolor,bcolor : Tcolor; aawidth: integer; begin aawidth := width; if width > 1 then begin if TPCDrawing(owner).ZoomScale < 100 then begin aawidth := Trunc(width * (TPCDrawing(owner).ZoomScale / 100)); if aawidth = 0 then aawidth := 1; end; end; acolor := color; bColor := brc; if (aColor = -255) and (LayerHandle <> 0) then begin aColor := TLayer(LayerHandle).PenColor; end; if (bColor = -255) and (LayerHandle <> 0) then begin bColor := TLayer(LayerHandle).BrushColor; end; if (isGrayed) then begin acolor := TPCDrawing(Owner).FGrayedColor; //06.08.2012 GrayedColor; bcolor := TPCDrawing(Owner).FGrayedColor; //06.08.2012 GrayedColor; end; if DrawStyle = dsTrace then DEngine.canvas.pen.mode := pmXor else DEngine.canvas.pen.mode := pmCopy; if NeedRegion then DEngine.drawcircle(ap1.x,ap1.y,radius,acolor, aawidth,style,bcolor,GDIbrs,RegHandle,InCombined,Hatched); DrawFill(Dengine,isGrayed); DrawClipFigures(Dengine,isGrayed); DEngine.drawcircle(ap1.x,ap1.y,radius,acolor, aawidth,style,bcolor,GDIbrs,RegHandle,InCombined,Hatched); //Tolik if RegHandle <> 0 then begin GetRegObject; if TBrushStyle(brs) <> bsClear then RegObject.CheckPointByRects := true; deleteObject(RegHandle); RegHandle := 0; end; // end; procedure TCircle.DrawFigureGuides(DEngine: TPCDrawEngine); begin inherited; // if DrawStyle = dsTrace then DEngine.canvas.pen.mode := pmXor else // DEngine.canvas.pen.mode := pmCopy; // Dengine.drawselectionpoint(ap1.x,ap1.y,ap1.z,ptCross,pointdim,clRed); end; procedure TCircle.getModPoints(ModList: TMyList); var CControl : TPCDrawing; begin CControl := TPCDrawing(Owner); ModList.Add(CControl.RegisterModPoint(self,ptCirclePoint,ptRect,clBlue,pointdim,ap1.x,ap1.y + radius,0)); ModList.Add(CControl.RegisterModPoint(self,ptCirclePoint,ptRect,clBlue,pointdim,ap1.x,ap1.y - radius,0)); ModList.Add(CControl.RegisterModPoint(self,ptCirclePoint,ptRect,clBlue,pointdim,ap1.x+radius,ap1.y,0)); ModList.Add(CControl.RegisterModPoint(self,ptCirclePoint,ptRect,clBlue,pointdim,ap1.x-radius,ap1.y,0)); end; procedure TCircle.getbounds(var figMaxX,figMaxY,figMinX,figMinY: Double); begin figMaxX := ap1.x+radius; figMinX := ap1.x-radius; figMaxY := ap1.y+radius; figMinY := ap1.y-radius; end; function TCircle.isPointIn(x,y:Double):boolean; var a,b,cx,cy,nx,ny: real; ctrl: real; begin result := false; result := inherited isPointIn(x,y); if result then exit; result := isPointInCircle(x,y,ap1.x,ap1.y,radius); if TBrushStyle(brs) <> bsClear then begin if isPointInRegion(x,y) then result := true; //Tolik if IsPointInRegionByRegObj(x,y) then result := true; // end; end; function TCircle.DuplicateAsBezier: TFigure; var Points: T2DPointArray; cnt,i: Integer; p: TDoublePoint; pp: TDoublePointArr; res: TPolyline; begin BezierElpArcPoints(Points,ap1.x,ap1.y,Radius,Radius,0,0,2*pi); cnt := Length(Points); SetLength(pp,cnt); for i := 0 to cnt-1 do begin p := DoublePoint(Points[i].x,Points[i].y); pp[i] := p; end; SetLength(Points,0); result := TPolyline.createFromBezierPoints(pp,Width,Style,color,Brs,Brc,0, True,Layerhandle,mydsNormal,owner); end; function TCircle.duplicate:TFigure; var res : TCircle; begin res := Tcircle.create( originalpoints[1].x, originalpoints[1].y, radius, width, style, color, brs, brc, LayerHandle, drawstyle,Owner); res.angle := angle; res.actualpoints[1] := actualpoints[1]; res.rotPoint.x := rotPoint.x ; res.rotPoint.y := rotPoint.y ; res.AngleToPoint := AngleToPoint; result := res; end; function TCircle.GetLinearInterSections(p1, p2: TDoublePoint; var pArr: TDoublePointArr): Boolean; var np1,np2: TDoublePoint; icnt: Integer; begin result := false; if GetLineCircleIntersection(p1,p2,ap1,radius,np1,np2,icnt,false) then begin SetLength(pArr,iCnt); if icnt > 0 then pArr[0] := np1; if icnt > 1 then pArr[1] := np2; result:= true; end; end; function TCircle.BreakByPoint(p: TdoublePoint;var Figures: TList): boolean; var a1:Double; fig: TFigure; begin result := false; if isPointInCircle(p.x,p.y,ap1.x,ap1.y,Radius) then begin result := true; a1 := GetradOfLine(ap1,p); fig := TArc.create(ap1.x,ap1.y,radius,a1,a1,width,style,color, brs,brc,0,LayerHandle,mydsNormal,owner); Figures.Add(fig); end; end; procedure TCircle.GetVectorObjects(Objects: Tlist; BaseP: TDoublePoint); var obj: TvectorObject; p1: TDoublePoint; begin p1 := DoublePoint(ap1.x-baseP.x,ap1.y-baseP.y); obj := TVectorObject.CreateCircleObject(p1,Radius); Objects.Add(obj); end; // ----- Tolik --- TOVERLAPPEDCIRCLE IMPLEMENTATION ------------------ constructor TOverLappedCircle.create(cX,cY,cX1,cY1,rad, CutRad: Double;w,s,c,abrs,abrc:integer; LHandle:LongInt; aDrawStyle: TDrawStyle;aOwner: TComponent); begin inherited create(LHandle,aDrawStyle,aOwner); Initialize; originalpoints[1] := DoublePoint(cx,cy); actualpoints[1] := DoublePoint(cx,cy); originalpoints[2] := DoublePoint(cx1,cy1); actualpoints[2] := DoublePoint(cx1,cy1); radius := rad; CutRadius := CutRad; width := w; color := c; style := s; brs := abrs; brc := abrc; Hatched := False; end; procedure TOverLappedCircle.Initialize; begin inherited; pointcount := 2; end; procedure TOverLappedCircle.draw(DEngine: TPCDrawEngine;isGrayed:Boolean); var acolor,bcolor : Tcolor; aawidth: integer; begin aawidth := width; if width > 1 then begin if TPCDrawing(owner).ZoomScale < 100 then begin aawidth := Trunc(width * (TPCDrawing(owner).ZoomScale / 100)); if aawidth = 0 then aawidth := 1; end; end; acolor := color; bColor := brc; if (aColor = -255) and (LayerHandle <> 0) then begin aColor := TLayer(LayerHandle).PenColor; end; if (bColor = -255) and (LayerHandle <> 0) then begin bColor := TLayer(LayerHandle).BrushColor; end; if (isGrayed) then begin acolor := TPCDrawing(Owner).FGrayedColor; //06.08.2012 GrayedColor; bcolor := TPCDrawing(Owner).FGrayedColor; //06.08.2012 GrayedColor; end; if DrawStyle = dsTrace then DEngine.canvas.pen.mode := pmXor else DEngine.canvas.pen.mode := pmCopy; if NeedRegion then DEngine.DrawOverLappedCircle(ap1.x, ap1.y, ap2.x, ap2.y, radius, CutRadius, acolor, aawidth,style,bcolor,GDIbrs,RegHandle,InCombined,Hatched); DEngine.DrawOverLappedCircle(ap1.x, ap1.y, ap2.x, ap2.y, radius, CutRadius, acolor, aawidth, style, bcolor, GDIbrs, RegHandle, InCombined, Hatched); DrawFill(Dengine,isGrayed); DrawClipFigures(Dengine,isGrayed); //Tolik if RegHandle <> 0 then begin GetRegObject; if TBrushStyle(brs) <> bsClear then RegObject.CheckPointByRects := true; deleteObject(RegHandle); RegHandle := 0; end; // end; // ---------------- TOverlappedEllipse Implementation -- (Tolik) constructor TOverlappedEllipse.create(cX, cY, cX1, cY1, Rad1, Rad2, CutRad1, CutRad2: Double;w,s,c,abrs,abrc:integer; LHandle: LongInt; aDrawStyle: TDrawStyle; aOwner: TComponent); begin inherited create(LHandle,aDrawStyle,aOwner); Initialize; originalpoints[1] := DoublePoint(cx,cy); actualpoints[1] := DoublePoint(cx,cy); originalpoints[2] := DoublePoint(cx1,cy1); actualpoints[2] := DoublePoint(cx1,cy1); radius := rad1; Radius1 := Rad2; CutRadius1 := CutRad1; CutRadius2 := CutRad2; width := 1; color := c; style := s; brs := 0; brc := abrc; Hatched := False; Owner := GCadForm.PCad; end; procedure TOverlappedEllipse.Initialize; begin inherited; pointcount := 2; end; procedure TOverlappedEllipse.draw(DEngine: TPCDrawEngine;isGrayed:Boolean); var acolor,bcolor : Tcolor; aawidth: integer; begin aawidth := width; if width > 1 then begin if TPCDrawing(owner).ZoomScale < 100 then begin aawidth := Trunc(width * (TPCDrawing(owner).ZoomScale / 100)); if aawidth = 0 then aawidth := 1; end; end; acolor := color; bColor := brc; if (aColor = -255) and (LayerHandle <> 0) then begin aColor := TLayer(LayerHandle).PenColor; end; if (bColor = -255) and (LayerHandle <> 0) then begin bColor := TLayer(LayerHandle).BrushColor; end; if (isGrayed) then begin acolor := TPCDrawing(Owner).FGrayedColor; //06.08.2012 GrayedColor; bcolor := TPCDrawing(Owner).FGrayedColor; //06.08.2012 GrayedColor; end; if DrawStyle = dsTrace then DEngine.canvas.pen.mode := pmXor else DEngine.canvas.pen.mode := pmCopy; if NeedRegion then DEngine.DrawOverLappedEllipse(ap1.x, ap1.y, ap2.x, ap2.y, radius, radius1, CutRadius1, CutRadius2, acolor, aawidth,style,bcolor,GDIbrs,RegHandle); DEngine.DrawOverLappedEllipse(ap1.x, ap1.y, ap2.x, ap2.y, radius, radius1, CutRadius1, CutRadius2, acolor, aawidth, style, bcolor, GDIbrs, RegHandle); DrawFill(Dengine,isGrayed); DrawClipFigures(Dengine,isGrayed); //Tolik if RegHandle <> 0 then begin GetRegObject; if TBrushStyle(brs) <> bsClear then RegObject.CheckPointByRects := true; deleteObject(RegHandle); RegHandle := 0; end; // end; procedure TOverLappedEllipse.getbounds(var figMaxX,figMaxY,figMinX,figMinY: double); begin figMaxX := ap1.x + Radius; figMaxY := ap1.y + Radius; figMinX := ap1.x - Radius; figMinY := ap1.y - Radius; end; Function TOverLappedEllipse.GetClassName:String; begin Result := 'OverLappedEllipse'; end; Procedure TOverLappedEllipse.WriteToStream(Stream:TStream); var xByte: Byte; xInt: Integer; xStr: String; xDbl: Double; begin inherited WriteToStream(Stream); // Tolik 22/11/2019 -- //xByte := brs; if brs = -1 then xByte := 255 else xByte := LoByte(LoWord(brs)); // WriteField(90,Stream,xByte,1); xInt := brc; WriteField(20,Stream,xInt,4); //xDbl := Radius; WriteField(222,Stream,xDbl,8); xDbl := Radius1; WriteField(252,Stream,xDbl,8); {xStr := DLabel;WriteStrField(180,Stream,xStr); xStr := Prefix;WriteStrField(181,Stream,xStr); xStr := Suffix;WriteStrField(182,Stream,xStr); xStr := TextFont;WriteStrField(183,Stream,xStr); xDbl := TextHeight; WriteField(230,Stream,xDbl,8); xDbl := GuideLen; WriteField(231,Stream,xDbl,8); } xDbl := CutRadius1; WriteField(232,Stream,xDbl,8); // cutRadius xDbl := CutRadius2; WriteField(251,Stream,xDbl,8); { if TextBold then xByte := 1 else xByte := 0; WriteField(100,Stream,xByte,1); if TextItalic then xByte := 1 else xByte := 0; WriteField(101,Stream,xByte,1); if AutoText then xByte := 1 else xByte := 0; WriteField(102,Stream,xByte,1); if DrawGuides then xByte := 1 else xByte := 0; WriteField(103,Stream,xByte,1); xByte := ord(LStyle);WriteField(104,Stream,xByte,1);} end; Procedure TOverLappedEllipse.SetPropertyFromStream(xCode:Byte;data:pointer;size:integer); begin inherited; Case xcode of 20: brc := pInt(data)^; 90: begin if pByte(data)^ = 255 then brs := -1 else brs := pByte(data)^; end; 222: Radius := pDouble(data)^; 232: CutRadius1 := pDouble(data)^; // cut Radius (from center Point) 251: CutRadius2 := pDouble(data)^; 252: Radius1 := pDouble(data)^; 253: isAutocreatedFigure := pByte(data)^; 254: Transparency := PInteger(data)^; end; end; // (* ========================================================================== *) // TARC IMPLEMENTATION // (* ========================================================================== *) constructor TArc.create(cx, cy, rad,a1, a2: Double; w, s, c, abrs, abrc, aArcStyle, LHandle: Integer; aDrawStyle: TDrawStyle; aOwner: TComponent); begin inherited create(LHandle,aDrawStyle,aOwner); Initialize; originalpoints[1] := DoublePoint(cx,cy); actualpoints[1] := DoublePoint(cx,cy); originalpoints[2] := DoublePoint(cx,cy); actualpoints[2] := DoublePoint(cx,cy); originalpoints[3] := DoublePoint(cx,cy); actualpoints[3] := DoublePoint(cx,cy); SAngle:= a1; FAngle:= a2; radius := rad; ArcStyle := TarcStyle(aArcStyle); width := w; color := c; style := s; brs := abrs; brc := abrc; end; function TArc.CreateModification: TFigure; begin result := TArc.create(ap1.x, ap1.y, Radius, SAngle, FAngle, 1,1,clLime,0,0,0,0,dsTrace,nil); Tarc(result).ArcStyle := ArcStyle; Result.RotPoint := RotPoint; end; class function TArc.CreateShadow(x, y: Double): TFigure; begin result := TArc.create(x,y,0,0,0,1,1,clLime,0,0,0,0,dsTrace,nil); end; procedure TArc.Initialize; begin inherited; pointcount := 3; end; function TArc.EndModification(CadControl: Pointer;mp: TModPoint; TraceFigure: TFigure; x,y: Double;Shift: TShiftState): boolean; var Angle: Double; cp,p1: TDoublepoint; r: integer; begin cp := ap1; p1 := DoublePoint(x,y); Angle := GetradOfLine(cp,p1); if mp.SeqNbr = 2 then SAngle := Angle else if mp.SeqNbr = 3 then FAngle := Angle else if mp.SeqNbr = 4 then Radius := sqrt( sqr(x - cp.x)+sqr(y - cp.y) ); ResetRegion; Modified := True; end; function TArc.ShadowClick(ClickIndex:Integer;x,y: Double): Boolean; var cp,p1: TDoublePoint; begin result := false; if clickIndex = 2 then begin radius := sqrt(sqr(x - ap1.x)+ sqr(y - ap1.y)); cp := ap1; p1 := DoublePoint(x,y); SAngle := GetradOfLine(cp,p1); FAngle := SAngle; result := false; end else if clickindex = 3 then begin cp := ap1; p1 := DoublePoint(x,y); FAngle := GetradOfLine(cp,p1); result := true; end; end; class function TArc.CreateFromShadow(aOwner: TComponent; LHandle: Integer; Shadow: TFigure): TFigure; var cad: TPCDrawing; begin cad := TPCDrawing(aOwner); Result := TArc.Create( shadow.ap1.x, shadow.ap1.y, shadow.radius, TArc(Shadow).SAngle, TArc(Shadow).FAngle, cad.DefaultPenWidth, ord(cad.DefaultPenStyle), cad.DefaultPenColor, ord(cad.DefaultBrushStyle), cad.DefaultBrushColor, ord(cad.DefaultArcStyle),LHandle,mydsNormal,aOwner); end; function TArc.ShadowTrace(ClickIndex:Integer;x,y:Double): Boolean; var rad:Double; cp,p1,p2: TDoublepoint; begin If ClickIndex = 1 then begin rad := sqrt(sqr(x - ap1.x)+ sqr(y - ap1.y)); radius := rad; cp := ap1; p1 := DoublePoint(x,y); SAngle := GetradOfLine(cp,p1); FAngle := SAngle; end else if ClickIndex = 2 then begin cp := ap1; p1 := DoublePoint(x,y); FAngle := GetradOfLine(cp,p1); end; end; function TArc.TraceModification(CadControl: Pointer;mp: TModPoint;TraceFigure:TFigure; x, y: Double;Shift: TShiftState): boolean; var Angle: Double; cp,p1: TDoublepoint; begin cp := ap1; p1 := DoublePoint(x,y); Angle := GetRadOfLine(cp,p1); if mp.SeqNbr = 2 then TArc(TraceFigure).SAngle := Angle else if mp.SeqNbr = 3 then Tarc(TraceFigure).FAngle := Angle else if (mp.SeqNbr = 4) or (mp.SeqNbr = 5) then begin TArc(TraceFigure).Radius := sqrt( sqr(x - cp.x)+sqr(y - cp.y)); Tarc(TraceFigure).Fangle := Tarc(TraceFigure).Sangle; end; end; procedure TArc.WriteToStream(Stream: TStream); var xByte: Byte; xInt: Integer; xDbl: Double; begin inherited; // Tolik 22/11/2019 -- //xByte := brs; if brs = -1 then xByte := 255 else xByte := LoByte(LoWord(brs)); // WriteField(90,Stream,xByte,1); xByte := ord(ArcStyle); WriteField(91,Stream,xByte,1); xInt := brc; WriteField(20,Stream,xInt,4); xDbl := Radius; WriteField(222,Stream,xDbl,8); xDbl := SAngle; WriteField(220,Stream,xDbl,8); xDbl := FAngle; WriteField(221,Stream,xDbl,8); end; Procedure TArc.SetPropertyFromStream(xCode:Byte;data:pointer;size:integer); begin Case xcode of 20: brc := pInt(data)^; 21: Radius := pInt(data)^/10; 90: begin if pByte(data)^ = 255 then brs := -1 else brs := pByte(data)^; end; 91: ArcStyle := TArcStyle(pByte(data)^); 220: SAngle := pDouble(data)^; 221: FAngle := pDouble(data)^; 222: Radius := pDouble(data)^; end; end; procedure TArc.draw(DEngine: TPCDrawEngine;isGrayed:Boolean); var acolor,bColor : Tcolor; dx,dy: real; Angle: Double; p1,p2: TDOublePoint; aawidth: integer; begin aawidth := width; if width > 1 then begin if TPCDrawing(owner).ZoomScale < 100 then begin aawidth := Trunc(width * (TPCDrawing(owner).ZoomScale / 100)); if aawidth = 0 then aawidth := 1; end; end; if (FAngle = 0) and (SAngle = 0) then begin Angle := GetradOfLine(ap1,ap2); SAngle := Angle; Angle := GetradOfLine(ap1,ap3); FAngle := Angle; end; acolor := color; if (aColor = -255) and (LayerHandle <> 0) then begin aColor := TLayer(LayerHandle).PenColor; end; bColor := brc; if (bColor = -255) and (LayerHandle <> 0) then begin bColor := TLayer(LayerHandle).BrushColor; end; if (isGrayed) then begin acolor := TPCDrawing(Owner).FGrayedColor; //06.08.2012 GrayedColor; bcolor := TPCDrawing(Owner).FGrayedColor; //06.08.2012 GrayedColor; end; if DrawStyle = dsTrace then DEngine.Canvas.Pen.Mode := pmXor else DEngine.Canvas.Pen.Mode := pmCopy; if Needregion and (ArcStyle <> asOpen) then DEngine.drawbezarc(ap1.x,ap1.y,radius,SAngle,FAngle,acolor, aawidth,style, bColor,GDIbrs,Ord(ArcStyle),RegHandle,p1,p2,InCombined,RowStyle); if ArcStyle <> asOpen then DrawFill(Dengine,isGrayed); DrawClipFigures(Dengine,isGrayed); DEngine.drawbezarc(ap1.x,ap1.y,radius,SAngle,FAngle,acolor, aawidth,style, bColor,GDIbrs,Ord(ArcStyle),RegHandle,p1,p2,InCombined,RowStyle); actualpoints[2] := NormalizePoint(p1); actualpoints[3] := NormalizePoint(p2); //Tolik if RegHandle <> 0 then begin GetRegObject; if TBrushStyle(brs) <> bsClear then RegObject.CheckPointByRects := true; deleteObject(RegHandle); RegHandle := 0; end; // end; procedure TArc.getModPoints(ModList: TMyList); var p4: TDoublePoint; CControl: TPCDrawing; dx,dy: Double; MAngle: Double; begin CControl := TPCDrawing(Owner); if FAngle = SAngle then begin p4 := DoublePoint(ap1.x+radius,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; p4 := DoublePoint(ap1.x+radius,ap1.y); p4 := RotatePoint(ap1,p4,MAngle); end; if radius = 0 then begin ModList.Add(CControl.RegisterModPoint(self,ptArcEnd,ptCircle,clRed,2,p4.x,p4.y,4)); end else begin ModList.Add(CControl.RegisterModPoint(self,ptUndefined,ptCross,clBlue,pointdim,ap1.x,ap1.y,1)); ModList.Add(CControl.RegisterModPoint(self,ptArcEnd,ptRect,clBlue,pointdim,ap2.x,ap2.y,2)); ModList.Add(CControl.RegisterModPoint(self,ptArcEnd,ptRect,clBlue,pointdim,ap3.x,ap3.y,3)); ModList.Add(CControl.RegisterModPoint(self,ptArcEnd,ptCircle,clRed,2,p4.x,p4.y,4)); end; end; procedure TArc.getbounds(var figMaxX,figMaxY,figMinX,figMinY:Double); begin GetArcBounds(ap1,Radius,Radius,ord(arcstyle),sAngle,fAngle,0,figMaxX,figMaxY,figMinX,figMinY); end; function TArc.isPointIn(x,y:Double):boolean; var CControl:TPCdrawing; a: Double; begin result := false; result := inherited isPointIn(x,y); if result then exit; a := GetRadOfLine(ap1,DoublePOint(x,y)); result := isPointInCircle(x,y,ap1.x,ap1.y,Radius) and isAngleIn(a); if (not result) and ((ArcStyle <> asOpen) or (SAngle = FAngle)) and (brs <> ord(bsClear)) then begin if IsPointInRegion(x,y) then result := true; // Tolik if IsPointInRegionByRegObj(x,y) then result := true; // end; end; function TArc.isAngleIn(a: Double): boolean; begin if FAngle > SAngle then begin result := Between(a,SAngle,FAngle); end else if FAngle = SAngle then begin result := true; end else begin result := not Between(a,SAngle,FAngle); end; end; function TArc.DuplicateAsBezier: TFigure; var Points: T2DPointArray; cnt,cntA,i: Integer; p: TDoublePoint; pp: TDoublePointArr; res: TPolyline; cx,cy: Double; begin cx := ap1.x; cy := ap1.y; BezierElpArcPoints(Points,ap1.x,ap1.y,Radius,Radius,0,SAngle,FAngle); cnt := Length(Points); cntA := 0; if arcStyle = asPie then cntA := 6 else if ArcStyle = asChord then cntA := 3; SetLength(pp,cnt+cntA); for i := 0 to cnt-1 do begin p := DoublePoint(Points[i].x,Points[i].y); pp[i] := p; end; if arcStyle = asPie then begin pp[cnt-1+1] := QrPoint(pp[cnt-1],ap1); pp[cnt-1+2] := QrPoint(ap1,pp[cnt-1]); pp[cnt-1+3] := ap1; pp[cnt-1+4] := QrPoint(ap1,pp[0]); pp[cnt-1+5] := QrPoint(pp[0],ap1); pp[cnt-1+6] := pp[0]; end else if ArcStyle = asChord then begin pp[cnt-1+1] := QrPoint(pp[cnt-1],pp[0]); pp[cnt-1+2] := QrPoint(pp[0],pp[cnt-1]); pp[cnt-1+3] := pp[0]; end; SetLength(Points,0); result := TPolyline.createFromBezierPoints(pp,Width,Style,color,Brs,Brc,0, (ArcStyle <> asOpen),Layerhandle,mydsNormal,owner); // Tolik 24/05/2019 -- SetLength(pp, 0); // end; function TArc.duplicate:TFigure; var res : TArc; begin res := TArc.create( originalpoints[1].x, originalpoints[1].y, radius, sAngle, FAngle, width, style, color, brs, brc, ord(ArcStyle), LayerHandle, DrawStyle,Owner); res.angle := angle; res.actualpoints[1] := actualpoints[1]; res.actualpoints[2] := actualpoints[2]; res.actualpoints[3] := actualpoints[3]; res.originalpoints[1] := originalpoints[1]; res.originalpoints[2] := originalpoints[2]; res.originalpoints[3] := originalpoints[3]; res.rotPoint.x := rotPoint.x ; res.rotPoint.y := rotPoint.y ; res.AngleToPoint := AngleToPoint; result := res; end; function TArc.GetLinearInterSections(p1, p2: TDoublePoint; var pArr: TDoublePointArr): Boolean; var np1,np2:TDoublePoint; iCnt,xCnt: Integer; a: Double; begin result := false; if GetLineCircleIntersection(p1,p2,ap1,radius,np1,np2,icnt,false) then begin xCnt := 0; if iCnt > 0 then begin a := GetradOfLine(ap1,np1); if isPointInCircle(np1.x,np1.y,ap1.x,ap1.y,Radius) and isAngleIn(a) then begin xCnt := xcnt+1; SetLength(pArr,xCnt); pArr[xCnt-1] := np1; end; end; if iCnt > 1 then begin a := GetradOfLine(ap1,np2); if isPointInCircle(np2.x,np2.y,ap1.x,ap1.y,Radius) and isAngleIn(a) then begin xCnt := xcnt+1; SetLength(pArr,xCnt); pArr[xCnt-1] := np2; end; end; if xCnt > 0 then result := True; end; end; function TArc.BreakByPoint(p: TdoublePoint; var Figures: TList): boolean; var a: Double; Fig: Tfigure; begin a := GetradOfLine(ap1,p); result := false; if isPointInCircle(p.x,p.y,ap1.x,ap1.y,Radius) and isAngleIn(a) then begin fig := TArc.create(ap1.x,ap1.y,radius,SAngle,a,width,style,color, brs,brc,ord(arcStyle),LayerHandle,mydsNormal,owner); Figures.Add(fig); fig := TArc.create(ap1.x,ap1.y,radius,a,Fangle,width,style,color, brs,brc,ord(arcStyle),LayerHandle,mydsNormal,owner); Figures.Add(fig); result := true; end; end; Procedure TArc.Invert; var tA: double; Begin ta := SAngle; Sangle := FAngle; FAngle := ta; Resetregion; Modified := true; End; procedure TArc.VerifyZeroPoints(orgV, orgH: Byte); begin inherited; if (orgV <> VertZero) then begin SAngle := 2*pi - SAngle; FAngle := 2*pi - FAngle; Invert; end; if (orgH <> HorzZero) then begin SAngle := pi - SAngle; FAngle := pi - FAngle; Invert; end; end; procedure TArc.ArrangeStyle(val: TArcStyle); begin ArcStyle := val; Resetregion; end; Procedure TArc.Mirror(Point1,Point2: TDoublePoint); Begin inherited Mirror(Point1,Point2); SAngle := GetradOfLine(ap1,ap2); FAngle := GetradOfLine(ap1,ap3); Invert; end; procedure TArc.Rotate(aAngle: Double; cPoint: TDoublePoint); begin inherited; Fangle := 0; SAngle := 0; draw(GCadForm.PCad.DEngine, False); // SAngle := GetradOfLine(ap1,ap2); // FAngle := GetradOfLine(ap1,ap3); // SAngle := SAngle + aAngle; // if SAngle > 2 * pi then // SAngle := SAngle - 2 * pi; // FAngle := FAngle + aAngle; // if FAngle > 2 * pi then // FAngle := FAngle - 2 * pi; //Tolik if RegHandle <> 0 then begin GetRegObject; deleteObject(RegHandle); RegHandle := 0; end; // end; procedure TArc.MenuClicked(CommandId: integer); var mnIdx: integer; begin mnIdx := CommandId-MenuIndex; case mnIdx of 0: ArcStyle:= asOpen; 1: ArcStyle:= asPie; 2: ArcStyle:= asChord; 3: Invert; end; end; procedure TArc.UpdateMenu(var popMenu: TPopUpMenu; var sIndex: Integer); var mnItem:TMenuItem; begin menuIndex := sIndex; mnItem := TMenuItem.Create(PopMenu); mnItem.Caption := fmOpenArc; mnItem.Tag := sIndex; if arcStyle = asOpen then mnItem.Checked := true; PopMenu.Items.Add(mnItem); mnItem := TMenuItem.Create(PopMenu); mnItem.Caption := fmPieArc; mnItem.Tag := sIndex+1; if arcStyle = asPie then mnItem.Checked := true; PopMenu.Items.Add(mnItem); mnItem := TMenuItem.Create(PopMenu); mnItem.Caption := fmChordArc; mnItem.Tag := sIndex+2; if arcStyle = asChord then mnItem.Checked := true; PopMenu.Items.Add(mnItem); mnItem := TMenuItem.Create(PopMenu); mnItem.Caption := fmInvertArc; mnItem.Tag := sIndex+3; PopMenu.Items.Add(mnItem); sIndex := sIndex+4; end; (* ========================================================================== *) // TRECTANGLE IMPLEMENTATION // (* ========================================================================== *) constructor TRectangle.create(aX1,aY1,aX2,aY2:Double;w,s,c,abrs,abrc:integer; LHandle:LongInt;aDrawStyle: TDrawStyle;aOwner: TComponent); begin inherited create(LHandle, aDrawStyle,aOwner); Initialize; originalpoints[1] := DoublePoint(ax1,ay1); originalpoints[2] := DoublePoint(ax2,ay1); originalpoints[3] := DoublePoint(ax2,ay2); originalpoints[4] := DoublePoint(ax1,ay2); actualpoints[1] := DoublePoint(ax1,ay1); actualpoints[2] := DoublePoint(ax2,ay1); actualpoints[3] := DoublePoint(ax2,ay2); actualpoints[4] := DoublePoint(ax1,ay2); width := w; color := c; style := s; brs := abrs; brc := abrc; //Initialize; end; procedure TRectangle.Initialize; begin inherited; pointcount := 4; DimLeft:=False; DimRight:=True; DimTop:=True; DimBottom:= False; GetMem(FDrawPoints, 5*8); //31.10.2011 - память для отрисовки точек на TPCDrawEngine.WPolygon end; class function TRectangle.ShadowType: TShadowType; begin result := stRectangle; end; function TRectangle.CreateModification: TFigure; var res: TRectangle; begin res := TRectangle.create(ap1.x,ap1.y, ap3.x,ap3.y, 1,1,clLime,1,clWhite,0,dsTrace,nil); res.actualpoints[1] := ap1; res.actualpoints[2] := ap2; res.actualpoints[3] := ap3; res.actualpoints[4] := ap4; res.RotPoint := RotPoint; CreateModification := res; end; class function TRectangle.CreateFromShadow(aOwner: TComponent; LHandle: Integer; Shadow: TFigure): TFigure; var cad: TPCDrawing; begin cad := TPCDrawing(aOwner); Result := TRectangle.create(Shadow.ap1.x,Shadow.ap1.y, Shadow.ap3.x,Shadow.ap3.y, cad.DefaultPenWidth, ord(cad.DefaultPenStyle), cad.DefaultPenColor, ord(cad.DefaultBrushStyle), cad.DefaultBrushColor, LHandle, mydsNormal,aOwner); end; function TRectangle.EndModification(CadControl: Pointer;mp: TModPoint; TraceFigure: TFigure; x,y: Double;Shift: TShiftState): boolean; var a: integer; ap: TDoublePoint; begin For a := 1 to PointCount do begin ap := ActualPoints[a]; ActualPoints[a] := DoublePoint( ap.x+(TraceFigure.ActualPoints[a].x- ap.x), ap.y+(TraceFigure.ActualPoints[a].y- ap.y) ); end; ResetRegion; Modified := True; If assigned(OnModified) then OnModified(self); end; function TRectangle.ShadowClick(ClickIndex:Integer;x,y:Double): Boolean; begin result := false; if clickindex = 2 then result := true; end; function TRectangle.ShadowTrace(ClickIndex:Integer;x,y:Double): Boolean; var x1,y1: Double; begin if clickindex = 1 then begin x1 := ap1.x; y1 := ap1.y; actualPoints[2] := DoublePoint(x,y1); actualPoints[3] := DoublePoint(x,y); actualPoints[4] := DoublePoint(x1,y); end; end; function TRectangle.TraceModification(CadControl: Pointer;mp: TModPoint;TraceFigure:TFigure; x,y: Double;Shift: TShiftState): boolean; var p1,p2,p3,p4,hitPoint,orPoint : TDoublePoint; rad,dist,distx,disty,distx1,disty1,dx,dy,xAngle : Double; ang1,ang2:Double; w,h:Double; ddx,ddy: integer; idx: Integer; fg: Tfigure; begin fg := mp.Figure; dx := (fg.ActualPoints[3].x - fg.ActualPoints[4].x ); dy := (fg.ActualPoints[3].y - fg.ActualPoints[4].y ); p1 := fg.ap1; p2 := fg.ap2; p3 := fg.ap3; p4 := fg.ap4; if (dx <> 0) and (dy <> 0) then xAngle := (ArcTan(dy / dx)) else if dx = 0 then xAngle := pi/2 else if dy = 0 then xAngle := 0; if fDiagonal then begin w := GetLineLenght(p1,p2); h := GetLineLenght(p2,p3); end; hitPoint := RotatePoint(p4,DoublePoint(x,y),-1*xAngle); if mp.SeqNbr = 1 then begin orPoint := RotatePoint(p4,p1,-1*xAngle); distx := hitPoint.x - orPoint.x; disty := hitPoint.y - orPoint.y; ddx := 1;ddy := 1; if distx < 0 then ddx := -1; if disty < 0 then ddy := -1; if p1.x < p2.x then ddx := ddx*-1; if p1.y < p3.y then ddy := ddy*-1; if fDiagonal then begin if abs(distx / w) > abs(disty/h) then begin disty := abs((distx/w)*h); if ddx = 1 then begin if p1.y < p3.y then disty := -1*disty; end else begin if p1.y > p3.y then disty := -1*disty; end; end else begin distx := abs((disty/h)*w); if ddy = 1 then begin if p1.x < p2.x then distx := -1*distx; end else begin if p1.x > p2.x then distx := -1*distx; end; end; end; orPoint := RotatePoint(p4,p4,-1*xAngle); TraceFigure.ActualPoints[4] := RotatePoint(p4,DoublePoint(orPoint.x + distx,orPoint.y ),xAngle); orPoint := RotatePoint(p4,p2,-1*xAngle); TraceFigure.ActualPoints[2] := RotatePoint(p4,DoublePoint(orPoint.x,orPoint.y+disty),xAngle); orPoint := RotatePoint(p4,p1,-1*xAngle); TraceFigure.ActualPoints[1] := RotatePoint(p4,DoublePoint(orPoint.x+distx,orPoint.y+disty),xAngle); end else if mp.SeqNbr = 2 then begin orPoint := RotatePoint(p4,MPoint(p1,p2),-1*xAngle); distx := hitPoint.x - orPoint.x; disty := hitPoint.y - orPoint.y; orPoint := RotatePoint(p4,p1,-1*xAngle); TraceFigure.ActualPoints[1] := RotatePoint(p4,MVPoint(orPoint,disty),xAngle); orPoint := RotatePoint(p4,p2,-1*xAngle); TraceFigure.ActualPoints[2] := RotatePoint(p4,MVPoint(orPoint,disty),xAngle); end else if mp.SeqNbr = 3 then begin orPoint := RotatePoint(p4,p2,-1*xAngle); distx := hitPoint.x - orPoint.x; disty := hitPoint.y - orPoint.y; ddx := 1;ddy := 1; if distx < 0 then ddx := -1; if disty < 0 then ddy := -1; if p1.x > p2.x then ddx := ddx*-1; if p1.y < p3.y then ddy := ddy*-1; if fDiagonal then begin if abs(distx / w) > abs(disty/h) then begin disty := abs((distx/w)*h); if ddx = 1 then begin if p1.y < p3.y then disty := -1*disty; end else begin if p1.y > p3.y then disty := -1*disty; end; end else begin distx := abs((disty/h)*w); if ddy = 1 then begin if p1.x > p2.x then distx := -1*distx; end else begin if p1.x < p2.x then distx := -1*distx; end; end; end; orPoint := RotatePoint(p4,p3,-1*xAngle); TraceFigure.ActualPoints[3] := RotatePoint(p4,MHPoint(orPoint,distx),xAngle); orPoint := RotatePoint(p4,p1,-1*xAngle); TraceFigure.ActualPoints[1] := RotatePoint(p4,MVPoint(orPoint,disty),xAngle); orPoint := RotatePoint(p4,p2,-1*xAngle); TraceFigure.ActualPoints[2] := RotatePoint(p4,MovePoint(orPoint,distx,disty),xAngle); end else if mp.SeqNbr = 4 then begin orPoint := RotatePoint(p4,MPoint(p2,p3),-1*xAngle); distx := hitPoint.x - orPoint.x; disty := hitPoint.y - orPoint.y; orPoint := RotatePoint(p4,p2,-1*xAngle); TraceFigure.ActualPoints[2] := RotatePoint(p4,MHPoint(orPoint,distx),xAngle); orPoint := RotatePoint(p4,p3,-1*xAngle); TraceFigure.ActualPoints[3] := RotatePoint(p4,MHPoint(orPoint,distx),xAngle); end else if mp.SeqNbr = 5 then begin orPoint := RotatePoint(p4,p3,-1*xAngle); distx := hitPoint.x - orPoint.x; disty := hitPoint.y - orPoint.y; ddx := 1;ddy := 1; if distx < 0 then ddx := -1; if disty < 0 then ddy := -1; if p1.x > p2.x then ddx := ddx*-1; if p1.y > p3.y then ddy := ddy*-1; if fDiagonal then begin if abs(distx / w) > abs(disty/h) then begin disty := abs(abs(distx/w)*h); if ddx = 1 then begin if p1.y > p3.y then disty := -1*disty; end else begin if p1.y < p3.y then disty := -1*disty; end; end else begin distx := abs((disty/h)*w); if ddy = 1 then begin if p1.x > p2.x then distx := -1*distx; end else begin if p1.x < p2.x then distx := -1*distx; end; end; end; TraceFigure.ActualPoints[4] := RotatePoint(p4,MVPoint(p4,disty),xAngle); orPoint := RotatePoint(p4,p2,-1*xAngle); TraceFigure.ActualPoints[2] := RotatePoint(p4,MHPoint(orpoint,distx),xAngle); orPoint := RotatePoint(p4,p3,-1*xAngle); TraceFigure.ActualPoints[3] := RotatePoint(p4,MovePoint(orpoint,distx,disty),xAngle); end else if mp.SeqNbr = 6 then begin orPoint := RotatePoint(p4,MPoint(p3,p4),-1*xAngle); distx := hitPoint.x - orPoint.x; disty := hitPoint.y - orPoint.y; orPoint := RotatePoint(p4,p3,-1*xAngle); TraceFigure.ActualPoints[3] := RotatePoint(p4,MVPoint(orpoint,disty),xAngle); orPoint := RotatePoint(p4,p4,-1*xAngle); TraceFigure.ActualPoints[4] := RotatePoint(p4,MVPoint(orpoint,disty),xAngle); end else if mp.SeqNbr = 7 then begin orPoint := RotatePoint(p4,p4,-1*xAngle); distx := hitPoint.x - orPoint.x; disty := hitPoint.y - orPoint.y; ddx := 1;ddy := 1; if distx < 0 then ddx := -1; if disty < 0 then ddy := -1; if p1.x < p2.x then ddx := ddx*-1; if p1.y > p3.y then ddy := ddy*-1; if fDiagonal then begin if abs(distx / w) > abs(disty/h) then begin disty := abs(abs(distx/w)*h); if ddx = 1 then begin if p1.y > p3.y then disty := -1*disty; end else begin if p1.y < p3.y then disty := -1*disty; end; end else begin distx := abs((disty/h)*w); if ddy = 1 then begin if p1.x < p2.x then distx := -1*distx; end else begin if p1.x > p2.x then distx := -1*distx; end; end; end; orPoint := RotatePoint(p4,p3,-1*xAngle); TraceFigure.ActualPoints[3] := RotatePoint(p4,MVPoint(orPoint,distY),xAngle); orPoint := RotatePoint(p4,p1,-1*xAngle); TraceFigure.ActualPoints[1] := RotatePoint(p4,MHPoint(orPoint,distX),xAngle); orPoint := RotatePoint(p4,p4,-1*xAngle); TraceFigure.ActualPoints[4] := RotatePoint(p4,MovePoint(orPoint,distX,distY),xAngle); end else if mp.SeqNbr = 8 then begin orPoint := RotatePoint(p4,MPoint(p1,p4),-1*xAngle); distx := hitPoint.x - orPoint.x; disty := hitPoint.y - orPoint.y; orPoint := RotatePoint(p4,p4,-1*xAngle); TraceFigure.ActualPoints[4] := RotatePoint(p4,MHPoint(orPoint,distX),xAngle); orPoint := RotatePoint(p4,p1,-1*xAngle); TraceFigure.ActualPoints[1] := RotatePoint(p4,MHPoint(orPoint,distX),xAngle); end; end; procedure TRectangle.WriteToStream(Stream: TStream); var xByte: Byte; xInt: Integer; begin inherited; if brs = -1 then xByte := 255 else xByte := LoByte(LoWord(brs)); WriteField(90,Stream,xByte,1); xInt := brc; WriteField(20,Stream,xInt,4); WriteField(91,Stream,DimLeft,1); WriteField(92,Stream,DimRight,1); WriteField(93,Stream,DimTop,1); WriteField(94,Stream,DimBottom,1); end; Procedure TRectangle.SetPropertyFromStream(xCode:Byte;data:pointer;size:integer); begin Case xcode of 20: brc := pInt(data)^; 90: begin if pByte(data)^ = 255 then brs := -1 else brs := pByte(data)^; end; 91: DimLeft := Boolean(pByte(data)^); 92: DimRight := Boolean(pByte(data)^); 93: DimTop := Boolean(pByte(data)^); 94: DimBottom := Boolean(pByte(data)^); end; end; procedure TRectangle.draw(DEngine: TPCDrawEngine;isGrayed:Boolean); var acolor,bcolor : Tcolor; points : TDoublePointArr; xBrs: Integer; xp: TPoint; //31.10.2011 aawidth: integer; begin aawidth := width; if width > 1 then begin if TPCDrawing(owner).ZoomScale < 100 then begin aawidth := Trunc(width * (TPCDrawing(owner).ZoomScale / 100)); if aawidth = 0 then aawidth := 1; end; end; acolor := color; bColor := brc; if (aColor = -255) and (LayerHandle <> 0) then begin aColor := TLayer(LayerHandle).PenColor; end; if (bColor = -255) and (LayerHandle <> 0) then begin bColor := TLayer(LayerHandle).BrushColor; end; if (isGrayed) then begin acolor := TPCDrawing(Owner).FGrayedColor; //06.08.2012 GrayedColor; bcolor := TPCDrawing(Owner).FGrayedColor; //06.08.2012 GrayedColor; end; if DrawStyle = dsTrace then DEngine.Canvas.Pen.Mode := pmXor else DEngine.Canvas.Pen.Mode := pmCopy; {//31.10.2011} SetLength(points,4); points[0] := ap1; points[1] := ap2; points[2] := ap3; points[3] := ap4;{} {//31.10.2011 - точки для отрисовки xp := DEngine.ConvertCoordToPt(ap1); PInt(PChar(FDrawPoints)+0*8+0)^:= xp.x; PInt(PChar(FDrawPoints)+0*8+4)^:= xp.y; PInt(PChar(FDrawPoints)+4*8+0)^:= xp.x; PInt(PChar(FDrawPoints)+4*8+4)^:= xp.y; xp := DEngine.ConvertCoordToPt(ap2); PInt(PChar(FDrawPoints)+1*8+0)^:= xp.x; PInt(PChar(FDrawPoints)+1*8+4)^:= xp.y; xp := DEngine.ConvertCoordToPt(ap3); PInt(PChar(FDrawPoints)+2*8+0)^:= xp.x; PInt(PChar(FDrawPoints)+2*8+4)^:= xp.y; xp := DEngine.ConvertCoordToPt(ap4); PInt(PChar(FDrawPoints)+3*8+0)^:= xp.x; PInt(PChar(FDrawPoints)+3*8+4)^:= xp.y;} if NeedRegion then //{//31.10.2011 }DEngine.drawpolygon(points,acolor,width,style,bcolor,GdiBrs,RegHandle, nil, FDrawPoints); DEngine.drawrect(ap1, ap2, ap3, ap4, acolor, aawidth, Style, bcolor, GdiBrs, RegHandle); DrawFill(Dengine,isGrayed); DrawClipFigures(Dengine,isGrayed); //{//31.10.2011 }DEngine.drawpolygon(points,acolor,width,style,bcolor,GdiBrs,RegHandle, nil, FDrawPoints); DEngine.drawrect(ap1, ap2, ap3, ap4, acolor, aawidth, Style, bcolor, GdiBrs, RegHandle); //Tolik if RegHandle <> 0 then begin GetRegObject; if TBrushStyle(brs) <> bsClear then RegObject.CheckPointByRects := true; deleteObject(RegHandle); RegHandle := 0; end; // end; procedure TRectangle.getModPoints(ModList: TMyList); var CControl: TPCDrawing; MT,MR,MB,ML : TDoublePoint; begin CControl := TPCDrawing(Owner); MT := MPoint(ap1,ap2); MR := MPoint(ap2,ap3); MB := MPoint(ap3,ap4); ML := MPoint(ap4,ap1); ModList.Add(CControl.RegisterModPoint(self,ptRectPoint,ptRect,clBlue,PointDim,ap1.x,ap1.y,1)); ModList.Add(CControl.RegisterModPoint(self,ptRectPoint,ptRect,clBlue,PointDim,MT.x,MT.y,2)); ModList.Add(CControl.RegisterModPoint(self,ptRectPoint,ptRect,clBlue,PointDim,ap2.x,ap2.y,3)); ModList.Add(CControl.RegisterModPoint(self,ptRectPoint,ptRect,clBlue,PointDim,MR.x,MR.y,4)); ModList.Add(CControl.RegisterModPoint(self,ptRectPoint,ptRect,clBlue,PointDim,ap3.x,ap3.y,5)); ModList.Add(CControl.RegisterModPoint(self,ptRectPoint,ptRect,clBlue,PointDim,MB.x,MB.y,6)); ModList.Add(CControl.RegisterModPoint(self,ptRectPoint,ptRect,clBlue,PointDim,ap4.x,ap4.y,7)); ModList.Add(CControl.RegisterModPoint(self,ptRectPoint,ptRect,clBlue,PointDim,ML.x,ML.y,8)); end; procedure TRectangle.getbounds(var figMaxX,figMaxY,figMinX,figMinY:Double); var a : integer; begin //Tolik // при получении границ кабинета ар не всегда могут быть проинициализированы, можно получить // "мусор" при расчетах figMaxX := ap1.x; figMinX := ap1.x; figMaxY := ap1.y; figMinY := ap1.y; { figMaxX := actualpoints[1].x; figMinX := actualpoints[1].x; figMaxY := actualpoints[1].y; figMinY := actualpoints[1].y; } // For a := 1 to 4 do begin if actualpoints[a].x > figMaxX then figMaxX := actualpoints[a].x; if actualpoints[a].x < figMinX then figMinX := actualpoints[a].x; if actualpoints[a].y > figMaxY then figMaxY := actualpoints[a].y; if actualpoints[a].y < figMinY then figMinY := actualpoints[a].y; end; end; function TRectangle.isPointIn(x,y:Double): boolean; var apoint,p1,p2,p3,p4: TDoublePoint; DEngine: TPCDrawEngine; z: Double; begin result := false; result := inherited isPointIn(x,y); if result then exit; apoint.x := x; apoint.y := y; aPoint.z := 0; // Tolik 28/08/2019 -- на всякий... p1 := ap1; p2 := ap2; p3 := ap3; p4 := ap4; if assigned(owner) then begin z := 0; DEngine := TPCDrawing(owner).DEngine; Dengine.ConvertPoint(p1.x,p1.y,z); Dengine.ConvertPoint(p2.x,p2.y,z); Dengine.ConvertPoint(p3.x,p3.y,z); Dengine.ConvertPoint(p4.x,p4.y,z); Dengine.ConvertPoint(apoint.x,apoint.y,z); end; if ( ispointInLine(p1,p2,apoint,width) or ispointInLine(p2,p3,apoint,width) or ispointInLine(p3,p4,apoint,width) or ispointInLine(p4,p1,apoint,width) ) then begin result := true; exit; end; if TBrushStyle(brs) <> bsClear then begin result := isPointInRegion(x,y); //Tolik result := IsPointInRegionByRegObj(x,y); // end; end; function TRectangle.BreakByPoint(p: TdoublePoint;var Figures: TList): boolean; var pArr: TDoublePointArr; Fig: Tfigure; begin result := true; SetLength(pArr,6); if isPointinLine(ap1,ap2,p,2) then begin pArr[0] := p ;pArr[1] := ap2;pArr[2] := ap3; pArr[3] := ap4;pArr[4] := ap1;pArr[5] := p; end else if isPointinLine(ap2,ap3,p,2) then begin pArr[0] := p ;pArr[1] := ap3;pArr[2] := ap4; pArr[3] := ap1;pArr[4] := ap2;pArr[5] := p; end else if isPointinLine(ap3,ap4,p,2) then begin pArr[0] := p ;pArr[1] := ap4;pArr[2] := ap1; pArr[3] := ap2;pArr[4] := ap3;pArr[5] := p; end else if isPointinLine(ap4,ap1,p,2) then begin pArr[0] := p ;pArr[1] := ap1;pArr[2] := ap2; pArr[3] := ap3;pArr[4] := ap4;pArr[5] := p; end else begin Result := False; end; if result then begin Fig := TPolyline.create(pArr,width,style,color,brs,brc,0,false,LayerHandle,mydsNormal,owner); Figures.Add(fig) end; SetLength(pArr,0); end; function TRectangle.GetLinearInterSections(p1, p2: TDoublePoint; var pArr: TDoublePointArr): Boolean; var p: TDoublePoint; pCnt: Integer; begin result := false; pCnt := 0; if GetInterSectionPoint(ap1,ap2,p1,p2,p,False) then begin pCnt := pCnt+1; SetLength(pArr,pCnt); pArr[pCnt-1] := p; end; if GetInterSectionPoint(ap2,ap3,p1,p2,p,False) then begin pCnt := pCnt+1; SetLength(pArr,pCnt); pArr[pCnt-1] := p; end; if GetInterSectionPoint(ap3,ap4,p1,p2,p,False) then begin pCnt := pCnt+1; SetLength(pArr,pCnt); pArr[pCnt-1] := p; end; if GetInterSectionPoint(ap4,ap1,p1,p2,p,False) then begin pCnt := pCnt+1; SetLength(pArr,pCnt); pArr[pCnt-1] := p; end; result := (pCnt > 0); end; function TRectangle.DuplicateAsBezier: TFigure; var points: TDoublePointArr; p1,p2,cp1,cp2: TDoublePoint; i: Integer; begin SetLength(Points,12); for i := 1 to 4 do begin p1 := ActualPoints[i]; p2 := ActualPoints[i+1]; cp1 := MPoint(p1,p2); cp1 := MPoint(p1,cp1); cp2 := MPoint(p1,p2); cp2 := MPoint(p2,cp2); Points[(i-1)*3 +0] := p1; Points[(i-1)*3 +1] := cp1; Points[(i-1)*3 +2] := cp2; if i < 4 then Points[(i-1)*3 +3] := p2; end; result := TPolyline.CreateFromBezierPoints(points,width,style,color, brs,brc,0,true,LayerHandle,mydsNormal,owner); SetLength(Points,0); end; function TRectangle.duplicate:TFigure; var res : TRectangle; begin res := TRectangle.create( originalpoints[1].x, originalpoints[1].y, originalpoints[3].x, originalpoints[3].y, width, style, color, brs, brc, LayerHandle, DrawStyle,Owner); res.angle := angle; res.actualpoints[1] := actualpoints[1]; res.actualpoints[2] := actualpoints[2]; res.actualpoints[3] := actualpoints[3]; res.actualpoints[4] := actualpoints[4]; res.originalpoints[1] := originalpoints[1]; res.originalpoints[2] := originalpoints[2]; res.originalpoints[3] := originalpoints[3]; res.originalpoints[4] := originalpoints[4]; res.rotPoint.x := rotPoint.x ; res.rotPoint.y := rotPoint.y ; res.AngleToPoint := AngleToPoint; result := res; end; procedure TRectangle.GetVectorObjects(Objects: Tlist; BaseP: TDoublePoint); var obj: TvectorObject; p: array [0..3] of TDoublePoint; p1: TDoublePoint; i: Integer; begin for i := 1 to 4 do begin p1 := ActualPoints[i]; p1 := DoublePoint(p1.x-baseP.x,p1.y-baseP.y); p[i-1] := p1; end; obj := TVectorObject.CreatePolygonObject(4,p); Objects.Add(obj); end; (* ========================================================================== *) // TBMPObject IMPLEMENTATION // (* ========================================================================== *) // Tolik -- 10/03/2016 -- тут немножко переделано с целью правильно загрузить размеры JPEG constructor TBMPObject.create(x,y:Double; afName: string; LHandle:LongInt; aDrawStyle: TDrawStyle;aOwner: TComponent; JPEGBounds: Boolean = false); var bmpress: single; bmpresW, bmpresH: single; //i: Integer; i: TPixelFormat; bmpres:Integer; picW,picH :Double; TempPic: TPicture; gpImage: TgpImage; gdiGraphics: TGPGraphics; res1: Extended; maxv: Extended; res111: Extended; res222: Extended; PictWidth, PictHeight: Integer; rect: TRect; BadFormatResult: Boolean; // если не получилось установить PixelFormat картинки == true WidthScale, HeightScale: Double; FitImageToPage: Boolean; FitKoef: Double; CadPicWidth, CadPicHeight: Int64; TempPicWidth, TempPicHeight: Integer; encoderClsid: TGuid; Procedure SetMaxDefaultPictureASttribs; // получится BMP-ха примерно на 120 MB -- на всякий... var CadPW, CadPH: Int64; begin Picture.PixelFormat := pf24bit; CadPW := gpImage.GetWidth; Picture.Height := Round(40000000/CadPW); Picture.Width := Round(40000000/Picture.Height); end; Procedure Get_PictureFormat(aImage: TGpImage); var i: Integer; CanProceed: Boolean; {TempPicWidth, TempPicHeight}PicWidth, PicHeight: Integer; //CadPicWidth, CadPicHeight: Int64; PictSize, PictPixelSize: int64; deltax, deltay, MaxVal, Caddeltax, Caddeltay: Integer; Counter: Integer; HKoef, WKoef, CadHKoef, CadWKoef: Double; ScaleWKoef, ScaleHKoef, DSize: Extended; PicFormat: TPixelFormat; xProc, yProc: integer; begin FitKoef := 1; bmpresW := aImage.GetHorizontalResolution; // dpi по ширине bmpresH := aImage.GetVerticalResolution; // dpi по высоте PicWidth := aImage.GetWidth; PicHeight := aImage.GetHeight; // Tolik 24/02/2021 if GLoadImageAsIs then begin Picture.Width := PicWidth; Picture.Height := PicHeight; exit; end; // if (PicWidth = 0) or (PicHeight = 0) then exit; Counter := 0; // resize Counter BadFormatResult := False; CanProceed := True; MaxVal := 180000000; //в дюймах CadPicWidth := Round(GCadForm.Pcad.workwidth/25.4); //Round((PicWidth / bmpresW) * 25.4) ; CadPicHeight := Round(GCadForm.Pcad.workHeight/25.4); //Round((PicHeight / bmpresH) * 25.4) ; // в точках CadPicWidth := Round(bmpresW * CadPicWidth); CadPicHeight := Round(bmpresH * CadPicHeight); // 95% от размера када CadPicWidth := Round(CadPicWidth * 0.95); CadPicHeight := Round(CadPicHeight * 0.95); //коэффициенты отношения сторон ScaleWKoef := CadPicWidth / PicWidth; ScaleHKoef := CadPicHeight / PicHeight; //взять меньший if (CompareValue(ScaleWKoef, ScaleHKoef) = 1) then ScaleWKoef := ScaleHKoef; //5% - для изменения коэффициента скейла ScaleHKoef := ScaleWKoef/50; if not GAutoScaleRasterImages then // втиснуть загружаемое изображение на лист, если оно превышает его размеры // может, конечно быть пользовательский формат листа с размерами от самолета, // тогда все равно будем коцать, пока не получим приемлемлемое значение или, // если не получится, зададим на крайний случай параметры по дефолту begin while CanProceed do begin inc(Counter); // на всякий, чтоб до абсурда не доводить ... if Counter = 50 then begin //BadFormatResult := True; // не удалось привести размер/формат SetMaxDefaultPictureASttribs; exit; end; DSize := (PicWidth * ScaleWKoef); DSize := (DSize * PicHeight); DSize := (DSize * ScaleWKoef); PictSize := Round(DSize); //pf32 PictPixelSize := PictSize * 4; if PictPixelSize < MaxVal then begin CanProceed := False; Picture.PixelFormat := pf32bit; end else begin //pf24 PictPixelSize := PictSize * 3; if PictPixelSize < MaxVal then begin CanProceed := False; Picture.PixelFormat := pf24bit; end else begin //pf16 PictPixelSize := PictSize * 2; if PictPixelSize < MaxVal then begin CanProceed := False; Picture.PixelFormat := pf16bit; end else //PictPixelSize := PictSize;//pf8 -- некрасиво будет, не берем // pf15bit begin PictPixelSize := PictSize * 15; PictPixelSize := PictPixelSize div 8; if PictPixelSize < MaxVal then begin CanProceed := False; Picture.PixelFormat := pf15bit; end end; end; end; if CanProceed then ScaleWKoef := ScaleWKoef - ScaleHKoef else begin Picture.Width := Round(PicWidth * ScaleWKoef); Picture.Height := Round(PicHeight * ScaleWKoef); exit; end; end; end else begin // показать форму настройки изображения -- if not Assigned(F_RasterImageSettings) then begin Application.CreateForm(TF_RasterImageSettings, F_RasterImageSettings); F_RasterImageSettings.CheckBox1.Checked := True; end; F_RasterImageSettings.PixelImageX := PicWidth; F_RasterImageSettings.PixelImageY := PicHeight; F_RasterImageSettings.CadPicWidth := CadPicWidth; F_RasterImageSettings.CadPicHeight := CadPicHeight; //проверить что больше, картинка или Кад if CadPicWidth > PicWidth then begin if CadPicHeight > PicHeight then F_RasterImageSettings.CadIsBiggerThanImage := True else F_RasterImageSettings.CadIsBiggerThanImage := False; end else F_RasterImageSettings.CadIsBiggerThanImage := False; //Прикинуть допустимый размер картинки на Каде if F_RasterImageSettings.CadIsBiggerThanImage then begin F_RasterImageSettings.MaxAllowedTrackVal := 100; // если КАд больше -- то, в принципе, картинка должна поместиться любая... F_RasterImageSettings.TrackBar1.Position := 100; end else // если нет -- прикинуть размер begin Counter := 0; // resize Counter // 5 % deltax := (PicWidth div 50); deltay := (PicHeight div 50); PictSize := PicWidth * PicHeight; TempPicWidth := PicWidth; TempPicHeight := PicHeight; while CanProceed do begin inc(Counter); // на всякий, чтоб до абсурда не доводить ... if Counter = 50 then begin break; end; //pf24 PictPixelSize := PictSize * 3; //if PictPixelSize < MaxVal then if PictPixelSize < 50000000 then CanProceed := False; if CanProceed then begin TempPicWidth := TempPicWidth - deltax; TempPicHeight := TempPicHeight - deltay; PictSize := TempPicWidth * TempPicHeight; end; end; xProc := Round((TempPicWidth*100)/PicWidth); yProc := Round((TempPicHeight*100)/PicHeight); if xProc > 100 then xProc := 100; if yProc > 100 then yProc := 100; if xProc > yProc then xProc := yProc; F_RasterImageSettings.MaxAllowedTrackVal := xProc; F_RasterImageSettings.TrackBar1.Position := xProc; end; F_RasterImageSettings.TrackBar1Change(F_RasterImageSettings); if F_RasterImageSettings.ShowModal = mrOk then begin FitImageToPage := F_RasterImageSettings.CheckBox1.Checked; if FitImageToPage then begin if F_RasterImageSettings.TrackBar1.Position = 100 then begin TempPicWidth := PicWidth; TempPicHeight := PicHeight; end else begin TempPicWidth := Round(PicWidth/100); TempPicHeight := Round(PicHeight/100); TempPicWidth := TempPicWidth * F_RasterImageSettings.TrackBar1.Position; TempPicHeight := TempPicHeight * F_RasterImageSettings.TrackBar1.Position; end; PictSize := TempPicWidth * TempPicHeight * 3; if PictSize < 180000000 then begin Picture.Width := TempPicWidth; Picture.Height := TempPicHeight; Picture.PixelFormat := pf24bit; end else begin Counter := 0; // resize Counter // 5 % deltax := (TempPicWidth div 50); deltay := (TempPicHeight div 50); CanProceed := True; PictSize := TempPicWidth * TempPicHeight; while CanProceed do begin inc(Counter); // на всякий, чтоб до абсурда не доводить ... if Counter = 50 then begin break; end; //pf24 PictPixelSize := PictSize * 3; if PictPixelSize < MaxVal then begin CanProceed := False; Picture.PixelFormat := pf24bit; end; if CanProceed then begin TempPicWidth := TempPicWidth - deltax; TempPicHeight := TempPicHeight - deltay; PictSize := TempPicWidth * TempPicHeight; end else begin Picture.Width := TempPicWidth; Picture.Height := TempPicHeight; end; end; end; ScaleWKoef := CadPicWidth / TempPicWidth; ScaleHKoef := CadPicHeight / TempPicHeight; // берем меньший if CompareValue(ScaleWKoef, ScaleHKoef) = 1 then FitKoef := ScaleHKoef else FitKoef := ScaleWKoef; end else begin // если не масштабировать на лист -- проверить размер и привести к нормальному, чтобы не вылетело ... Picture.PixelFormat := pf24bit; Picture.Width := 0; MaxVal := 180000000; if F_RasterImageSettings.TrackBar1.Position <> 100 then begin //MaxVal := 1800000 * F_RasterImageSettings.TrackBar1.Position; TempPicWidth := Round((PicWidth/100) * F_RasterImageSettings.TrackBar1.Position); TempPicHeight := Round((PicHeight/100)*F_RasterImageSettings.TrackBar1.Position); end else begin TempPicWidth := PicWidth; TempPicHeight := PicHeight; end; Counter := 0; // resize Counter // 5 % deltax := (TempPicWidth div 50); deltay := (TempPicHeight div 50); CanProceed := True; PictSize := TempPicWidth * TempPicHeight; while CanProceed do begin inc(Counter); // на всякий, чтоб до абсурда не доводить ... if Counter = 50 then begin break; end; //pf24 PictPixelSize := PictSize * 3; if PictPixelSize < MaxVal then begin CanProceed := False; end; if CanProceed then begin TempPicWidth := TempPicWidth - deltax; TempPicHeight := TempPicHeight - deltay; PictSize := TempPicWidth * TempPicHeight; end else begin Picture.Width := TempPicWidth; Picture.Height := TempPicHeight; end; end; end; end else begin Picture.Width := 0; end; end; end; // Tolik 04/02/2020 -- function CheckCanGetMemoForPicture(aPictSize: Cardinal): Boolean; var p: PByte; Mess: string; begin Result := True; try p := AllocMem(aPictSize); except on E: Exception do begin // if E.ClassName = 'EOutOfMeMory' then {$IF Defined (SCS_PE)} Mess := 'Attention! Not enough memory to load image! ' + #13#10 + 'It is recommended to close other applications or contact' + #13#10 + 'to the technical support service.'; {$ELSEIF Defined (SCS_RF)} Mess := 'Внимание! Недостаточно памяти для загрузки изображения!' + #13#10 + 'Рекомендуется закрыть другие приложения или обратиться' + #13#10 + 'в службу техподдержки.'; {$ELSEIF Defined (SCS_UKR)} Mess := 'Увага! Недостатньо пам' + ''''+'яті для завантаження зображення!' + #13#10 + 'Рекомендується закрити інші програмні додатки або звернутися' + #13#10 + 'в службу техпідтримки.'; {$ELSE} Mess := 'Внимание! Недостаточно памяти для загрузки изображения!' + #13#10 + 'Рекомендуется закрыть другие приложения или обратиться' + #13#10 + 'в службу техподдержки.'; {$IFEND} ShowMessage(Mess); Result := False; exit; end; end; FreeMem(p); end; begin inherited create(LHandle, aDrawStyle,aOwner); initialize; originalpoints[1] := DoublePoint(x,y); originalpoints[2] := DoublePoint(x,y); originalpoints[3] := DoublePoint(x,y); originalpoints[4] := DoublePoint(x,y); actualpoints[1] := originalpoints[1]; actualpoints[2] := originalpoints[2]; actualpoints[3] := originalpoints[3]; actualpoints[4] := originalpoints[4]; PictureName := extractFileName(afName); Picture.Width := 0; Picture.Height := 0; FitImageToPage := False; // Tolik 09/08/2019 -- if fileexists(afName) then begin if DrawStyle = mydsNormal then begin try ImageEdited := True; // Tolik 20/04/2018 -- try maxv := 200000000; gdiGraphics:= TGPGraphics.Create(); GPImage := nil; try GPImage := GPImage.FromFile(afName); except AddExceptionToLog('TBMPObject.create FromFile'); if Assigned(gpImage) then freeandnil(gpImage); gdiGraphics.free; exit; end; {$IF Not Defined (FINAL_SCS)} // Tolik -- этим пожно спиздить картинку, если надо ... (на дебаге) //GetEncoderClsid('image/jpeg', encoderClsid); //GPimage.Save('c:\1.jpg', encoderClsid, nil); {$IFEND} Get_PictureFormat(GpImage); if (Picture.Width = 0) or (Picture.Height = 0) then begin if Assigned(gpImage) then freeandnil(gpImage); gdiGraphics.free; exit; end; except if (Picture.Width = 0) or (Picture.Height = 0) then begin //Picture.PixelFormat := pf8bit; //Picture.Width := PictWidth; //Picture.Height := PictHeight; if Assigned(gpImage) then freeandnil(gpImage); gdiGraphics.free; exit; end; end; {begin TempPic := TPicture.Create; TempPic.Bitmap := TBitmap.Create; TempPic.Bitmap.Width := TempPicWidth; TempPic.Bitmap.Height := TempPicHeight; gdiGraphics := gdiGraphics.FromHDC(TempPic.Bitmap.Canvas.Handle); gdiGraphics.DrawImage(GPImage, 0, 0, TempPicWidth, TempPicHeight); Picture.Width := CadPicWidth; Picture.Height := CadPicHeight; rect.Left := 0; rect.Top := 0; Rect.Bottom := CadPicHeight; Rect.Right := CadPicWidth; Picture.Canvas.StretchDraw(Rect,TempPic.Bitmap); TempPic.Free; end else begin} if not CheckCanGetMemoForPicture(Picture.Width*Picture.Width*3) then begin if Assigned(gpImage) then freeandnil(gpImage); gdiGraphics.free; Picture.Width := 0; exit; end; gdiGraphics := gdiGraphics.FromHDC(Picture.Canvas.Handle); //gdigraphics.SetInterpolationMode(3); gdiGraphics.DrawImage(GPImage, 0, 0, Picture.Width, Picture.Height); //end; GPImage.Free; gdiGraphics.free; FitImageToPage := (GAutoScaleRasterImages and Assigned(F_RasterImageSettings) and F_RasterImageSettings.CheckBox1.Checked); if FitImageToPage then begin GImageScale := 0; picW := CadPicWidth / Picture.Width; picH := CadPicHeight / Picture.Height; if compareValue(PicW, PicH) = 1 then GImageScale := PicH else GImageScale := PicW; end; except on EInvalidGraphic do begin AddExceptionToLog('TBMPObject.create'); picture.width := 10; picture.height := 10; end; end; if JPEGBounds then begin PicW := (Picture.width / 3.78); PicH := (Picture.Height / 3.78); end else begin {if bmpres = 0 then bmpres := 180; PicW := (Picture.width / bmpres) * 25.4 ; PicH := (Picture.Height / bmpres) * 25.4 ;} // на всякий .. if bmpresW = 0 then bmpresW := 96; if bmpresH = 0 then bmpresH := 96; // PicW := (Picture.width / bmpresW) * 25.4 ; PicH := (Picture.Height / bmpresH) * 25.4 ; end; if vertZero = 1 then PicH := -1* PicH; if horzZero = 1 then PicW := -1* PicW; originalpoints[2] := DoublePoint(x+PicW,y); originalpoints[3] := DoublePoint(x+PicW,y-PicH); originalpoints[4] := DoublePoint(x,y-PicH); actualpoints[2] := originalpoints[2]; actualpoints[3] := originalpoints[3]; actualpoints[4] := originalpoints[4]; width := 1; color := clBlack; //FreeAndNil(TempPic); end; end else Picture.Width := 0; end; (*constructor TBMPObject.create(x,y:Double; afName: string; LHandle:LongInt; aDrawStyle: TDrawStyle;aOwner: TComponent); var bmpres:Integer; picW,picH :Double; TempPic: TPicture; res1: double; maxv: double; begin inherited create(LHandle, aDrawStyle,aOwner); initialize; originalpoints[1] := DoublePoint(x,y); originalpoints[2] := DoublePoint(x,y); originalpoints[3] := DoublePoint(x,y); originalpoints[4] := DoublePoint(x,y); actualpoints[1] := originalpoints[1]; actualpoints[2] := originalpoints[2]; actualpoints[3] := originalpoints[3]; actualpoints[4] := originalpoints[4]; if DrawStyle = mydsNormal then begin TempPic := TPicture.Create; PictureName := extractFileName(afName); if fileexists(afName) then begin try TempPic.LoadFromFile(afName); try maxv := 200000000; res1 := (TempPic.Graphic.Width) * (TempPic.Graphic.Height) * 32 div 8; Picture.PixelFormat := pf24bit; if res1 > maxv then begin res1 := (TempPic.Graphic.Width) * (TempPic.Graphic.Height) * 24 div 8; if res1 > maxv then begin res1 := (TempPic.Graphic.Width) * (TempPic.Graphic.Height) * 16 div 8; if res1 > maxv then begin Picture.PixelFormat := pf8bit; end else Picture.PixelFormat := pf16bit; end else Picture.PixelFormat := pf24bit; end; Picture.Width := TempPic.Graphic.Width; Picture.Height := TempPic.Graphic.Height; except if (Picture.Width = 0) or (Picture.Height = 0) then begin Picture.PixelFormat := pf8bit; Picture.Width := TempPic.Graphic.Width; Picture.Height := TempPic.Graphic.Height; end; end; Picture.Canvas.Draw(0,0,TempPic.Graphic); //Picture.PixelFormat := pf24bit; bmpres := GetBmpDpi(afName); except on EInvalidGraphic do begin AddExceptionToLog('TBMPObject.create'); // ShowMessage(emInvalidPicture); picture.width := 10; picture.height := 10; end; end; end; if bmpres = 0 then bmpres := 180; PicW := (Picture.width / bmpres) * 25.4 ; if horzZero = 1 then PicW := -1* PicW; PicH := (Picture.Height / bmpres) * 25.4 ; if vertZero = 1 then PicH := -1* PicH; originalpoints[2] := DoublePoint(x+PicW,y); originalpoints[3] := DoublePoint(x+PicW,y-PicH); originalpoints[4] := DoublePoint(x,y-PicH); actualpoints[2] := originalpoints[2]; actualpoints[3] := originalpoints[3]; actualpoints[4] := originalpoints[4]; width := 1; color := clBlack; FreeAndNil(TempPic); end; end; *) class function TBmpObject.ShadowType:TShadowType; begin result := stRectangle; end; class function TBMPObject.CreateShadow(x, y: Double): TFigure; begin result := tbmpobject.create(x,y,'',0,dsTrace,nil); end; function TBMPObject.ShadowClick(ClickIndex:Integer;x, y: Double): Boolean; begin result := true; end; procedure TBMPObject.Initialize; begin inherited; pointcount := 4; ClipFigure := NIl; ClpRgn := 0; SelMode := 2; if DrawStyle = mydsNormal then begin Picture := TBitmap.create; VertFlipped := false; HorzFlipped := false; Image := TBitmap.Create; Image.PixelFormat := pf24bit; Modified := True; end; Tiled := False; end; constructor TBMPObject.createEx(x,y: Double; aBitmap: TBitmap; LHandle: Integer; aDrawStyle: TDrawStyle; aOwner: TComponent); var bmpres: Integer; picW,picH : Double; begin inherited create(LHandle, aDrawStyle,aOwner); bmpres := 180; originalpoints[1] := DoublePoint(x,y); originalpoints[1] := DoublePoint(x,y); originalpoints[2] := DoublePoint(x,y); originalpoints[3] := DoublePoint(x,y); originalpoints[4] := DoublePoint(x,y); actualpoints[1] := originalpoints[1]; actualpoints[2] := originalpoints[2]; actualpoints[3] := originalpoints[3]; actualpoints[4] := originalpoints[4]; SelMode := 2; pointcount := 4; if DrawStyle = mydsNormal then begin PictureName := ''; Picture := TBitmap.create; Picture.Assign(aBitmap); Picture.PixelFormat := pf24bit; PicW := (Picture.width / bmpres) * 25.4 ; if horzZero = 1 then PicW := -1* PicW; PicH := (Picture.Height / bmpres) * 25.4 ; if vertZero = 1 then PicH := -1* PicH; originalpoints[2] := DoublePoint(x+PicW,y); originalpoints[3] := DoublePoint(x+PicW,y-PicH); originalpoints[4] := DoublePoint(x,y-PicH); actualpoints[2] := originalpoints[2]; actualpoints[3] := originalpoints[3]; actualpoints[4] := originalpoints[4]; width := 1; color := clBlack; VertFlipped := false; HorzFlipped := false; Image := TBitmap.Create; Modified := True; ImageEdited := True; // Tolik 20/04/2018 -- end; end; function TBMPObject.Edit: Boolean; begin result := false; end; function TBMPObject.CreateModification: TFigure; var res: TFigure; r: TDoubleRect; figMaxX, figMaxY, figMinX,figMinY: Double; begin if (assigned(ClipFigure)) and (Selmode <> 0) then begin res := TBMPObject.create(0,0,'',0,dsTrace,nil); r := GetBoundRect; res.actualpoints[1] := DoublePoint(r.left,r.top); res.actualpoints[2] := DoublePoint(r.right,r.top); res.actualpoints[3] := DoublePoint(r.right,r.bottom); res.actualpoints[4] := DoublePoint(r.left,r.bottom); end else begin Res := inherited CreateModification; end; res.RotPoint := RotPoint; CreateModification := res; end; function TBMPObject.EndModification(CadControl: Pointer;mp: TModPoint; TraceFigure: TFigure; x,y:Double;Shift: TShiftState): boolean; var a: integer; p1: TDoublePoint; distx,disty: Double; GRect: TDoubleRect; begin if (assigned (clipfigure)) and (selmode <> 0) then begin GRect := mp.Figure.GetBoundRect; distx := 0; distY := 0; If mp.SeqNbr in [3,4,5] then begin distX := x - GRect.Right; p1.x := GRect.Left; end else if mp.SeqNbr in [1,8,7] then begin distX := GRect.Left-x; p1.x := GRect.Right; end; If mp.SeqNbr in [1,2,3] then begin distY := y - GRect.Top; p1.y := GRect.Bottom; end else if mp.SeqNbr in [5,6,7] then begin distY := GRect.Bottom - y; p1.y := GRect.Top; end; if (distX <> 0) and (distY <> 0) then scale( 1+distx/(GRect.Right-Grect.Left), 1+disty/(GRect.Top-Grect.Bottom),p1) else if distX = 0 then scale( 1,1+disty/(GRect.Top-Grect.Bottom),p1) else if distY = 0 then scale( 1+distx/(GRect.Right-Grect.Left),1,p1); end else begin inherited EndModification(CadControl,mp,TraceFigure,x,y,Shift); end; ResetRegion; Modified := True; ImageEdited := True; // Tolik 20/04/2018 -- if assigned(onModified) then OnModified(Self); end; class function TBMPObject.CreateFromShadow(aOwner: TComponent; LHandle: Integer; Shadow: TFigure): TFigure; var cad: TPCDrawing; OPD : TOpenPictureDialog; x,y: Double; ext: string; begin result := nil; cad := TPCDrawing(aOwner); x := shadow.ap1.x; y := shadow.ap1.y; OPD := TOpenPictureDialog.Create(nil); if Cad.DefaultPictureFolder <> '' then Opd.InitialDir := Cad.DefaultPictureFolder; OPD.Filter := GraphicFilter(TGraphic); if OPD.Execute then begin ext := UpperCase(extractfileext(OPD.FileName)); if (ext = '.WMF') or (ext = '.EMF') then result := TWMFObject.create(x,y,OPD.fileName,Lhandle,mydsNormal,aOwner) else result := TBMPObject.create(x,y,OPD.fileName,LHandle,mydsNormal,aOwner); result.DiagonalScale := true; end; //ImageEdited := True; // Tolik 20/04/2018 -- end; function TBMPObject.TraceModification(CadControl: Pointer;mp: TModPoint;TraceFigure: TFigure; x,y: Double;Shift: TShiftState): boolean; begin if assigned(ClipFigure) and (selmode <> 0) then begin result := TraceModificationClipped(CadControl,mp,TraceFigure,x,y,shift); exit; end else begin result := inherited TraceModification(CadControl,mp,TraceFigure, x,y,Shift); end; end; function TBmpObject.TraceModificationClipped(CadControl: Pointer;mp: TModPoint;TraceFigure:TFigure; x,y: Double;Shift: TShiftState): boolean; var GRect: TDoubleRect; begin GRect := GetBoundRect; If MP.SeqNbr in [3,4,5] then begin TraceFigure.ActualPoints[2] := DoublePoint(x,TraceFigure.ActualPoints[2].y); TraceFigure.ActualPoints[3] := DoublePoint(x,TraceFigure.ActualPoints[3].y); end else if MP.SeqNbr in [1,8,7] then begin TraceFigure.ActualPoints[1] := DoublePoint(x,TraceFigure.ActualPoints[1].y); TraceFigure.ActualPoints[4] := DoublePoint(x,TraceFigure.ActualPoints[4].y); end; If mp.SeqNbr in [1,2,3] then begin TraceFigure.ActualPoints[1] := DoublePoint(TraceFigure.ActualPoints[1].x,y); TraceFigure.ActualPoints[2] := DoublePoint(TraceFigure.ActualPoints[2].x,y); end else if mp.SeqNbr in [5,6,7] then begin TraceFigure.ActualPoints[3] := DoublePoint(TraceFigure.ActualPoints[3].x,y); TraceFigure.ActualPoints[4] := DoublePoint(TraceFigure.ActualPoints[4].x,y); end; end; procedure TBMPObject.WriteToStream(Stream: TStream); var xByte,xCode,xZero: Byte; xInt,xSize: Integer; xStr: String; xStream: TMemoryStream; Jpeg: TJPEGImage; (* function TPCDrawing.PrepareBitmap(aPdfSave: Boolean = False): TBitmap; var Form: TForm; res1: double; maxv: double; BadSize: boolean; PictW, PictH, PictureSize, PicturePixelSize: Int64; LoopDelta: Double; i: Integer; begin prDpm := DotsPerMilOrig; Form := GetForm; if Form <> nil then prDpm := Form.PixelsPerInch / 25.4; if GExportUSeScale then begin prDpm := prDpm * self.ZoomScale / 100; end; OFFMMX := 0; OFFMMY := 0; TileX := 0; TileY := 0; Result := TBitmap.Create; try maxv := 200000000; PictW := Round((WorkWidth) * prDpm); PictH := Round((WorkHeight) * prDpm); // Tolik 14/08/2019 -- тут выставляем формат картинки 24 бита железно, т.к., например ПДФ поддерживает ТОЛЬКО 24 бита!!! // чтобы не случилось бяки, будем подгонять размер изображения, если потребуется if aPdfSave then // если PDF begin Result.PixelFormat := pf24bit; PictureSize := PictW * PictH; //PictureSize := PictureSize * 24; PicturePixelSize := PictureSize * 3; // 24 бит - 3 байта BadSize := True; if PicturePixelSize < maxv then BadSize := False; if BadSize then begin i := 0; LoopDelta := SimpleRoundTo(prDpm/10); end; while BadSize do begin inc(i); prDpm := prDpm - LoopDelta; PictW := Round((WorkWidth) * prDpm); PictH := Round((WorkHeight) * prDpm); PictureSize := PictW * PictH; PicturePixelSize := PictureSize * 3; if PicturePixelSize < maxv then break; if i = 9 then LoopDelta := SimpleRoundTo(LoopDelta/10); if i = 18 then // если не сможем получить приемлемое значение -- приведем картинку примерно к 120 МБ (на всякий, можно бы и больше, но хз...) begin PictW := Round(40000000/WorkHeight); PIctH := Round(40000000/PictW); break; end; end; end else begin Result.PixelFormat := pf32bit; PictureSize := PictW * PictH; PicturePixelSize := PictureSize * 4; // 32 - bit if PicturePixelSize > maxv then begin PicturePixelSize := PictureSize * 3; //24 div 8; if PicturePixelSize > maxv then begin PicturePixelSize := PictureSize * 2; //16 div 8; if PicturePixelSize > maxv then begin Result.PixelFormat := pf8bit; end else Result.PixelFormat := pf16bit; end else Result.PixelFormat := pf24bit; end; end; Result.Width := PictW; Result.Height := PictH; SetEngine(Result.canvas,prConvertXY,prDeConvertXY,prConvertDim,prDeConvertDim,false,nil); except if (Result.Width = 0) or (Result.Height = 0) then begin try Result.PixelFormat := pf8bit; Result.Width := Round((WorkWidth) * prDpm); Result.Height := round((WorkHeight) * prDpm); SetEngine(Result.canvas,prConvertXY,prDeConvertXY,prConvertDim,prDeConvertDim,false,nil); except end; end; end; end; *) begin inherited; xZero := 0; xStr := PictureName;WriteStrField(180,Stream,xStr); xByte := 1; if VertFlipped then WriteField(90,Stream,xByte,1) else WriteField(90,Stream,xZero,1); if HorzFlipped then WriteField(91,Stream,xByte,1) else WriteField(91,Stream,xZero,1); if Transparent then WriteField(92,Stream,xByte,1) else WriteField(92,Stream,xZero,1); if Skewed then WriteField(93,Stream,xByte,1) else WriteField(93,Stream,xZero,1); if Tiled then WriteField(94,Stream,xByte,1) else WriteField(94,Stream,xZero,1); xStream := TMemoryStream.Create; Jpeg := TJPEGImage.Create; Jpeg.Assign(Picture); Jpeg.SaveToStream(xStream); FreeAndNil(Jpeg); xSize := xStream.Size; WriteStreamField(150,Stream,xStream); xStream.Free; if assigned(ClipFigure) then begin xStream := TMemoryStream.Create; ClipFigure.WriteToStream(xStream); xSize := xStream.Size; xStream.Seek(0,soFromBeginning); xCode := 151;Stream.Write(xCode,1); Stream.Write(xSize,4); StreamToStream(xStream,Stream,xSize); xStream.Free; end; end; Procedure TBmpObject.SetPropertyFromStream(xCode:Byte;data:pointer;size:integer); var mstr:TMemoryStream; TempPic: TJpegImage; //TempPic: TBitmap; res1: double; maxv: double; begin Case xcode of 90: VertFlipped := (pByte(data)^ = 1); 91: HorzFlipped := (pByte(data)^ = 1); 92: Transparent := (pByte(data)^ = 1); 93: Skewed := (pByte(data)^ = 1); 94: Tiled := (pByte(data)^ = 1); 150: begin mStr := TMemoryStream.Create; mStr.Write(pByte(data)^,size); mStr.Position := 0; TempPic := TJpegImage.create; //TempPic := TBitmap.Create; try tempPic.LoadFromStream(mStr); try maxv := 200000000; res1 := (TempPic.Width) * (TempPic.Height) * 32 div 8; Picture.PixelFormat := pf24bit; if res1 > maxv then begin res1 := (TempPic.Width) * (TempPic.Height) * 24 div 8; if res1 > maxv then begin res1 := (TempPic.Width) * (TempPic.Height) * 16 div 8; if res1 > maxv then begin Picture.PixelFormat := pf8bit; end else Picture.PixelFormat := pf16bit; end else Picture.PixelFormat := pf24bit; end; Picture.Width := TempPic.Width; Picture.Height := TempPic.Height; except if (Picture.Width = 0) or (Picture.Height = 0) then begin Picture.PixelFormat := pf8bit; Picture.Width := TempPic.Width; Picture.Height := TempPic.Height; end; end; Picture.Canvas.Draw(0, 0, TempPic); //Picture.PixelFormat := pf24bit; except mStr.Position := 0; try Picture.LoadFromStream(mStr); except on E: Exception do AddExceptionToLogExt(ClassName, 'SetPropertyFromStream', E.Message); end; end; FreeAndNil(TempPic); FreeAndNil(mStr); end; 151: begin mStr := TMemoryStream.Create; mStr.Write(pByte(data)^,size); mStr.Position := 0; ClipFigure := TFigure.CreateFromStream(mStr,LayerHandle,DrawStyle,Owner); mStr.Free; end; 180: Picturename := String(pchar(data)); end; end; Procedure TBMPObject.FlipHorz; Begin with Picture do begin Picture.Transparent := False; Canvas.StretchDraw (Rect(Width-1,0,-1,Height),Picture); HorzFlipped := not HorzFlipped; end; Modified := True; ImageEdited := True; // Tolik 20/04/2018 -- End; Procedure TBMPObject.FlipVert; Begin with Picture do begin Picture.Transparent := False; Canvas.StretchDraw (Rect(0,Height-1,Width,-1),Picture); VertFlipped := not VertFlipped; end; Modified := True; ImageEdited := True; // Tolik 20/04/2018 -- End; Procedure TBMPObject.mirror(Point1,Point2: TDoublePoint); var Teta: Double; BufP : TDoublePoint; Begin inherited mirror(Point1,Point2); try Teta := arctan(abs(point1.y - point2.y)/abs(point1.x-point2.x)); except Teta := pi/2; end; if Teta > pi/4 then begin FlipHorz; BufP := actualPoints[2]; actualPoints[2] := actualPoints[1]; actualPoints[1] := bufP; BufP := originalPoints[2]; originalPoints[2] := originalPoints[1]; originalPoints[1] := bufP; BufP := actualPoints[3]; actualPoints[3] := actualPoints[4]; actualPoints[4] := bufP; BufP := originalPoints[3]; originalPoints[3] := originalPoints[4]; originalPoints[4] := bufP; end else FlipVert; Modified := True; ImageEdited := True; // Tolik 20/04/2018 -- End; procedure TBMPObject.setTrans(value: Boolean); begin fTrans := value; modified := true; ImageEdited := True; // Tolik 20/04/2018 -- end; procedure TBMPObject.Select; begin inherited select; if assigned(ClipFigure) then Clipfigure.Select; end; procedure TBMPObject.DeSelect; begin inherited deselect; if assigned(ClipFigure) then Clipfigure.deSelect; end; procedure TBMPObject.drawselectionpoints(DEngine: TPCDrawEngine; isGrayed: Boolean); begin if selmode = 0 then inherited else if selmode = 1 then begin if assigned(ClipFigure) then begin ClipFigure.drawselectionpoints(DEngine,isGrayed); end else begin inherited; end; end else begin inherited; end; end; procedure TBMPObject.draw(DEngine: TPCDrawEngine;isGrayed:Boolean); var Layer: TLayer; acolor : Tcolor; points : Array [0..3] of Tpoint; aDpm :Double; s: integer; aStyle: integer; begin aColor := color; if (aColor = -255) and (LayerHandle <> 0) then begin aColor := TLayer(LayerHandle).PenColor; end; //Tolik 20/10/2021 -- { if (isGrayed) then acolor := TPCDrawing(Owner).FGrayedColor; //06.08.2012 GrayedColor; if (isGrayed) or (drawStyle = dsTrace) then begin s := 0; if (drawStyle = dsTrace) then begin acolor := clLime; s := 1; end; DEngine.DrawLine(ap1.x,ap1.y,ap2.x,ap2.y,acolor,1,s,0); DEngine.DrawLine(ap2.x,ap2.y,ap3.x,ap3.y,acolor,1,s,0); DEngine.DrawLine(ap3.x,ap3.y,ap4.x,ap4.y,acolor,1,s,0); DEngine.DrawLine(ap4.x,ap4.y,ap1.x,ap1.y,acolor,1,s,0); if drawSTyle = mydsNormal then begin DEngine.DrawLine(ap1.x,ap1.y,ap3.x,ap3.y,acolor,1,s,0); DEngine.DrawLine(ap2.x,ap2.y,ap4.x,ap4.y,acolor,1,s,0); end; end else } begin adpm := 1; Dengine.ConvertLen(aDpm); if aDpm <> dpm then begin modified := true; dpm := aDpm; end; if assigned(ClipFigure) then begin ClipFigure.brs := ord(bsSolid); Clipfigure.ResetRegion; ClipFigure.color := aColor; ClipFigure.Width := width; ClipFigure.Style := style; ClipFigure.brc := brc; ClipFigure.draw(DEngine,isGrayed); clprgn := ClipFigure.RegHandle; Dengine.Clip(clpRgn); end; if assigned(clipFigure) then aStyle := ord(psClear) else aStyle := Style; // Tolik -- 20/04/2018 -- {DEngine.DrawPicture(ap1,ap2,ap3,ap4,acolor,width,astyle, Transparent,Modified,picture,Image,true,Skewed,RegHandle,Tiled ); } //Tolik 20/10/2021 -- {DEngine.DrawPicture(ap1, ap2, ap3, ap4, acolor, width, astyle, Transparent, Modified, picture, Image, ImageEdited, true, Skewed, RegHandle, Tiled);} isGrayed := TLayer(LayerHandle).visible = grayed; if isGrayed then begin ImageEdited := True; DEngine.DrawPicture(ap1, ap2, ap3, ap4, acolor, width, astyle, Transparent, Modified, picture, Image, ImageEdited, true, Skewed, RegHandle, Tiled, TPowerCad(owner).FGrayedColor) end else DEngine.DrawPicture(ap1, ap2, ap3, ap4, acolor, width, astyle, Transparent, Modified, picture, Image, ImageEdited, true, Skewed, RegHandle, Tiled); // if assigned(ClipFigure) then begin Dengine.Clip(0); end; end; //Tolik if RegHandle <> 0 then begin GetRegObject; if TBrushStyle(brs) <> bsClear then RegObject.CheckPointByRects := true; deleteObject(RegHandle); RegHandle := 0; end; // end; procedure TBMPObject.getModPoints(ModList: TMyList); var Layer: TLayer; MT,MR,MB,ML : TDoublePoint; CControl: TPCDrawing; figMaxX,figMaxY,figMinX,figMinY: Double; acolor: integer; p1,p2,p3,p4: TDoublePoint; isPolyline: Boolean; begin CControl := TPCDrawing(Owner); if assigned(ClipFigure) and (SelMode = 2) then begin ClipFigure.getbounds(figMaxX,figMaxY,figMinX,figMinY); p1 := DoublePoint(figMinX,figMinY); p2 := DoublePoint(figMaxX,figMinY); p3 := DoublePoint(figMaxX,figMaxY); p4 := DoublePoint(figMinX,figMaxY); end else begin p1 := ap1;p2:= ap2;p3 := ap3;p4 := ap4; end; isPolyline := Skewed; if assigned(ClipFigure) and (SelMode <> 0) then isPolyline := False; if not isPolyline then begin MT := MPoint(p1,p2); MR := MPoint(p2,p3); MB := MPoint(p3,p4); ML := MPoint(p4,p1); if SelMode = 2 then acolor := clRed else acolor := clBlue; ModList.Add(CControl.RegisterModPoint(self,ptRectPoint,ptRect,aColor,PointDim,p1.x,p1.y,1)); ModList.Add(CControl.RegisterModPoint(self,ptRectPoint,ptRect,aColor,PointDim,MT.x,MT.y,2)); ModList.Add(CControl.RegisterModPoint(self,ptRectPoint,ptRect,aColor,PointDim,p2.x,p2.y,3)); ModList.Add(CControl.RegisterModPoint(self,ptRectPoint,ptRect,aColor,PointDim,MR.x,MR.y,4)); ModList.Add(CControl.RegisterModPoint(self,ptRectPoint,ptRect,aColor,PointDim,p3.x,p3.y,5)); ModList.Add(CControl.RegisterModPoint(self,ptRectPoint,ptRect,aColor,PointDim,MB.x,MB.y,6)); ModList.Add(CControl.RegisterModPoint(self,ptRectPoint,ptRect,aColor,PointDim,p4.x,p4.y,7)); ModList.Add(CControl.RegisterModPoint(self,ptRectPoint,ptRect,aColor,PointDim,ML.x,ML.y,8)); end else begin acolor := clBlue; ModList.Add(CControl.RegisterModPoint(self,ptPolyPoint,ptCircle,aColor,PointDim,p1.x,p1.y,1)); ModList.Add(CControl.RegisterModPoint(self,ptPolyPoint,ptCircle,aColor,PointDim,p2.x,p2.y,2)); ModList.Add(CControl.RegisterModPoint(self,ptPolyPoint,ptCircle,aColor,PointDim,p3.x,p3.y,3)); ModList.Add(CControl.RegisterModPoint(self,ptPolyPoint,ptCircle,aColor,PointDim,p4.x,p4.y,4)); end; end; procedure TBMPObject.getbounds(var figMaxX,figMaxY,figMinX,figMinY: Double); var a : integer; begin if assigned(clipfigure) and (selmode <> 0) then begin ClipFigure.GetBounds(figMaxX,figMaxY,figMinX,figMinY); exit; end; figMaxX := ap1.x; figMinX := ap1.x; figMaxY := ap1.y; figMinY := ap1.y; For a := 1 to 4 do begin if actualpoints[a].x > figMaxX then figMaxX := actualpoints[a].x; if actualpoints[a].x < figMinX then figMinX := actualpoints[a].x; if actualpoints[a].y > figMaxY then figMaxY := actualpoints[a].y; if actualpoints[a].y < figMinY then figMinY := actualpoints[a].y; end; end; function TBMPObject.isPointIn(x,y:Double): boolean; begin result := false; result := inherited isPointIn(x,y); if (not result) and (assigned(ClipFigure)) and (selmode <> 0) then begin ClipFigure.RegHandle := clpRgn; result := ClipFigure.isPointIn(x,y) end else if (not result) then begin result := IsPointInRegion(x,y); //Tolik result := IsPointInRegionByRegObj(x,y); // end; end; function TBMPObject.duplicate:TFigure; var res : TBMPObject; begin res := TBMPObject.create( originalpoints[1].x, originalpoints[1].y, PictureName, LayerHandle,DrawStyle,Owner); res.angle := angle; res.actualpoints[1] := actualpoints[1]; res.originalpoints[1] := originalpoints[1]; res.actualpoints[2] := actualpoints[2]; res.originalpoints[2] := originalpoints[2]; res.actualpoints[3] := actualpoints[3]; res.originalpoints[3] := originalpoints[3]; res.actualpoints[4] := actualpoints[4]; res.originalpoints[4] := originalpoints[4]; res.Picture.Assign(Picture); res.rotPoint.x := rotPoint.x ; res.rotPoint.y := rotPoint.y ; res.HorzFlipped := HorzFlipped; res.VertFlipped := VertFlipped; res.transparent := transparent; if assigned(ClipFigure) then begin res.ClipFigure := ClipFigure.duplicate; end; res.AngleToPoint := AngleToPoint; result := res; end; Procedure TBMPObject.rotate(aAngle:Double; cPoint: TDoublePoint); begin Modified := True; ImageEdited := True; // Tolik 20/04/2018 -- if not assigned(clipfigure) then begin inherited; exit; end; if selmode = 0 then inherited else if selmode = 1 then ClipFigure.rotate(aAngle,cPoint) else begin inherited; ClipFigure.rotate(aAngle,cPoint); end; end; procedure TBMPObject.SkewShape; begin Skewed := True; Modified := true; end; procedure TBMPObject.scale(percentx,percenty: double; rPoint: TDoublepoint); begin Modified := True; if not assigned(clipfigure) then begin inherited; exit; end; if selmode = 0 then inherited else if selmode = 1 then ClipFigure.scale(percentx,percenty,rPoint) else begin inherited; ClipFigure.scale(percentx,percenty,rPoint); end; end; Procedure TBMPObject.move(deltax,deltay:Double); begin if not assigned(clipfigure) then begin inherited; exit; end; if selmode = 0 then inherited else if selmode = 1 then ClipFigure.Move(deltax,deltay) else begin inherited; ClipFigure.Move(deltax,deltay) end; end; destructor TBMPObject.Destroy; begin Picture.Dormant; Picture.FreeImage; Picture.Free; Image.FreeImage; image.free; if Assigned(ClipFigure) then FreeAndNil(ClipFigure); inherited; end; procedure TBmpObject.MenuClicked(commandID:integer); var mnIdx: integer; begin mnIdx := commandId-MenuIndex; case mnIdx of 0: Transparent := not Transparent; 1: FlipVert; 2: FlipHorz; 3: SkewShape; 4: SelMode := 0; 5: SelMode := 1; 6: SelMode := 2; else begin if assigned(ClipFigure) then ClipFigure.MenuClicked(commandId); end; end; end; procedure TBMPObject.UpdateMenu(var PopMenu: TPopUpMenu; var sIndex: Integer); var mnItem,mnSub: TMenuItem; pre : Boolean; begin menuIndex := sIndex; pre:= false; if (not assigned(ClipFigure)) or (SelMode = 0) then begin pre := true; mnItem := TMenuItem.Create(PopMenu); mnItem.Tag := sIndex; mnItem.Caption := fmTransparent; if (Transparent) then mnItem.Checked := true; PopMenu.Items.Add(mnItem); mnItem := TMenuItem.Create(PopMenu); mnItem.Tag := sIndex+1; mnItem.Caption := fmFlipVert; PopMenu.Items.Add(mnItem); mnItem := TMenuItem.Create(PopMenu); mnItem.Tag := sIndex+2; mnItem.Caption := fmFlipHorz; PopMenu.Items.Add(mnItem); mnItem := TMenuItem.Create(PopMenu); mnItem.Tag := sIndex+3; mnItem.Caption := fmSkewBitmap; PopMenu.Items.Add(mnItem); end; if assigned(ClipFigure) then begin if pre then begin mnItem := TMenuItem.Create(PopMenu); mnItem.Tag := -1; mnItem.Caption := '-'; PopMenu.Items.Add(mnItem); end; mnItem := TMenuItem.Create(PopMenu); mnItem.Tag := sIndex+4; mnItem.Caption := fmSelectBitmap; if (selmode = 0) then mnItem.Checked := true; PopMenu.Items.Add(mnItem); mnItem := TMenuItem.Create(PopMenu); mnItem.Tag := sIndex+5; mnItem.Caption := fmSelectClipfigure; if (selmode = 1) then mnItem.Checked := true; PopMenu.Items.Add(mnItem); mnItem := TMenuItem.Create(PopMenu); mnItem.Caption := fmSelectGroup; mnItem.Tag := sIndex+6; if (selmode = 2) then mnItem.Checked := true; PopMenu.Items.Add(mnItem); if selmode = 1 then begin mnItem := TMenuItem.Create(PopMenu); mnItem.Tag := -1; mnItem.Caption := '-'; PopMenu.Items.Add(mnItem); ClipFigure.UpdateMenu(PopMenu,sIndex); end; sIndex := SIndex+7; end else sIndex := SIndex+4; end; (* ========================================================================== *) // TText IMPLEMENTATION // (* ========================================================================== *) constructor TText.create( aX1,aY1,h,w: double;atext: string; FontName:String; FontCharset: Byte; aColor:Integer; LHandle:LongInt; aDrawStyle: TDrawStyle;aOwner: TComponent); var p1 : TDoublePoint; TM : TTextMetric; FCanvas: TCanvas; FontRecord : TLogFont; xHeight,xWidth: Double; vl,hl:DOuble; xlen: Double; r: real; //TextHeight: Double; mCanvas: TMetafileCanvas; ww,hh: Double; begin inherited create(LHandle,aDrawStyle,aOwner); initialize; BoxWidth := -1; // Tolik 18/10/2019 -- Color := aColor; Text := aText; Font.Charset := FontCharset; Font.Name := FontName; Font.Color := aColor; Height := h; CWidth := w; Modified := true; originalpoints[1] := DoublePoint(ax1,ay1); actualpoints[1]:= DoublePoint(ax1,ay1); if owner <> nil then begin TPCDrawing(Owner).DEngine.GetTextLens(TextLength,TextHeight,Text,Font,Height,CWidth,CSpace); (* Fcanvas := TPCDrawing(Owner).DEngine.canvas; xHeight := Height*4; FCanvas.Font.Height := Round(xHeight); if CWidth <> 0 then begin xWidth := CWidth*4; GetObject(FCanvas.Font.Handle,sizeof(FontRecord),Addr(FontRecord)); FontRecord.lfWidth := Round(xWidth); FCanvas.Font.handle := CreateFontIndirect(FontRecord); end; TextLength := Fcanvas.TextWidth(text); TextHeight := Fcanvas.TextHeight(text); TextLength := (TextLength/4); TextHeight := (TextHeight/4); *) if HorzZero = 1 then hl := -1 else hl := 1; if VertZero = 1 then vl := -1 else vl := 1; end; originalpoints[2] := Doublepoint( originalpoints[1].x + hl*TextLength, originalpoints[1].y); actualpoints[2] := Doublepoint( originalpoints[1].x + hl*TextLength, originalpoints[1].y); originalpoints[3] := Doublepoint( originalpoints[1].x + hl*TextLength , originalpoints[1].y - vl*TextHeight); actualpoints[3] := Doublepoint( originalpoints[1].x + hl*TextLength , originalpoints[1].y - vl*TextHeight); originalpoints[4] := Doublepoint( originalpoints[1].x , originalpoints[1].y - vl*TextHeight); actualpoints[4] := Doublepoint( originalpoints[1].x , originalpoints[1].y - vl*TextHeight); end; class function TText.ShadowType:TShadowType; begin result := stRectangle; end; class function TText.CreateShadow(x, y: Double): TFigure; begin result := TText.Create(x,y,1,1,'','',0,0,0,dsTrace,nil); end; Function TText.ShadowClick(ClickIndex:Integer;x,y: Double):Boolean; begin result := true; end; procedure TText.Initialize; begin inherited; Font := TFont.Create; pointcount := 4; Angle := 0; CSpace := 0; fKeepA := false; OutLined := False; end; function TText.Edit: Boolean; var EnterStr: string; begin Result := False; EnterStr := Text; // if InputQuery(csTextTool, msEnterNewText, EnterStr) then if InputQuery(cDrawObjects_Mes6, cDrawObjects_Mes5, EnterStr) then begin Text := EnterStr; Modified := True; result := true; end; end; class function TText.CreateFromShadow(aOwner: TComponent; LHandle: Integer; Shadow: TFigure): TFigure; var EnterStr: string; cad: TPCDrawing; begin cad := TPCDrawing (aOwner); // if InputQuery(csTextTool, msEnterNewText, EnterStr) then if InputQuery(cDrawObjects_Mes6, cDrawObjects_Mes5, EnterStr) then begin result := TText.Create(shadow.ap1.x, shadow.ap1.y, cad.DefaultTextHeight, 0, enterstr, cad.Font.name, cad.font.charset, Cad.Font.Color, LHandle, mydsNormal, aOwner); TText(result).Font.Style := Cad.Font.Style; end else result := nil; end; procedure TText.WriteToStream(Stream: TStream); var xByte: Byte; xInt: Integer; xStr: String; xDbl: Double; begin inherited; xStr := Text; WriteStrField(180,Stream,xStr); xStr := Font.Name;WriteStrField(181,Stream,xStr); xInt := Color; WriteField(21,Stream,xInt,4); xInt := brc; WriteField(22,Stream,xInt,4); xDbl := Height; WriteField(221,Stream,xDbl,8); xDbl := CSpace; WriteField(222,Stream,xDbl,8); xDbl := Cwidth; WriteField(223,Stream,xDbl,8); xDbl := Angle; WriteField(224,Stream,xDbl,8); xByte := 1; if fsBold in Font.Style then WriteField(90,Stream,xByte,1); if fsItalic in Font.Style then WriteField(91,Stream,xByte,1); if fsStrikeout in Font.Style then WriteField(92,Stream,xByte,1); if fsUnderLine in Font.Style then WriteField(93,Stream,xByte,1); if Outlined then WriteField(94,Stream,xByte,1); // Tolik 22/11/2019 -- //xByte := brs; if brs = -1 then xByte := 255 else xByte := brs; // WriteField(95,Stream,xByte,1); end; Procedure TText.SetPropertyFromStream(xCode:Byte;data:pointer;size:integer); var Ratio: Double; begin Case xcode of 20: Height := pInt(data)^/10; 21: Color := pInt(data)^; 22: brc := pInt(data)^; 90: font.Style := font.Style + [fsBold]; 91: font.Style := font.Style + [fsItalic]; 92: font.Style := font.Style + [fsStrikeout]; 93: font.Style := font.Style + [fsUnderLine]; 94: Outlined := True; // Tolik 22/11/2019 -- //95: brs := pByte(data)^; 95: begin if pByte(data)^ = 255 then brs := -1 else brs := pByte(data)^; end; // //Tolik 26/03/2019 -- //180: Text := string(pAnsiChar(data)); //181: font.name := string(AnsiChar(data)); 180: Text := string(pchar(data)); 181: font.name := string(pchar(data)); // 220: begin Ratio := pDouble(data)^; if ratio < 0 then CWidth := -ratio else CWidth := Height*Ratio; end; 221: Height := pDouble(data)^; 222: CSpace := pDouble(data)^; 223: CWidth := pDouble(data)^; 224: Angle := pDouble(data)^; end; end; procedure TText.draw(DEngine: TPCDrawEngine;isGrayed:Boolean); var Layer: TLayer; acolor : TColor; a : integer; TestX,TestY1,TestY2,z: Double; TopY : boolean; lMult: integer; points: TDoublePointArr; xlen: Double; nLen,nH: Integer; p: TDoublePointArr; fCanvas: TMetafileCanvas; ol:Boolean; begin ol := outlined and not Incombined; aColor := color; if (aColor = -255) and (LayerHandle <> 0) then begin aColor := TLayer(LayerHandle).TextColor; end; if (isGrayed) then acolor := TPCDrawing(Owner).FGrayedColor; //06.08.2012 GrayedColor; font.Color := acolor; DEngine.canvas.Pen.color := clBlack; //if screen.Fonts.IndexOf(Font.Name) = -1 then Font.Name := 'Arial'; TestX := 0; TestY1:= 100; TestY2 := 200; z := 0; DEngine.ConvertPoint(TestX,TestY1,Z); DEngine.ConvertPoint(TestX,TestY2,Z); if TestY2 > TestY1 then topY := true else topY := false; nh := 0; nlen := 0; if TopY then lMult := 1 else lMult := -1; if DrawStyle = dsTrace then begin DEngine.Canvas.Pen.Mode := pmXor; GetPointArray(points); DEngine.drawpolygon(points,clLime,1,1,0,0,RegHandle); end else begin DEngine.Canvas.Pen.Mode := pmCopy; if ol then BeginPath(DEngine.Canvas.Handle); if fKeepA then begin DEngine.drawtext(ap1,ap2,ap3,ap4,lMult*angle,text,font,height,0,cSpace,nH,nLen); fKeepA := False; end else DEngine.drawtext(ap1,ap2,ap3,ap4,lMult*angle,text,font,height,CWidth,cSpace,nH,nLen); TextHeight := nH; TextLength := nLen; if ol then begin EndPath(DEngine.Canvas.Handle); DEngine.Canvas.Pen.Color := color; DEngine.Canvas.Pen.Width := Width; DEngine.Canvas.Pen.Style := TPenStyle(style); DEngine.Canvas.Brush.Color := brc; DEngine.Canvas.Brush.Style := TBrushStyle(brs); StrokeANDFillPath(DEngine.Canvas.Handle); end; end; if DrawStyle = mydsNormal then begin if Modified then begin SetRegionPoints; if (nh <> 0) and (nLen <> 0) then Modified := False; end; ResetRegion; if Reghandle = 0 then begin SetLength(p,4); p[0] := ap1;p[1] := ap2;p[2] := ap3;p[3] := ap4; RegHandle := DEngine.PolygonRegion(p); end; end; //Tolik 24/05/2019 -- SetLength(Points, 0); SetLength(P, 0); // //Tolik if RegHandle <> 0 then begin GetRegObject; if TBrushStyle(brs) <> bsClear then RegObject.CheckPointByRects := true; deleteObject(RegHandle); RegHandle := 0; end; // end; procedure TText.getModPoints(ModList: TMyList); var MR : TDoublePoint; CControl: TPCDrawing; pt: TmodPoint; begin inherited; CControl := TPCDrawing(Owner); if Modlist.Count = 4 then begin MR := MPoint(ap2,ap3); ModList.Add(CControl.RegisterModPoint(self,ptRectPoint,ptRow,clRed,PointDim,MR.x,MR.y,4)); end else begin pt := ModList[5]; pt.DType := ptRow; pt.Color := clRed; end; end; function TText.EndModification(CadControl: Pointer; mp: TModPoint; TraceFigure: TFigure; x, y: Double; Shift: TShiftState): boolean; var wNew,wOld,wDist: Double; hNew,hOld,hDist: Double; cnt: Integer; wChar: Double; cad: TPCDrawing; begin wOld := GetLineLenght(ap1,ap2); hOld := GetLineLenght(ap2,ap3); result := inherited endModification(CadControl,mp,TraceFigure,x,y,Shift); cad := TPCDrawing(CadControl); if mp.SeqNbr = 4 then begin wNew := GetLineLenght(ap1,ap2); wDist := wNew-wOld; cnt := length(Text); if Cnt < 2 then CSpace := 0 else CSpace := CSpace+(wDist / (cnt-1)); Modified := true; end else begin Cad.Dengine.TextToRect(ap1,ap2,ap3,ap4,Text,Font,CSpace,CWidth,Height); Modified := True; end; end; function TText.isPointIn(x,y:Double): boolean; begin result := inherited isPointIn(x,y); if result then exit; result := IsPointInRegion(x,y); //Tolik Result := IsPointInRegionByRegObj(x,y); // end; procedure TText.setRegionPoints; var figMaxX,figMaxY,figMinX,figMinY: Double; a: integer; hl,vl: integer; FCanvas: TCanvas; r,xLen: Double; canvas: TMetaFileCanvas; MetaFile: TMetaFile; // Tolik 18/10/2019 -- HKoef: double; TxtH: Double; // begin if assigned(owner) then begin font.Size := Round(height/2 + 1); {MetaFile:= TMetaFile.Create; Metafile.Enhanced := True; canvas := TMetafileCanvas.Create(Metafile, 0); canvas.Font := font; canvas.Font.Height := Round(height); a := canvas.TextWidth(text); canvas.Free;} Fcanvas := TPCDrawing(Owner).DEngine.canvas; if HorzZero = 1 then hl := -1 else hl := 1; if VertZero = 1 then vl := -1 else vl := 1; if (TextLength = 0) or (TextHeight = 0) then begin //if Height < 1 then //begin // TextHeight := Height; // TextLength := Length(Text) * Height * 0.8; //end //else //begin TextHeight := Height; if Height < 1 then begin TextLength := Length(Text) * Height * 0.8; font.Size := Round(height/2 + 1); end else begin MetaFile:= TMetaFile.Create; Metafile.Enhanced := True; canvas := TMetafileCanvas.Create(Metafile, 0); //TxtH := Height/2; //HKoef := 0; {if TxtH < 1 then begin HKoef := 100; TxtH := TxtH*100; end;} canvas.Font := font; //canvas.Font.Height := Round(TxtH + 1); canvas.Font.Height := Round(height); TextLength := canvas.TextWidth(text); {if HKoef <> 0 then TextLength := (TextLength / HKoef) * 1.4;} canvas.Free; Metafile.free; end; end else if assigned(TPCDrawing(Owner).DEngine.ConvertLen) then begin xlen := 100; TPCDrawing(Owner).DEngine.ConvertLen(xLen); r := xlen / 100; TextLength := (TextLength / r); TextHeight := (TextHeight / r) end; figMaxX := ap1.x + hl*TextLength; figMaxY := ap1.y; figMinX := ap1.x; figMinY := ap1.y - vl*TextHeight ; actualpoints[1] := Doublepoint(FigMinX,FigMaxY); actualpoints[2] := RotatePoint(ap1,DoublePoint(FigMaxX,FigMaxY),Angle); actualpoints[3] := RotatePoint(ap1,DoublePoint(FigMaxX,FigMinY),Angle); actualpoints[4] := RotatePoint(ap1,DoublePoint(FigMinX,FigMinY),Angle); for a := 1 to 4 do originalpoints[a] := actualpoints[a]; RotPoint := (DoublePoint(-1000,-1000)); end; end; procedure TText.getbounds(var figMaxX,figMaxY,figMinX,figMinY: Double); var a : integer; begin figMaxX := actualpoints[1].x ; figMaxY := actualpoints[1].y ; figMinX := actualpoints[1].x ; figMinY := actualpoints[1].y ; for a := 1 to 4 do begin if actualpoints[a].x > FigMaxX then FigMaxX := actualpoints[a].x; if actualpoints[a].x < FigMinX then FigMinX := actualpoints[a].x; if actualpoints[a].y > FigMaxY then FigMaxy := actualpoints[a].y; if actualpoints[a].y < FigMiny then FigMinY := actualpoints[a].y; end; end; function TText.duplicate:TFigure; var res : TText; begin res := TText.create( originalpoints[1].x, originalpoints[1].y, height, CWidth, text, Font.Name, Font.Charset, Font.Color, LayerHandle, DrawStyle,Owner); res.actualpoints[1] := actualpoints[1]; res.actualpoints[2] := actualpoints[2]; res.originalpoints[2] := originalpoints[2]; res.actualpoints[3] := actualpoints[3]; res.originalpoints[3] := originalpoints[3]; res.actualpoints[4] := actualpoints[4]; res.originalpoints[4] := originalpoints[4]; res.angle := angle; res.Height := Height; res.CSpace := CSpace; res.Font.Style := Font.Style; res.rotPoint.x := rotPoint.x ; res.rotPoint.y := rotPoint.y ; res.Color := Color; res.AngleToPoint := AngleToPoint; result := res; end; Procedure TText.rotate(aAngle: Double; cPoint: TDoublePoint); begin inherited rotate(aAngle,cPoint); CalculateAngle; end; Procedure TText.calculateAngle; begin Angle := GetRadOfLine(ap1,ap2); end; procedure TText.scale(percentx,percenty: Double; rPoint: TDoublepoint); var wNew: Double; hNew: Double; wChar: Double; cnt: Integer; Cad: TPCDrawing; Scalex: double; begin {if BoxWidth <> -1 then begin BoxWidth := BoxWidth * percentx; percentx := BoxWidth/TextLength; BoxWidth := -1; end;} inherited scale(percentx,percenty,rPoint); if assigned(owner) then begin Cad := TPCDrawing(Owner); Cad.Dengine.TextToRect(ap1,ap2,ap3,ap4,Text,Font,CSpace,CWidth,Height); // Tolik 01/11/2017 -- // это оставлять нельзя, потому что на отрисовке по этому флажку // изменятся границы текста в размер самого текста (поскольку размер шрифта не может быть дробным числом, // при скейлинге текст может быть меньше границ -- не впритык) // потом теряется возможность отскейлить в обратную сторону, т.к. реальные границы текста будут утеряны !!! //Modified := True; // end; end; Function TText.ModifyTextAndFont(mm: TModifyMode; valueI:Double; valueS: string; valueSt: TFontStyles;ValueB:Boolean):Boolean; var TM : TTextMetric; Layer: TLayer; begin result := true; if mm = mmText then begin Text := valueS; modified := true; end else if mm = mmFontName then begin Font.Name := valueS; modified := true; end else if mm = mmFontCs then begin Font.Charset := Round(valueI); modified := true; end else if mm = mmFontSize then begin Height := valueI; modified := true; end else if mm = mmFontColor then begin Font.Color := Round(valueI); Color := Round(valueI); end else if mm = mmFontStyle then begin Font.Style := valueSt; modified := true; end else if mm = mmFontBold then begin if ValueB then Font.Style := Font.Style + [fsBold] else Font.Style := Font.Style - [fsBold]; modified := true; end else if mm = mmFontItalic then begin if ValueB then Font.Style := Font.Style + [fsItalic] else Font.Style := Font.Style - [fsItalic]; modified := true; end else if mm = mmFontUnderline then begin if ValueB then Font.Style := Font.Style + [fsUnderline] else Font.Style := Font.Style - [fsUnderline]; modified := true; end else if mm = mmFontStrike then begin if ValueB then Font.Style := Font.Style + [fsStrikeOut] else Font.Style := Font.Style - [fsStrikeOut]; modified := true; end; end; procedure TText.ValidatePoints; var cad: TPCDrawing; begin if assigned(owner) then begin Cad := TPCDrawing(Owner); end; end; Procedure TText.mirror(Point1,Point2: TDoublePoint); var cad: TPCDrawing; begin //inherited mirror(Point1,Point2); //if angle <> 0 then CalculateAngle; //ValidatePoints; //if assigned(owner) then begin // Cad := TPCDrawing(Owner); // Cad.Dengine.TextToRect(ap1,ap2,ap3,ap4,Text,Font,CSpace,CWidth,Height); // Modified := True; //end; end; Destructor TText.destroy; begin //deleteobject(font.handle); Font.Free; inherited; end; procedure TText.MenuClicked(CommandId: integer); var idx: integer; begin idx := commandID-menuIndex; case idx of 0: begin CWidth := 0; fKeepA := True; end; 1: CSpace := 0; 2: Outlined := not outlined; end; Modified := True; end; procedure TText.UpdateMenu(var popMenu: TPopUpMenu; var sIndex: Integer); var mnItem,mnSub: TMenuItem; begin menuIndex:= sIndex; mnItem := TMenuItem.Create(PopMenu); mnItem.Tag := sIndex; mnItem.Caption := fmAspectRatio; PopMenu.Items.Add(mnItem); mnItem := TMenuItem.Create(PopMenu); mnItem.Tag := sIndex; mnItem.Tag := sIndex+1; mnItem.Caption := fmDefaultSpacing; PopMenu.Items.Add(mnItem); mnItem := TMenuItem.Create(PopMenu); mnItem.Tag := sIndex; mnItem.Tag := sIndex+2; mnItem.Caption :=fmOutlined; mnItem.Checked := Outlined; PopMenu.Items.Add(mnItem); sIndex := sIndex+3; end; /////////////////////////////////////////////////////////////////////////////// procedure TPlSegment.CopyFrom(frSeg: TPLSegment); begin Index := frSeg.Index; Stype := frSeg.Stype; CPoint1 := frSeg.CPoint1; CPoint2 := frSeg.CPoint2; TangentKnot := frSeg.TangentKnot; Inverted:= frSeg.Inverted; tp1 := frSeg.tp1; tp2 := frSeg.tp2; end; { TFigureGrp } procedure TFigureGrp.AddFigure(fig: TFigure; AResetReg: Boolean=true); begin AddToGrp(fig); //28.04.2011 InFigures.Add(fig); BoundCalc := False; if AResetReg then //02.04.2012 ResetRegion; // Tolik -- 27/06/2017 -- if Self.ClassName = TFigureGrpMod.ClassName then HasAutocreatedFigures := CheckHasAutocreatedFigures(TFigure(Self)); // end; // Tolik 22/08/2017 -- procedure TFigureGrp.InsertFigure(fig: TFigure; AResetReg: Boolean=true); begin InsertFig(fig); //28.04.2011 InFigures.Add(fig); BoundCalc := False; if AResetReg then //02.04.2012 ResetRegion; end; // procedure TFigureGrp.ClearFigureList; begin InFigures.Clear; // Tolik -- 27/06/2017 -- HasAutocreatedFigures := False; BoundCalc := False; // ResetRegion; end; constructor TFigureGrp.create(LHandle: LongInt;aOwner: TComponent); begin inherited create(LHandle,mydsNormal,aOwner); initialize; end; procedure TFigureGrp.Initialize; begin inherited; DimLocked := False; pointcount := 4; inFigures := TList.Create; Changed := False; bDeltaX := 0; bDeltaY := 0; FCombined := false; Reloading := false; LoadIdx := 0; Ungrouped := False; Style := ord(psSolid); Width := 1; Color := clBlack; brc := clWhite; brs := ord(bsSolid); AlwaysTogether := False; FMetaFile := nil; UseMetafile := False; BoundCalc := False; DrawRatio := 1; //Tolik HasAutocreatedFigures := False; // end; Procedure TFigureGrp.DestroyInFigures; var a: Integer; Figure: TFigure; begin try Figure := nil; //Tolik if Assigned(inFigures) then if inFigures.Count > 0 then begin for a := 0 to inFigures.Count - 1 do begin Figure := TFigure(inFigures[a]); if Figure is tFigureGrp then TFigureGrp(Figure).DestroyInFigures; FreeAndNil(Figure); end; InFigures.Clear; end; except //on E: Exception do AddExceptionToLog(CPowerCadMessage + 'TFigureGrp.DestroyInFigures' + E.Message); end; // Tolik -- 27/06/2017 -- HasAutocreatedFigures := False; BoundCalc := False; // end; Destructor TFigureGrp.Destroy; begin DestroyInFigures; if assigned(FMetaFile) then FMetafile.Free; InFigures.Free; ID := -1; inherited; end; function TFigureGrp.CreateModification: TFigure; var r: TDoubleRect; res: TRectangle; begin res := TRectangle.create(0,0,0,0,1,1,clLime,0,0,0,dsTrace,nil); r := GetBoundRect; res.actualpoints[1] := DoublePoint(r.left,r.top); res.actualpoints[2] := DoublePoint(r.right,r.top); res.actualpoints[3] := DoublePoint(r.right,r.bottom); res.actualpoints[4] := DoublePoint(r.left,r.bottom); Res.DiagonalScale := DiagonalScale; res.RotPoint := RotPoint; result := res; end; function TFigureGrp.EndModification(CadControl: Pointer;mp: TModPoint; TraceFigure: TFigure; x, y: double;Shift: TShiftState): boolean; var distx,disty: double; GRect: TDoubleRect; ap: TDoublepoint; begin ap := DoublePoint(mp.coordx,mp.coordy); GRect := mp.Figure.GetBoundRect; distx := 0; distY := 0; If mp.SeqNbr in [3,4,5] then begin x := TraceFigure.ap2.x; distX := x - GRect.Right; ap.x := GRect.Left; end else if mp.SeqNbr in [1,8,7] then begin x := TraceFigure.ap1.x; distX := GRect.Left-x; ap.x := GRect.Right; end; If mp.SeqNbr in [1,2,3] then begin y := TraceFigure.ap1.y; distY := y - GRect.Top; ap.y := GRect.Bottom; end else if mp.SeqNbr in [5,6,7] then begin y := TraceFigure.ap3.y; distY := GRect.Bottom - y; ap.y := GRect.Top; end; if (distX <> 0) and (distY <> 0) then scale(1 + distx / (GRect.Right - Grect.Left), 1 + disty / (GRect.Top - Grect.Bottom), ap) else if distX = 0 then scale(1, 1 + disty / (GRect.Top - Grect.Bottom), ap) else if distY = 0 then scale(1 + distx / (GRect.Right - Grect.Left), 1, ap); ResetRegion; end; function TFigureGrp.TraceModification(CadControl: Pointer;mp: TModPoint;TraceFigure:TFigure; x,y: double;Shift: TShiftState): boolean; var GRect: TDoubleRect; begin TraceFigure.TraceModification(CadControl,mp,TraceFigure,x,y,Shift); exit; GRect := GetBoundRect; If MP.SeqNbr in [3,4,5] then begin TraceFigure.ActualPoints[2] := DoublePoint(x,TraceFigure.ActualPoints[2].y); TraceFigure.ActualPoints[3] := DoublePoint(x,TraceFigure.ActualPoints[3].y); end else if MP.SeqNbr in [1,8,7] then begin TraceFigure.ActualPoints[1] := DoublePoint(x,TraceFigure.ActualPoints[1].y); TraceFigure.ActualPoints[4] := DoublePoint(x,TraceFigure.ActualPoints[4].y); end; If mp.SeqNbr in [1,2,3] then begin TraceFigure.ActualPoints[1] := DoublePoint(TraceFigure.ActualPoints[1].x,y); TraceFigure.ActualPoints[2] := DoublePoint(TraceFigure.ActualPoints[2].x,y); end else if mp.SeqNbr in [5,6,7] then begin TraceFigure.ActualPoints[3] := DoublePoint(TraceFigure.ActualPoints[3].x,y); TraceFigure.ActualPoints[4] := DoublePoint(TraceFigure.ActualPoints[4].x,y); end; end; procedure TFigureGrp.draw(DEngine: TPCDrawEngine;isGrayed:Boolean); var a: integer; Figure: TFigure; Layer: Tlayer; isDraw:Boolean; f: Tfigure; dx,dy,dz: DOuble; var figMaxX, figMaxY, figMinX,figMinY,cx,cy: double; xbrs: Integer; xRgn: HRGN; begin //31.10.2011 GetBounds(figMaxX, figMaxY, figMinX, figMinY); if DrawRatio <> 1 then begin GetBounds(figMaxX, figMaxY, figMinX, figMinY); //31.10.2011 cx := (figMaxX + figMinX) / 2; cy := (figMaxY + figMinY) / 2; cx := cx / 2; cy := cy / 2; Dengine.ConvertDim(cx); Dengine.ConvertDim(cy); ConvertRatio := DrawRatio; ConvertDx := cx; ConvertDy := cy; end; if mirrored then begin dx := (ap1.x + ap2.x) / 2; dy := ap1.y; dz := 0; Dengine.ConvertCoord(dx,dy,dz); FlipCanvas(Dengine.Canvas.Handle,fmHorz,2*dx); end; SetOwnerProps; if Combined and (RegHandle = 0) then begin DrawInFigures(Dengine,isGrayed); Beginpath(Dengine.Canvas.Handle); DrawInFigures(Dengine,isGrayed); EndPath(Dengine.Canvas.Handle); RegHandle := PathToRegion(Dengine.Canvas.Handle); end; DrawFill(Dengine,isGrayed); DrawClipFigures(Dengine,isGrayed); if combined then Beginpath(Dengine.Canvas.Handle); DrawInFigures(Dengine,isGrayed); if combined then EndPath(Dengine.Canvas.Handle); if combined then begin DEngine.Canvas.Pen.Style := TPenStyle(Style); DEngine.Canvas.Pen.Color := (Color); DEngine.Canvas.Pen.Width := (Width); DEngine.Canvas.Brush.Style := TbrushStyle(Brs); DEngine.Canvas.Brush.Color := (Brc); SetPolyfillMode(Dengine.Canvas.Handle,ALTERNATE); //if brs = ord(bsSolid) then //StrokeAndFillPath(Dengine.Canvas.Handle) //else StrokePath(Dengine.Canvas.Handle); end; if mirrored then begin ResetCanvas(Dengine.Canvas.Handle); end; ConvertRatio := 1; ConvertDx := 0; ConvertDy := 0; //Tolik if RegHandle <> 0 then begin GetRegObject; if TBrushStyle(brs) <> bsClear then RegObject.CheckPointByRects := true; deleteObject(RegHandle); RegHandle := 0; end; // end; function TFigureGrp.duplicate:TFigure; var res: TFigureGrp; a : integer; begin res := TFigureGrp.create(LayerHandle,Owner); for a := 0 to inFigures.Count - 1 do begin res.AddFigure(TFigure(InFigures[a]).duplicate); end; res.changed := changed; res.AngleToPoint := AngleToPoint; res.bDeltaX := bDeltaX; res.bDeltaY := bDeltaY; res.Combined := combined; res.CreateMetaFile; result := res; end; function TFigureGrp.DuplicateAsBezier: TFigure; var res: TFigureGrp; a : integer; begin res := TFigureGrp.create(LayerHandle,Owner); for a := 0 to inFigures.Count - 1 do begin res.AddFigure(TFigure(InFigures[a]).duplicateAsBezier); end; res.changed := changed; res.AngleToPoint := AngleToPoint; res.bDeltaX := bDeltaX; res.bDeltaY := bDeltaY; res.Combined := combined; res.CreateMetaFile; result := res; end; procedure TFigureGrp.getbounds(var figMaxX, figMaxY, figMinX, figMinY: double); var mx,my,ax,ay: Double; a: integer; rect: TDoubleRect; xp: TDoublePoint; p1,p2: TDoublePoint; ap: TDoublePoint; begin if (not DimLocked) and ((not BoundCalc) or (Infigures.Count < 5)) then begin getInbounds(figMaxX,figMaxY,figMinX,figMinY); rect := DoubleRect(figMinX,figMinY,figMaxX,FigMaxY); pointcount := 4; ActualPoints[1] := DoublePoint(rect.Left,rect.Top); ActualPoints[2] := DoublePoint(rect.Right,rect.Top); ActualPoints[3] := DoublePoint(rect.Right,rect.Bottom); ActualPoints[4] := DoublePoint(rect.Left,rect.Bottom); BoundCalc := True; end else begin figMaxX := ap1.x; figMinX := ap1.x; figMaxY := ap1.y; figMinY := ap1.y; For a := 1 to 4 do begin {//31.10.2011 if actualpoints[a].x > figMaxX then figMaxX := actualpoints[a].x; if actualpoints[a].x < figMinX then figMinX := actualpoints[a].x; if actualpoints[a].y > figMaxY then figMaxY := actualpoints[a].y; if actualpoints[a].y < figMinY then figMinY := actualpoints[a].y;} ap := actualpoints[a]; if ap.x > figMaxX then figMaxX := ap.x; if ap.x < figMinX then figMinX := ap.x; if ap.y > figMaxY then figMaxY := ap.y; if ap.y < figMinY then figMinY := ap.y; end; end; if drawRatio <> 1 then begin xp.x := (figMaxX+figMinX)/2; xp.y := (figMaxY+figMinY)/2; p1 := DoublePoint(figMinx,figMinY); p2 := DoublePoint(figMaxX,figMaxY); p1 := ScalePoint(xp,p1,DrawRatio,DrawRatio); p2 := ScalePoint(xp,p2,DrawRatio,DrawRatio); figMinX := p1.x; figMinY := p1.y; figMaxX := p2.x; figMaxY := p2.y; end; end; // Tolik 29/06/2017 -- procedure TFigureGrp.GetINBoundsWithoutAutoCreatedFigures(var figMaxX,figMaxY,figMinX,figMinY: double); var mx,my,ax,ay: Double; a,i: integer; isFirst: boolean; c_name: string; begin c_name := Self.ClassName; c_name := LowerCase(c_name); if (c_name = 'tfiguregrpmod') or (c_name = 'tfiguregrpnotmod') or (c_name = 'tfiguregrp') then begin if self is TFigureGrpMod then begin figMaxX := 0; figMaxY := 0; figMinX := 0; figMinY := 0; // isFirst := True; for a := 0 to inFigures.Count - 1 do begin //Tolik -- 08/06/2017 -- if TFigure(InFigures[a]).isAutoCreatedFigure = biFalse then begin if not (TFigure(InFigures[a]) is TArcDimLine) then begin if isFirst then begin TFigure(InFigures[a]).getBounds(figMaxX, figMaxY, figMinX, figMinY); isFirst := False; // Tolik -- 08/11/2016-- иначе рискуем потерять минимальные границы !!!!! mx := figMaxX; my := figMaxY; ax := figMinX; ay := figMinY; // end else begin mx := figMaxX; my := figMaxY; ax := figMinX; ay := figMinY; TFigure(InFigures[a]).getBounds(mx,my,ax,ay); end; if a > 0 then begin if mx > figMaxX then figMaxX := mx; if ax < figMinX then figMinX := ax; if my > figMaxY then figMaxY := my; if ay < figMinY then figMinY := ay; end; end else begin if isFirst then begin // Tolik 09/11/2016-- -- если объект будет состоять только из объектов типа АРКА, // то опять потеряем байнды нах....то есть, нужно так: figMaxX := TFigure(InFigures[a]).ActualPoints[1].x; figMaxY := TFigure(InFigures[a]).ActualPoints[1].y; figMinX := TFigure(InFigures[a]).ActualPoints[1].x; figMinY := TFigure(InFigures[a]).ActualPoints[1].y; end; figMinY := figMinY; end; end; end; end else begin figMaxX := 0; figMaxY := 0; figMinX := 0; figMinY := 0; // i := 0; for a := 0 to inFigures.Count - 1 do begin // Tolik -- 08/06/2017 -- if TFigure(InFigures[a]).isAutoCreatedFigure = biFalse then begin {if a = 0 then TFigure(InFigures[a]).getBounds(figMaxX, figMaxY, figMinX, figMinY)} if i = 0 then begin TFigure(InFigures[a]).getBounds(figMaxX, figMaxY, figMinX, figMinY); inc(i); end else begin mx := figMaxX; my := figMaxY; ax := figMinX; ay := figMinY; TFigure(InFigures[a]).getBounds(mx,my,ax,ay); end; if a > 0 then begin if mx > figMaxX then figMaxX := mx; if ax < figMinX then figMinX := ax; if my > figMaxY then figMaxY := my; if ay < figMinY then figMinY := ay; end; end; end; end; end else getInbounds(figMaxX,figMaxY,figMinX,figMinY); end; procedure TFigureGrp.GetBoundsWithAutoCreatedFigures(var figMaxX,figMaxY,figMinX,figMinY: double); var mx,my,ax,ay: Double; a,i: integer; isFirst: boolean; c_name: string; begin c_name := Self.ClassName; c_name := LowerCase(c_name); if (c_name = 'tfiguregrpmod') or (c_name = 'tfiguregrpnotmod') or (c_name = 'tfiguregrp') then begin if self is TFigureGrpMod then begin figMaxX := 0; figMaxY := 0; figMinX := 0; figMinY := 0; // isFirst := True; for a := 0 to inFigures.Count - 1 do begin //Tolik -- 08/06/2017 -- //if TFigure(InFigures[a]).isAutoCreatedFigure = biFalse then begin if not (TFigure(InFigures[a]) is TArcDimLine) then begin if isFirst then begin TFigure(InFigures[a]).getBounds(figMaxX, figMaxY, figMinX, figMinY); isFirst := False; // Tolik -- 08/11/2016-- иначе рискуем потерять минимальные границы !!!!! mx := figMaxX; my := figMaxY; ax := figMinX; ay := figMinY; // end else begin mx := figMaxX; my := figMaxY; ax := figMinX; ay := figMinY; TFigure(InFigures[a]).getBounds(mx,my,ax,ay); end; if a > 0 then begin if mx > figMaxX then figMaxX := mx; if ax < figMinX then figMinX := ax; if my > figMaxY then figMaxY := my; if ay < figMinY then figMinY := ay; end; end else begin if isFirst then begin // Tolik 09/11/2016-- -- если объект будет состоять только из объектов типа АРКА, // то опять потеряем байнды нах....то есть, нужно так: figMaxX := TFigure(InFigures[a]).ActualPoints[1].x; figMaxY := TFigure(InFigures[a]).ActualPoints[1].y; figMinX := TFigure(InFigures[a]).ActualPoints[1].x; figMinY := TFigure(InFigures[a]).ActualPoints[1].y; end; figMinY := figMinY; end; end; end; end else begin figMaxX := 0; figMaxY := 0; figMinX := 0; figMinY := 0; // i := 0; for a := 0 to inFigures.Count - 1 do begin // Tolik -- 08/06/2017 -- //if TFigure(InFigures[a]).isAutoCreatedFigure = biFalse then begin {if a = 0 then TFigure(InFigures[a]).getBounds(figMaxX, figMaxY, figMinX, figMinY)} if i = 0 then begin TFigure(InFigures[a]).getBounds(figMaxX, figMaxY, figMinX, figMinY); inc(i); end else begin mx := figMaxX; my := figMaxY; ax := figMinX; ay := figMinY; TFigure(InFigures[a]).getBounds(mx,my,ax,ay); end; if a > 0 then begin if mx > figMaxX then figMaxX := mx; if ax < figMinX then figMinX := ax; if my > figMaxY then figMaxY := my; if ay < figMinY then figMinY := ay; end; end; end; end; end else getbounds(figMaxX,figMaxY,figMinX,figMinY); end; procedure TFigureGrp.GetBoundsWithoutAutoCreatedFigures(var figMaxX,figMaxY,figMinX,figMinY: double); var mx,my,ax,ay: Double; a: integer; rect: TDoubleRect; xp: TDoublePoint; p1,p2: TDoublePoint; ap: TDoublePoint; c_name: string; begin c_name := Self.ClassName; c_name := LowerCase(c_name); if (c_name = 'tfiguregrpmod') or (c_name = 'tfiguregrpnotmod') or (c_name = 'tfiguregrp') then begin if (not DimLocked) and ((not BoundCalc) or (Infigures.Count < 5)) then begin GetINBoundsWithoutAutoCreatedFigures(figMaxX,figMaxY,figMinX,figMinY); rect := DoubleRect(figMinX,figMinY,figMaxX,FigMaxY); pointcount := 4; ActualPoints[1] := DoublePoint(rect.Left,rect.Top); ActualPoints[2] := DoublePoint(rect.Right,rect.Top); ActualPoints[3] := DoublePoint(rect.Right,rect.Bottom); ActualPoints[4] := DoublePoint(rect.Left,rect.Bottom); BoundCalc := True; end else begin figMaxX := ap1.x; figMinX := ap1.x; figMaxY := ap1.y; figMinY := ap1.y; For a := 1 to 4 do begin {//31.10.2011 if actualpoints[a].x > figMaxX then figMaxX := actualpoints[a].x; if actualpoints[a].x < figMinX then figMinX := actualpoints[a].x; if actualpoints[a].y > figMaxY then figMaxY := actualpoints[a].y; if actualpoints[a].y < figMinY then figMinY := actualpoints[a].y;} ap := actualpoints[a]; if ap.x > figMaxX then figMaxX := ap.x; if ap.x < figMinX then figMinX := ap.x; if ap.y > figMaxY then figMaxY := ap.y; if ap.y < figMinY then figMinY := ap.y; end; end; if drawRatio <> 1 then begin xp.x := (figMaxX+figMinX)/2; xp.y := (figMaxY+figMinY)/2; p1 := DoublePoint(figMinx,figMinY); p2 := DoublePoint(figMaxX,figMaxY); p1 := ScalePoint(xp,p1,DrawRatio,DrawRatio); p2 := ScalePoint(xp,p2,DrawRatio,DrawRatio); figMinX := p1.x; figMinY := p1.y; figMaxX := p2.x; figMaxY := p2.y; end; end else getbounds(figMaxX,figMaxY,figMinX,figMinY); end; procedure TFigureGrp.getModPoints(ModList: TMyList); var figMaxX, figMaxY, figMinX,figMinY: double; CControl:TPCDrawing; p1,p2,p3,p4,MT,MR,MB,ML : TDoublePoint; begin CControl := TPCdrawing(Owner); getbounds(figMaxX,figMaxY,figMinX,figMinY); p1 := DoublePoint(figMinX,figMinY); p2 := DoublePoint(figMaxX,figMinY); p3 := DoublePoint(figMaxX,figMaxY); p4 := DoublePoint(figMinX,figMaxY); MT := Mpoint(p1,p2); MR := Mpoint(p2,p3); MB := Mpoint(p3,p4); ML := Mpoint(p4,p1); ModList.Add(CControl.RegisterModPoint(self,ptGroupPoint,ptRect,clRed,PointDim,p1.x,p1.y,1)); ModList.Add(CControl.RegisterModPoint(self,ptGroupPoint,ptRect,clRed,PointDim,MT.x,MT.y,2)); ModList.Add(CControl.RegisterModPoint(self,ptGroupPoint,ptRect,clRed,PointDim,p2.x,p2.y,3)); ModList.Add(CControl.RegisterModPoint(self,ptGroupPoint,ptRect,clRed,PointDim,MR.x,MR.y,4)); ModList.Add(CControl.RegisterModPoint(self,ptGroupPoint,ptRect,clRed,PointDim,p3.x,p3.y,5)); ModList.Add(CControl.RegisterModPoint(self,ptGroupPoint,ptRect,clRed,PointDim,MB.x,MB.y,6)); ModList.Add(CControl.RegisterModPoint(self,ptGroupPoint,ptRect,clRed,PointDim,p4.x,p4.y,7)); ModList.Add(CControl.RegisterModPoint(self,ptGroupPoint,ptRect,clRed,PointDim,ML.x,ML.y,8)); ActualPoints[1] := p1; ActualPoints[2] := p2; ActualPoints[3] := p3; ActualPoints[4] := p4; end; procedure TFigureGrp.WriteToStream(Stream: TStream); var a,xSize,xInt: integer; xCode,xByte: Byte; figure: TFigure; xStream : TMemoryStream; begin inherited; xInt:= inFigures.Count; xCode := 20; WriteField(xCode, Stream, xInt, 4); if combined then begin xByte := 1; xCode := 90; WriteField(xCode,Stream,xByte,1); end; // Tolik 13/10/2017 -- записать флаг наличия автосозданных фигур xByte := byte(HasAutocreatedFigures); xCode := 91; WriteField(xCode,Stream,xByte,1); // for a := 0 to inFigures.Count - 1 do begin xStream := TMemoryStream.Create; Figure := TFigure(InFigures[a]); Figure.WriteToStream(xStream); xSize := xStream.Size; xStream.Position := 0; xCode := 150; Stream.Write(xCode,1); Stream.Write(xSize,4); StreamToStream(xStream,Stream,xSize); xStream.Free; end; end; procedure TFigureGrp.SetPropertyFromStream(xCode: Byte; data: pointer; size: integer); var mstr:TMemoryStream; Figure: Tfigure; begin Case xcode of 90: Combined := (pByte(data)^ = 1); 150: begin mStr := TMemoryStream.Create; mStr.Write(pByte(data)^,size); mStr.Position := 0; if reloading then begin Figure := TFigure(InFigures[LoadIdx]); ReadStringFromStream(mStr); Figure.SetPropertiesFromStream(mStr); LoadIdx := LoadIdx + 1; Figure.InCombined := Combined; end else begin Figure := TFigure.CreateFromStream(mStr, LayerHandle, DrawStyle, Owner); AddToGrp(Figure); //28.04.2011 InFigures.Add(Figure); Figure.InCombined := Combined; end; mStr.Free; end; // Tolik 13/10/2017 -- записать флаг наличия автосозданных фигур 91: HasAutocreatedFigures := Boolean(pByte(data)^); // end; end; function TFigureGrp.isPointIn(x, y: double): boolean; var a: integer; begin result := false; result := inherited isPointIn(x,y); if result then exit; if combined then begin result := IsPointInRegion(x,y); //Tolik result := IsPointInRegionByRegObj(x,y); // end else begin for a := 0 to inFigures.Count - 1 do begin // Tolik -- 08/06/2017 if TFigure(InFigures[a]).isAutoCreatedFigure = biFalse then begin // result := TFigure(InFigures[a]).ispointin(x,y); if result then exit; end; end; end; end; procedure TFigureGrp.mirror(Point1, Point2: TDoublePoint); var a: integer; begin inherited; for a := 0 to inFigures.Count - 1 do begin TFigure(InFigures[a]).mirror(Point1, Point2); end; Changed := True; CreateMetafile; ResetRegion; end; procedure TFigureGrp.ModifySelection(mm: TModifyMode; value: Integer); var a: integer; begin inherited; for a := 0 to inFigures.Count - 1 do begin TFigure(InFigures[a]).ModifySelection(mm,value); end; Changed := True; ResetRegion; end; Function TFigureGrp.ModifyTextAndFont(mm: TModifyMode; valueI: Double; valueS: string; valueSt: TFontStyles;valueB:Boolean):Boolean; var a: integer; begin result := false; for a := 0 to inFigures.Count - 1 do begin if TFigure(InFigures[a]).ModifyTextAndFont(mm,valueI,valueS,ValueSt,ValueB) then result := True; end; Changed := True; ResetRegion; end; procedure TFigureGrp.move(deltax, deltay:Double); var a: integer; begin inherited; for a := 0 to inFigures.Count - 1 do begin TFigure(InFigures[a]).move(deltax, deltay); end; BDeltax := BDeltax + deltax; BDeltay := BDeltay + deltay; ResetRegion; end; procedure TFigureGrp.rotate(aAngle: Double; cPoint: TDoublePoint); var a: integer; fig: TFigure; Cad: TPCDrawing; Arc: TElpArc; pd1: TDoublePoint; ElpArc: TElpArc; ElpPoly: TPolyline; begin inherited; AngletoPoint := AngleToPoint + aAngle; for a := 0 to inFigures.Count - 1 do begin fig := TFigure(inFigures[a]); if (fig is TElpArc) then begin Cad := TPCdrawing(owner); Cad.ClearUndoList; Arc := TElpArc(fig); ElpPoly := TPolyline(Arc.DuplicateAsBezier); InFigures[a] := ElpPoly; Arc.Destroy; TFigure(InFigures[a]).rotate(aAngle,cPoint); end else begin TFigure(InFigures[a]).rotate(aAngle,cPoint); end; end; Changed := True; CreateMetafile; ResetRegion; end; procedure TFigureGrp.scale(percentx, percenty: double; rPoint: TDoublepoint); var a: integer; fig: TFigure; Cad: TPCDrawing; elp: TEllipse; ElpArc: TElpArc; Arc: TArc; begin //27.05.2011 - Before scale events for a := 0 to inFigures.Count - 1 do begin fig := TFigure(InFigures[a]); if Assigned(fig.FBeforeAllScale) then fig.FBeforeAllScale(fig); end; // Tolik 02/05/2019 - - { for a := 0 to inFigures.Count - 1 do begin fig := TFigure(InFigures[a]); if FloatToStr(fig.Ap1.z) = 'NAN' then ShowMessage(fig.CName + ' is Broken Here!!! '); end; } // inherited; try for a := 0 to inFigures.Count - 1 do begin fig := TFigure(InFigures[a]); if (fig is TCircle) and (percentx <> percenty) and assigned(owner) then begin Cad := TPCdrawing(owner); Cad.ClearUndoList; elp := TEllipse.create(fig.ap1.x, fig.ap1.y, fig.radius, fig.radius, 0, fig.Width, fig.Style, fig.Color, fig.brs, fig.brc, fig.LayerHandle, mydsNormal, fig.Owner); elp.Scale(percentx, percenty, rPoint); InFigures[a] := elp; fig.Destroy; end else if (fig is TArc) and (not (fig is TArcDimLine)) and (percentx <> percenty) and assigned(owner) then begin // ElpPoly := TPolyline(Arc.DuplicateAsBezier); // InFigures[a] := ElpPoly; // Arc.Destroy; // TFigure(InFigures[a]).rotate(aAngle,cPoint); Cad := TPCdrawing(owner); Cad.ClearUndoList; Arc := TArc(fig); ElpArc := TElpArc.create(arc.ap1.x, arc.ap1.y, arc.Radius, arc.Radius, arc.SAngle, arc.FAngle, arc.Angle, fig.Width, fig.Style, fig.Color, fig.brs, fig.brc, ord(asOpen), fig.LayerHandle, mydsNormal, fig.Owner); ElpArc.draw(GCadForm.PCad.DEngine, False); ElpArc.Scale(percentx, percenty, rPoint); InFigures[a] := ElpArc; fig.Destroy; end else TFigure(InFigures[a]).scale(percentx, percenty, rPoint); end; except // on E: Exception do AddExceptionToLog(CPowerCadMessage + 'TFigureGrp.scale' + E.Message); on E:Exception do ShowMessage('a = ' + inttostr(a)); end; Changed := True; // Tolik 02/05/2019 - - for a := 0 to inFigures.Count - 1 do begin fig := TFigure(InFigures[a]); if FloatToStr(fig.Ap1.z) = 'NAN' then ShowMessage(fig.CName + ' is Broken Here!!! '); end; // //23.09.2011 - After Scaling And Before Other Events FAfterScalingBeforeEvents //for a := 0 to inFigures.Count - 1 do //begin // fig := TFigure(InFigures[a]); // if Assigned(fig.FAfterScalingBeforeEvents) then // fig.FAfterScalingBeforeEvents(fig); //end; //27.05.2011 - Sale events for a := 0 to inFigures.Count - 1 do begin fig := TFigure(InFigures[a]); if Assigned(fig.FScaleAllEvent) then fig.FScaleAllEvent(fig); end; // Tolik 02/05/2019 - - for a := 0 to inFigures.Count - 1 do begin fig := TFigure(InFigures[a]); if FloatToStr(fig.Ap1.z) = 'NAN' then ShowMessage(fig.CName + ' is Broken Here!!! '); end; // //27.05.2011 - After scale events for a := 0 to inFigures.Count - 1 do begin fig := TFigure(InFigures[a]); if Assigned(fig.FAfterAllScale) then fig.FAfterAllScale(fig); end; // Tolik 02/05/2019 - - for a := 0 to inFigures.Count - 1 do begin fig := TFigure(InFigures[a]); if FloatToStr(fig.Ap1.z) = 'NAN' then ShowMessage(fig.CName + ' is Broken Here!!! '); end; // CreateMetafile; // Tolik 02/05/2019 - - for a := 0 to inFigures.Count - 1 do begin fig := TFigure(InFigures[a]); if FloatToStr(fig.Ap1.z) = 'NAN' then ShowMessage(fig.CName + ' is Broken Here!!! '); end; // ResetRegion; end; // Tolik -- 27/06/2017 -- function TFigureGrp.CheckHasAutocreatedFigures(aFigure: TFigure): Boolean; var i: integer; c_name: string; begin result := False; c_name := Self.ClassName; c_name := LowerCase(c_name); //if (c_name = 'tfiguregrpmod') or (c_name = 'tfiguregrpnotmod') or (c_name = 'tfiguregrp') then if (c_name = 'tfiguregrpmod') then begin if assigned(self.owner) and assigned(TPowerCad(self.owner).OnObjectInserted) then begin for i := 0 to TFigureGrp(aFigure).InFigures.Count - 1 do begin // if TFigure(TFigureGrp(aFigure).InFigures[i]) is TFigureGrp then if TFigure(TFigureGrp(aFigure).InFigures[i]).ClassName = TFigureGrpMod.ClassName then Result := CheckHasAutocreatedFigures(TFigure(TFigureGrp(aFigure).InFigures[i])) else Result := (TFigure(TFigureGrp(aFigure).InFigures[i]).isAutoCreatedFigure = biTrue); end; if result then exit; end else begin result := HasAutocreatedFigures; end; end; end; function TFigureGrp.InsertFig(aFigure: TFigure): Integer; begin Result := 0; InFigures.Insert(0, AFigure); AFigure.Parent := Self; // Tolik 27/06/2017 if Self.ClassName = TFigureGrpMod.ClassName then HasAutocreatedFigures := CheckHasAutocreatedFigures(TFigure(Self)); // end; // function TFigureGrp.AddToGrp(AFigure: TFigure): Integer; begin Result := InFigures.Add(AFigure); AFigure.Parent := Self; // Tolik 27/06/2017 if Self.ClassName = 'TFigureGrpMod' then HasAutocreatedFigures := CheckHasAutocreatedFigures(TFigure(Self)); // end; function TFigureGrp.GetBoundRectWithoutAutoCreatedFigures: TDoubleRect; var figMaxX,figMaxY,figMinX,figMinY: Double; c_name: string; begin c_name := Self.ClassName; c_name := LowerCase(c_name); if (c_name = 'tfiguregrpmod') or (c_name = 'tfiguregrpnotmod') or (c_name = 'tfiguregrp') then begin GetBoundsWithoutAutoCreatedFigures(figMaxX,figMaxY,figMinX,figMinY); //result := Rect(figMinX,figMaxY,figMaxX,FigMinY); result := DoubleRect(figMinX,figMinY,figMaxX,FigMaxY); end else result := GetBoundRect; end; function TFigureGrp.RemoveFromGrp(AFigure: TFigure): Integer; begin while InFigures.IndexOf(AFigure) <> -1 do begin AFigure.Parent := nil; Result := InFigures.Remove(AFigure); end; // Tolik 27/06/2017 -- if Self.ClassName = TFigureGrpMod.ClassName then HasAutocreatedFigures := CheckHasAutocreatedFigures(TFigure(Self)); BoundCalc := False; // end; procedure TFigureGrp.UnGroup; var a: integer; CControl: TPCDrawing; fig: TFigure; begin if AlwaysTogether then exit; Combined := False; Deselect; CControl := TPCdrawing(Owner); try for a := 0 to inFigures.Count - 1 do begin //30.05.2011 TFigure(InFigures[a]).select; //30.05.2011 CControl.Figures.add(TFigure(InFigures[a])); fig := TFigure(InFigures[a]); fig.select; fig.Parent := nil; //30.05.2011 CControl.Figures.add(fig); end; except // on E: Exception do AddExceptionToLog(CPowerCadMessage + 'TFigureGrp.UnGroup' + E.Message); end; UnGrouped := true; // Tolik -- 27/06/2017 -- if Self.ClassName = TFigureGrpMod.ClassName then HasAutocreatedFigures := CheckHasAutocreatedFigures(TFigure(Self)); // ResetRegion; end; Procedure TFigureGrp.SetReload(Value:Boolean); var f: TFigure; i: Integer; begin Freload := Value; LoadIdx := 0; For i := 0 to Infigures.Count -1 do begin f := Tfigure(Infigures[i]); if f is TFigureGrp then TFigureGrp(f).Reloading := Value; end; end; function TFigureGrp.Rename: string; var a: integer; begin inherited Rename; if assigned(inFigures) then begin for a := 0 to inFigures.Count - 1 do begin TFigure(InFigures[a]).Rename; end; end; end; function TFigureGrp.CountBlock(BlockName: String): integer; var f:TFigure; fg: TfigureGrp; a,cnt,i: integer; begin cnt := 0; for a := 0 to InFigures.Count-1 do begin f := TFigure(InFigures[a]); if f is TBlock then begin if TBlock(f).BlockName = BlockName then cnt := cnt +1; end else if f is TFigureGrp then begin fg := TFigureGrp(f); cnt := cnt + fg.CountBlock(BlockName); end; end; result := cnt; end; procedure TFigureGrp.MenuClicked(CommandId: integer); var idx: integer; CadControl: TPCDrawing; begin idx := commandID-menuIndex; case idx of 0: Combined := not Combined; 1: begin if assigned(owner) then begin CadControl := TPCDrawing(Owner); CadControl.Figures.Remove(Self); end; Ungroup; end; 2: DiagonalScale := not DiagonalScale; end; end; procedure TFigureGrp.UpdateMenu(var popMenu: TPopUpMenu; var sIndex: Integer); var mnItem: TMenuItem; begin menuIndex := sIndex; mnItem := TMenuItem.Create(PopMenu); mnItem.Caption := fmCombined; mnItem.Tag := sIndex; if Combined then mnItem.Checked := true; PopMenu.Items.Add(mnItem); sIndex := sIndex+1; mnItem := TMenuItem.Create(PopMenu); mnItem.Caption := fmUnGroup; mnItem.Tag := sIndex; PopMenu.Items.Add(mnItem); sIndex := sIndex+1; mnItem := TMenuItem.Create(PopMenu); mnItem.Caption := fmDiagonal; mnItem.Tag := sIndex; mnItem.Checked := DiagonalScale; PopMenu.Items.Add(mnItem); sIndex := sIndex+2; end; procedure TFigureGrp.ResetRegion; var f: Tfigure; a: integer; begin inherited; for a := 0 to InFigures.Count-1 do begin f := TFigure(InFigures[a]); f.ResetRegion; end; end; procedure TFigureGrp.GetVectorObjects(Objects: Tlist; BaseP: TDoublePoint); var i: Integer; f: Tfigure; begin for i := 0 to Infigures.Count-1 do begin f := TFigure(Infigures[i]); f.GetVectorObjects(Objects,BaseP); end; end; Procedure TFigureGrp.VerifyZeroPoints(orgV,orgH:Byte); var i: Integer; begin for i := 0 to InFigures.Count -1 do begin TFigure(Infigures[i]).VerifyZeroPoints(orgV,orgH); end; end; procedure TFigureGrp.DrawFigureGuides(DEngine: TPCDrawEngine); var a: Integer; Figure: Tfigure; isDraw: Boolean; Layer: Tlayer; begin inherited; for a := 0 to inFigures.Count - 1 do begin Figure := TFigure(inFigures[a]); isDraw := true; if Figure.LayerHandle > 0 then begin Layer := TLayer(Figure.LayerHandle); isDraw := (Layer.visible <> lost); end; if isDraw and (not combined) then TFigure(InFigures[a]).drawFigureGuides(DEngine); end; end; procedure TFigureGrp.GetFigures(xList: TList); var a: Integer; Figure: Tfigure; begin if combined then xList.Add(Self) else for a := 0 to inFigures.Count - 1 do begin Figure := TFigure(inFigures[a]); if Figure is TFigureGrp then TFigureGrp(Figure).GetFigures(xList) else xList.Add(Figure); end; end; procedure TFigureGrp.SetCombined(const Value: Boolean); var a:Integer; begin FCombined := Value; if assigned(inFigures) then begin for a := 0 to inFigures.Count - 1 do begin TFigure(InFigures[a]).InCombined := Combined; end; end; end; procedure TFigureGrp.SetInCombined(const Value: Boolean); var a: Integer; begin inherited; if (Combined and Value) then Fcombined := False; if assigned(inFigures) then begin for a := 0 to inFigures.Count - 1 do begin TFigure(InFigures[a]).InCombined := Value; end; end; end; function TFigureGrp.GetClassName: String; begin result := 'FigureGrp'; end; procedure TFigureGrp.DrawDimlines(DEngine: TPCDrawEngine; isGrayed: Boolean); var i: Integer; begin for i := 0 to InFigures.Count-1 do Tfigure(InFigures[i]).DrawDimlines(Dengine,isGrayed); end; procedure TFigureGrp.CreateMetaFile; var rect:TDoubleRect; figMaxX,figMaxY,figMinX,figMinY: Double; begin getInbounds(figMaxX,figMaxY,figMinX,figMinY); rect := DoubleRect(figMinX,figMinY,figMaxX,FigMaxY); pointcount := 4; ActualPoints[1] := DoublePoint(rect.Left,rect.Top); ActualPoints[2] := DoublePoint(rect.Right,rect.Top); ActualPoints[3] := DoublePoint(rect.Right,rect.Bottom); ActualPoints[4] := DoublePoint(rect.Left,rect.Bottom); //if assigned(FMetaFile) then FMetafile.Free; //FMEtaFile := TPCDrawing(Owner).FigureAsWmf(Self.Handle,False); end; procedure TFigureGrp.SetSpecialPropertiesFromStream(Stream: TStream); begin inherited; CreateMetaFile; end; Destructor TFigureGrp.DestroyGrp; begin if assigned(FMetaFile) then FMetafile.Free; InFigures.Destroy; inherited; end; procedure TFigureGrp.getInbounds(var figMaxX, figMaxY, figMinX, figMinY: double); var mx,my,ax,ay: Double; a,i: integer; isFirst: boolean; begin if self is TFigureGrpMod then begin figMaxX := 0; figMaxY := 0; figMinX := 0; figMinY := 0; // isFirst := True; for a := 0 to inFigures.Count - 1 do begin //Tolik -- 08/06/2017 -- if TFigure(InFigures[a]).isAutoCreatedFigure = biFalse then begin if not (TFigure(InFigures[a]) is TArcDimLine) then begin if isFirst then begin TFigure(InFigures[a]).getBounds(figMaxX, figMaxY, figMinX, figMinY); isFirst := False; // Tolik -- 08/11/2016-- иначе рискуем потерять минимальные границы !!!!! mx := figMaxX; my := figMaxY; ax := figMinX; ay := figMinY; // end else begin mx := figMaxX; my := figMaxY; ax := figMinX; ay := figMinY; TFigure(InFigures[a]).getBounds(mx,my,ax,ay); end; if a > 0 then begin if mx > figMaxX then figMaxX := mx; if ax < figMinX then figMinX := ax; if my > figMaxY then figMaxY := my; if ay < figMinY then figMinY := ay; end; end else begin if isFirst then begin // Tolik 09/11/2016-- -- если объект будет состоять только из объектов типа АРКА, // то опять потеряем байнды нах....то есть, нужно так: figMaxX := TFigure(InFigures[a]).ActualPoints[1].x; figMaxY := TFigure(InFigures[a]).ActualPoints[1].y; figMinX := TFigure(InFigures[a]).ActualPoints[1].x; figMinY := TFigure(InFigures[a]).ActualPoints[1].y; end; figMinY := figMinY; end; end; end; end else begin figMaxX := 0; figMaxY := 0; figMinX := 0; figMinY := 0; // i := 0; for a := 0 to inFigures.Count - 1 do begin // Tolik -- 08/06/2017 -- if TFigure(InFigures[a]).isAutoCreatedFigure = biFalse then begin {if a = 0 then TFigure(InFigures[a]).getBounds(figMaxX, figMaxY, figMinX, figMinY)} if i = 0 then begin TFigure(InFigures[a]).getBounds(figMaxX, figMaxY, figMinX, figMinY); inc(i); end else begin mx := figMaxX; my := figMaxY; ax := figMinX; ay := figMinY; TFigure(InFigures[a]).getBounds(mx,my,ax,ay); end; if a > 0 then begin if mx > figMaxX then figMaxX := mx; if ax < figMinX then figMinX := ax; if my > figMaxY then figMaxY := my; if ay < figMinY then figMinY := ay; end; end; end; end; end; procedure TFigureGrp.SetFieldText(FName, FValue: String); var fig: TFigure; i: Integer; begin for i := 0 to InFigures.Count-1 do begin fig := Tfigure(InFigures[i]); if (fig is TText) then TText(fig).SetField(Fname,Fvalue) else if (fig is TTextPanel) then TTextPanel(fig).SetField(Fname,Fvalue) else if (fig is TFigureGrp) then TFigureGrp(fig).SetFieldText(FName, FValue); end; end; procedure TFigureGrp.LockDimensions(w, h: Double); begin actualpoints[2] := DoublePOint(ap1.x+w,ap1.y); actualpoints[3] := DoublePOint(ap1.x+w,ap1.y+h); actualpoints[4] := DoublePOint(ap1.x,ap1.y+h); DimLocked := True; end; procedure TFigureGrp.RemoveInFigure(FName: String); var fig: TFigure; i: Integer; begin try for i := 0 to InFigures.Count - 1 do begin fig := Tfigure(InFigures[i]); if fig.Name = FName then begin RemoveFromGrp(fig); //28.04.2011 InFigures.Remove(fig); Modified := true; BoundCalc := False; // 30/06/2017 -- Tolik ResetRegion; exit; end; end; except // on E: Exception do AddExceptionToLog(CPowerCadMessage + 'TFigureGrp.RemoveInFigure' + E.Message); end; // Tolik -- 27/06/2017 -- if Self.ClassName = TFigureGrpMod.ClassName then HasAutocreatedFigures := CheckHasAutocreatedFigures(TFigure(Self)); // end; procedure TFigureGrp.ReplaceTextWithWMF(FName: String; mf: TMEtafile); var fig: TFigure; i: Integer; txPanel: TTextPanel; xRect,wRect: TDoubleRect; ow,oh,w,h,sw,sh,s,dx,dy: Double; Cad: TPCDrawing; wmf: TWMFObject; begin for i := 0 to InFigures.Count-1 do begin fig := Tfigure(InFigures[i]); if (fig is TTextPanel) and (TTextPanel(fig).Text = FName) then begin txPanel := TTextPanel(fig); xRect := txPanel.GetBoundRect; wmf := TWMFObject.createEx(xRect.Left,xRect.top,mf,LayerHandle,mydsNormal,Owner); wRect := wmf.GetBoundRect; ow := wRect.Right-wRect.left; w := xRect.Right-xRect.Left; oh := wRect.Bottom-wRect.Top; h := xRect.Bottom-xRect.Top; sw := w/ow; sh := h/oh; s := sw; if sh < s then s := sh; wmf.Scale(s,s,DoublePoint(xRect.Left,xRect.top)); wRect := wmf.GetBoundRect; dx := (w-(wRect.Right-wRect.left))/2; dy := (h-(wRect.Bottom-wRect.Top))/2; wmf.Move(dx,dy); TPCDrawing(Owner).Figures.Add(wmf); txPanel.Text := ''; end else if (fig is TFigureGrp) then TFigureGrp(fig).ReplaceTextWithWMF(FName, mf); end; end; function TFigureGrp.Edit: Boolean; begin Self.RotateSelect; Result := True; end; procedure TFigureGrp.SetModified; var f: Tfigure; a: integer; begin inherited; for a := 0 to InFigures.Count-1 do begin f := TFigure(InFigures[a]); f.SetModified; end; end; procedure TFigureGrp.Unfilled; var i: Integer; begin inherited; for i := 0 to inFigures.Count-1 do TFigure(Infigures[i]).Unfilled; end; procedure TFigureGrp.DrawInFigures(DEngine: TPCDrawEngine; isGrayed: Boolean); var a:Integer; Layer: TLayer; Figure: TFigure; isDraw: Boolean; xBrs: Integer; begin for a := 0 to inFigures.Count - 1 do begin Figure := TFigure(inFigures[a]); isDraw := true; isGrayed := false; if Figure.LayerHandle > 0 then begin Layer := TLayer(Figure.LayerHandle); isDraw := (Layer.visible <> lost); isGrayed := (Layer.visible = Grayed); end; {//31.10.2011 if isDraw and TFigure(InFigures[a]).Visible then begin xBrs := TFigure(InFigures[a]).Brs; if Combined then Figure.Brs := TFigure(InFigures[a]).Brs := ord(bsClear); TFigure(InFigures[a]).draw(DEngine,isGrayed); if Combined then TFigure(InFigures[a]).Brs := xBrs; end;} if isDraw and Figure.Visible then begin if Combined then begin xBrs := Figure.Brs; Figure.Brs := ord(bsClear); end; Figure.draw(DEngine,isGrayed); if Combined then Figure.Brs := xBrs; //Tolik if Figure.RegHandle <> 0 then begin Figure.GetRegObject; if TBrushStyle(Figure.brs) <> bsClear then Figure.RegObject.CheckPointByRects := true; deleteObject(RegHandle); RegHandle := 0; end; // end; end; end; procedure TFigureGrp.SetOwnerProps; var Figure:TFigure; begin if Infigures.Count = 0 then exit; Figure := TFigure(inFigures[0]); Self.Style := Figure.Style; Self.width := Figure.Width; Self.color := Figure.Color; Self.Brs := Figure.Brs; Self.Brc := Figure.Brc; end; procedure TFigureGrp.SetGradient(GStyle: TGradStyle; ForeColor, BackColor: TColor); var i: Integer; begin inherited; for i := 0 to Infigures.Count-1 do TFigure(Infigures[i]).SetGradient(GStyle,ForeColor,BackColor); end; procedure TFigureGrp.SetHatch(HStyle: THatchStyle; ForeColor, BackColor: TColor; StepSize: Double); var i: Integer; begin inherited; for i := 0 to Infigures.Count-1 do TFigure(Infigures[i]).SetHatch(HStyle,ForeColor,BackColor,StepSize); end; procedure TFigureGrp.SetTexture(TStyle: TTextureStyle; TexSize: Integer); var i: Integer; begin inherited; for i := 0 to Infigures.Count-1 do TFigure(Infigures[i]).SetTexture(TStyle,TexSize); end; { TBlock } function TBlock.Rename: string; var a: integer; begin Name := BlockName + inttostr(Handle); CName := Copy(ClassName,1,length(classname)); if assigned(inFigures) then begin for a := 0 to inFigures.Count - 1 do begin TFigure(InFigures[a]).Rename; end; end; end; (* procedure TBlock.CreateProperties; var fPPage: TObjectInspector; a: integer; le: real; p1,p2: TPoint; CustomList: TList; begin if owner <> nil then begin if assigned(props[1]) then props[1].free; if assigned(props[2]) then props[2].free; if assigned(props[3]) then props[3].free; props[1] := TStringProperty.create('Name',false,name); props[2] := TIntegerProperty.create('Handle',true,Handle); props[3] := TBoolProperty.create('Combined',true,Combined); CCount := 0; CustomList := TPCDrawing(owner).GetCustomPropList(BlockName); if assigned(CustomList) then begin for a := 0 to CustomList.Count-1 do begin if assigned(props[4+a]) then props[4+a].free; props[4+a] := TProperty(Customlist[a]).Duplicate; end; CCOunt := CustomList.Count; end; end; end; *) procedure TBlock.WriteToStream(Stream: TStream); var xStr: String; a :integer; //pr: TProperty; xByte:Byte; xInt:Integer; xDbl: Double; begin inherited; xStr := BlockName; WriteStrField(180,Stream,xStr); xByte := VertZero; WriteField(95,Stream,xByte,1); xByte := HorzZero; WriteField(96,Stream,xByte,1); xInt := Round(MapScale); WriteField(25,Stream,xInt,4); xDbl := MapScale; WriteField(239, Stream, xDbl, sizeof(xDbl)); (* for a := 1 to CCOunt do begin pr := props[3+a]; xStr := pr.DataAsString;WriteStrField(180+a,Stream,xStr); end; *) end; procedure TBlock.SetPropertyFromStream(xCode: Byte; data: pointer; size: integer); var strval: string; //pr: TProperty; begin inherited; if xCode = 95 then begin OrgVZ := pByte(data)^; end else if xCode = 96 then begin OrgHZ := pByte(data)^; end else if xCode = 25 then begin MapScale := pInt(data)^; end else if xCode = 180 then begin BlockName := String(pChar(Data)); //CreateProperties; end else if (xCode > 180) and (xCode < 220) then begin strval := String(pAnsiChar(Data)); //pr := TProperty(props[3+xCode-180]); //pr.SetData(strVal); end else if xCode = 239 then begin MapScale := pDouble(data)^; end; end; constructor TBlock.Create(LHandle: Integer;aOwner: TComponent); begin inherited create(LHandle,aOwner); MapScale := TPCDrawing(Owner).MapScale; end; procedure TBlock.Initialize; begin inherited; MapScale := 1; if assigned(Owner) then MapScale := TPCDrawing(Owner).MapScale; end; function TBlock.duplicate: TFigure; var res: TBlock; a : integer; begin res := TBlock.create(LayerHandle,Owner); for a := 0 to inFigures.Count - 1 do begin res.AddFigure(TFigure(InFigures[a]).duplicate); end; res.changed := changed; res.AngleToPoint := AngleToPoint; res.Info := Info; res.OrgVz := orgvz; res.OrgHz := orghz; res.Blockname := Blockname; res.MapScale := MapScale; result := res; end; function TBlock.GetClassName: String; begin result := 'Block'; end; procedure TBlock.SaveToFile(const AFileName: String); //27.08.2010 //#From Oleg# var fStream: TFileStream; begin fStream := TFileStream.Create(AFileName,fmCreate); Self.WriteToStream(fStream); fStream.free; end; { TRotate } constructor TRotate.create(cX, cY:Double; p1, p2: TDoublepoint); begin inherited create(0,dsTrace,nil); pointcount := 3; actualpoints[1] := DoublePoint(cx,cy); actualpoints[2] := DoublePoint(p1.x,p1.y); actualpoints[3] := DoublePoint(p2.x,p2.y); end; class function TRotate.CreateShadow(x, y: Double): TFigure; begin CreateShadow := TRotate.create(x,y,DoublePoint(x,y),DoublePoint(x,y)); end; procedure TRotate.draw(DEngine: TPCDrawEngine;isGrayed:Boolean); begin DEngine.Canvas.pen.mode := pmXor; DEngine.drawline(ap1.x,ap1.y,ap2.x,ap2.y,clLime,1,1,0); DEngine.drawline(ap1.x,ap1.y,ap3.x,ap3.y,clLime,1,1,0); end; function TRotate.ShadowClick(ClickIndex:Integer; x, y: Double): Boolean; begin result := false; if clickindex = 2 then begin actualpoints[2] := DoublePoint(x,y); result := false; end else if clickindex = 3 then begin actualpoints[3] := DoublePoint(x,y); result := true; end; end; class function TRotate.CreateFromShadow(aOwner: TComponent; LHandle: Integer; Shadow: TFigure): TFigure; var cad: TPCDrawing; a: Double; begin cad := TPCDrawing(aOwner); a := TRotate(Shadow).GetAngle; cad.RotateSelection(a,Shadow.ap1); result := nil; end; function TRotate.ShadowTrace(ClickIndex:Integer; x, y:Double): Boolean; begin if clickindex = 1 then begin actualpoints[2] := DoublePoint(x,y); end else if clickindex = 2 then begin actualpoints[3] := DoublePoint(x,y); end; end; function TRotate.GetAngle: Double; var a1,a2,a: Double; sgn: Integer; begin a1 := GetRadOfLine(ap1,ap2); if a1 > pi then a1 := a1 - 2*pi; a2 := GetRadOfLine(ap1,ap3); if a2 > pi then a2 := a2 - 2*pi; result := a2-a1; end; { TMove } constructor TMove.create(p1, p2: TDoublepoint); begin inherited create(0,dsTrace,nil); Initialize; // Tolik 29/07/2021 -- pointcount := 2; actualpoints[1] := Doublepoint(p1.x,p1.y); actualpoints[2] := Doublepoint(p2.x,p2.y); end; class function TMove.CreateShadow(x, y: Double): TFigure; begin CreateShadow := TMove.create(Doublepoint(x,y),Doublepoint(x,y)); end; procedure TMove.draw(DEngine: TPCDrawEngine;isGrayed:Boolean); begin DEngine.Canvas.pen.mode := pmXor; DEngine.drawline(ap1.x,ap1.y,ap2.x,ap2.y,clLime,1,1,0); end; function TMove.ShadowClick(ClickIndex:Integer; x, y:Double): Boolean; begin result := false; if clickindex = 2 then begin actualpoints[2] := DoublePoint(x,y); result := true; end; end; class function TMove.CreateFromShadow(aOwner: TComponent; LHandle: Integer; Shadow: TFigure): TFigure; var cad: TPCDrawing; begin cad := TPCDrawing(aOwner); cad.MoveSelection(Shadow.ap2.x-Shadow.ap1.x,Shadow.ap2.y-Shadow.ap1.y); result := nil; end; function TMove.ShadowTrace(ClickIndex:Integer; x, y:Double): Boolean; begin if clickindex = 1 then actualpoints[2] := DoublePoint(x,y); end; { TDuplicate } class function TDuplicate.CreateShadow(x, y: Double): TFigure; begin CreateShadow := TDuplicate.create(DoublePoint(x,y),DoublePoint(x,y)); end; class function TDuplicate.CreateFromShadow(aOwner: TComponent; LHandle: Integer; Shadow: TFigure): TFigure; var cad: TPCDrawing; begin cad := TPCDrawing(aOwner); cad.DuplicateSelection(Shadow.ap2.x-Shadow.ap1.x,Shadow.ap2.y-Shadow.ap1.y); result := nil; end; { TMirror } class function TMirror.CreateShadow(x, y: Double): TFigure; begin CreateShadow := TMirror.create(DoublePoint(x,y),DoublePoint(x,y)); end; class function TMirror.CreateFromShadow(aOwner: TComponent; LHandle: Integer; Shadow: TFigure): TFigure; var cad: TPCDrawing; begin cad := TPCDrawing(aOwner); cad.MirrorSelection(Shadow.ap1,Shadow.ap2,(ssShift in Cad.CurrentShift) and MirrorDupl); result := nil; end; procedure TMirror.Initialize; begin inherited; Straight := False; end; function TMirror.ShadowClick(ClickIndex: Integer; x, y: Double): Boolean; var dx,dy: Double; begin result := false; if Straight then begin if clickindex = 2 then begin dx := abs(ap1.x - x); dy := abs(ap1.y - y); if dx > dy then y := ap1.y else x := ap1.x; actualpoints[2] := DoublePoint(x,y); result := true; end; end else begin result := inherited ShadowClick(ClickIndex,x, y); end; end; function TMirror.ShadowTrace(ClickIndex: Integer; x, y: Double): Boolean; var dx,dy: Double; begin if Straight then begin if clickindex = 1 then begin dx := abs(ap1.x - x); dy := abs(ap1.y - y); if dx > dy then y := ap1.y else x := ap1.x; actualpoints[2] := DoublePoint(x,y); end; end else begin inherited ShadowTrace(ClickIndex,x, y);; end; end; { TArrayPol } class function TArrayPol.CreateShadow(x, y: Double): TFigure; begin CreateShadow := TArrayPol.create(x,y,DoublePoint(x,y),DoublePoint(x,y)); end; class function TArrayPol.CreateFromShadow(aOwner: TComponent; LHandle: Integer; Shadow: TFigure): TFigure; var cad: TPCDrawing; a: Double; begin cad := TPCDrawing(aOwner); a := TArrayPol(Shadow).GetAngle; cad.ArrayPolarSelection(Shadow.ap1,a); result := nil; end; function TArrayPol.GetAngle: Double; var a1,a2,a: Double; sgn: Integer; begin a1 := GetRadOfLine(ap1,ap2); if a1 > pi then a1 := a1 - 2*pi; a2 := GetRadOfLine(ap1,ap3); if a2 > pi then a2 := a2 - 2*pi; result := a2-a1; end; { TArrayRect } constructor TArrayRect.create(p1, p2, p3, p4,p5: TDoublepoint); begin inherited create(0,dsTrace,nil); initialize; // Tolik 29/07/2021 -- pointcount := 5; actualpoints[1] := DoublePoint(p1.x,p1.y); actualpoints[2] := DoublePoint(p2.x,p2.y); actualpoints[3] := DoublePoint(p3.x,p3.y); actualpoints[4] := DoublePoint(p4.x,p4.y); actualpoints[5] := DoublePoint(p5.x,p5.y); end; class function TArrayRect.CreateShadow(x, y: Double): TFigure; begin CreateShadow := TArrayRect.Create(DoublePoint(x,y),DoublePoint(x,y), DoublePoint(x,y),DoublePoint(x,y),DoublePoint(x,y)); end; procedure TArrayRect.draw(DEngine: TPCDrawEngine;isGrayed:Boolean); var dx,dy: Double; tcount,a: integer; ap5: TDoublePoint; begin ap5 := ActualPoints[5]; DEngine.Canvas.pen.mode := pmXor; DEngine.drawline(ap1.x,ap1.y,ap4.x,ap1.y,clLime,1,0,0); DEngine.drawline(ap1.x,ap1.y,ap1.x,ap5.y,clLime,1,0,0); dx := ap2.x-ap1.x; if dx <> 0 then begin tcount := round(abs(ap4.x-ap1.x) / abs(dx)); for a := 1 to tcount do begin DEngine.drawline(ap1.x+(dx*a),ap1.y-3,ap1.x+(dx*a),ap1.y+3,clLime,1,0,0); end; end; dy := ap3.y-ap1.y; if dy <> 0 then begin tcount := Round(abs(ap5.y-ap1.y) / abs(dy)); for a := 1 to tcount do begin DEngine.drawline(ap1.x-3,ap1.y+(dy*a),ap1.x+3,ap1.y+(dy*a),clLime,1,0,0); end; end; end; function TArrayRect.ShadowClick(ClickIndex:Integer; x,y: Double): Boolean; begin result := false; if clickindex = 2 then begin actualpoints[2] := DoublePoint(x,y); actualpoints[4] := DoublePoint(x,y); end else if clickindex = 3 then begin actualpoints[3] := DoublePoint(x,y); actualpoints[5] := DoublePoint(x,y); end else if clickindex = 4 then begin actualpoints[4] := DoublePoint(x,y); end else if clickindex = 5 then begin actualpoints[5] := DoublePoint(x,y); result := true; end; end; class function TArrayRect.CreateFromShadow(aOwner: TComponent; LHandle: Integer; Shadow: TFigure): TFigure; var cad: TPCDrawing; a1,a2,r: Double; p1,p2,p3,p4,p5: TDoublePoint; dx,dy: Double; col,row: integer; begin col := 0;row:= 0; cad := TPCDrawing(aOwner); p1 := shadow.actualpoints[1]; p2 := shadow.actualpoints[2]; p3 := shadow.actualpoints[3]; p4 := shadow.actualpoints[4]; p5 := shadow.actualpoints[5]; dx := p2.x-p1.x; if dx <> 0 then col := Round(abs(p4.x-p1.x) / abs(dx)); dy := p3.y-p1.y; if dy <> 0 then row := Round(abs(p5.y-p1.y) / abs(dy)); cad.ArrayRectSelection(dx,dy,col+1,row+1); result := nil; end; function TArrayRect.ShadowTrace(ClickIndex:Integer; x, y: Double): Boolean; begin if clickindex = 1 then begin actualpoints[2] := DoublePoint(x,y); actualpoints[4] := DoublePoint(x,y); end else if clickindex = 2 then begin actualpoints[3] := DoublePoint(x,y); actualpoints[5] := DoublePoint(x,y); end else if clickindex = 3 then begin actualpoints[4] := DoublePoint(x,y); end else if clickindex = 4 then begin actualpoints[5] := DoublePoint(x,y); end; end; { TRichText } constructor TRichText.create(aX1, aY1, aX2, aY2:Double; w, s, c, abrs, abrc, LHandle: Integer; aDrawStyle: TDrawStyle; aOwner: TComponent; AText: Boolean=true); begin inherited create(aX1, aY1, aX2, aY2, w, s, c, abrs, abrc, LHandle, aDrawStyle, aOwner); if AText then //11.10.2011 re.Lines.Add(cDrawObjects_Mes7); // Initialize; // Tolik 24/03/2017 -- { Self.Lines := nil; Self.frm := nil;} // end; class function TRichText.ShadowType: TShadowType; begin result := stRectangle; end; procedure TRichText.Initialize; var fCanvas: TMetaFileCanvas; xLines: TStringList; begin inherited; pointcount := 4; frm := nil; ShowGuide := True; TagParse := False; if owner <> nil then begin //GProcCnt := GProcCnt + 1; if owner is TPowerCad then begin TPowerCad(owner).DisableAlign; end; try re := TRichEdit98.Create(owner); re.IncludeOLE := True; re.visible := false; re.Font.Size := 8; {//02.11.2011} if assigned(TPCDrawing(owner).parent) then begin if (owner <> nil) and (owner.ClassName = 'TPowerCad') then re.Parent := TPowerCad(owner) else if (owner <> nil) and (owner.ClassName = 'TPCDrawing') then re.Parent := TPCDrawing(owner); end else begin frm := TFrmInput.Create(application); re.Parent := frm; end; re.Perform(WM_PAINT,0,0); ttMetaFile:= TMetaFile.Create; ttMetafile.Enhanced := True; fCanvas := TMetafileCanvas.Create(ttMetafile, 0); TPCDrawing(Owner).DEngine.DrawRTFToCanvas(re, 1, 1,ttMetafile.Width - 3, ttMetafile.Height - 3, fCanvas, false); fCanvas.Free; //Tolik 13/01/2017 - - ttMetaFile.Free; ttMetaFile := nil; //FreeAndNil(fCanvas); //MetaFile.Free; Lines := Tstringlist.Create; FontName := 'Arial'; FontSize := 12; FontStyle := []; finally if owner is TPowerCad then begin //TPowerCad(owner).EnableAlign; if owner.Owner is TForm then begin TForm(owner.Owner).DisableAlign; TPowerCad(owner).EnableAlign; TForm(owner.Owner).ControlState := TForm(owner.Owner).ControlState - [csAlignmentNeeded]; TForm(owner.Owner).EnableAlign; end else TPowerCad(owner).EnableAlign; end; end; end; end; Function TRichText.Edit: Boolean; var cad: TPCDrawing; EditForm: TfrmRichEdit; xStream: TMemorystream; xStream2: TMemorystream; SelChange: TNotifyEvent; // Tolik 05/10/2021 -- begin result := false; if assigned(re) and assigned (owner) then begin EditForm := TFrmRichEdit.Create(owner); EditForm.Caption := cDrawObjects_Mes8; xStream := TmemoryStream.Create; // Tolik 24/02/2020 -- GetRTFSelection(TRichEdit(re), xStream); //re.Lines.SaveToStream(xStream); // xStream.Position := 0; //Tolik SelChange := EditForm.RichEdit1.OnSelectionChange; EditForm.RichEdit1.OnSelectionChange := nil; // //EditForm.RichEdit1.Lines.LoadFromStream(xStream); //Tolik 05/10/2021 -- //EditForm.RichEdit1.Lines.LoadFromStream(xStream, nil ); // EditForm.fStream := xStream; EditForm.RichEdit1.Font.Name := re.Font.Name; if EditForm.RichEdit1.Font.Name = 'GOST' then EditForm.RichEdit1.Font.Charset := 204; // EditForm.RichEdit1.OnSelectionChange := SelChange; // Tolik 05/10/2021 -- //xStream.Free; EditForm.RichEdit1.OnChange := EditForm.onTextChange; // Tolik 10/03/2020 -- if EditForm.ShowModal = mrOk then begin xStream2 := TmemoryStream.Create; //EditForm.RichEdit1.Lines.SavetoStream(xStream); GetRTFSelection(TRichEdit(EditForm.RichEdit1) ,xStream2); xStream2.Position := 0; re.Lines.LoadFromStream(xStream2); xStream2.Free; if Editform.TextChangesCount > 0 then // Tolik -- 10/03/2020 -- SetProjectChanged(true); end; xStream.Free; Editform.free; result := true; end; end; procedure TRichText.draw(DEngine: TPCDrawEngine; isGrayed: Boolean); var acolor,bcolor : Tcolor; points: TDoublePointArr; cad: TPCDrawing; dx,dy: double; w,h: extended; wi,hi: Integer; fCanvas:TMetaFileCanvas; a,cnt,i,pCnt: integer; tw,th:Integer; twd,thd:Double; xLines: TStringList; tp1: TPoint; mLine: Boolean; region: HRGN; np: Boolean; oldcolor: TColor; // Tolik 01/11/2021 -- xstream: TMemoryStream; re_Change, re_SelChange: TNotifyEvent; se_Change: TNotifyEvent; begin region := 1; //Tolik 01/11/2021 -- //acolor := color; acolor := re.SelAttributes.color; // bColor := brc; if (aColor = -255) and (LayerHandle <> 0) then begin aColor := TLayer(LayerHandle).PenColor; end; if (bColor = -255) and (LayerHandle <> 0) then begin bColor := TLayer(LayerHandle).BrushColor; end; if (isGrayed) then begin acolor := TPCDrawing(Owner).FGrayedColor; //06.08.2012 GrayedColor; bcolor := TPCDrawing(Owner).FGrayedColor; //06.08.2012 GrayedColor; end; if DrawStyle = dsTrace then DEngine.Canvas.Pen.Mode := pmXor else DEngine.Canvas.Pen.Mode := pmCopy; SetLength(points,4); points[0] := ap1; points[1] := ap2; points[2] := ap3; points[3] := ap4; if DrawStyle = dsTrace then begin DEngine.drawpolygon(points,acolor,width,style,bcolor,ord(bsClear),RegHandle); //Tolik if RegHandle <> 0 then begin GetRegObject; if TBrushStyle(brs) <> bsClear then RegObject.CheckPointByRects := true; deleteObject(RegHandle); RegHandle := 0; end; // exit; end; cad := TPCdrawing(Owner); tp1 := Point(0,0); // Tolik -- 13/01/2017 -- ttMetaFile:= TMetaFile.Create; ttMetafile.Enhanced := True; // if (TagParse) and (assigned(owner)) and (assigned(ttmetafile)) then begin w := GetLineLenght(ap1,ap2); h := GetLineLenght(ap1,ap4); hi := round(h * 4)+1; wi := round(w * 4)+1; ttMetafile.Height := hi; ttMetafile.Width := wi; fCanvas := TMetafileCanvas.Create(ttMetafile, 0); ttMetafile.Height := hi; ttMetafile.Width := wi; //здесь Region = 1так что новый объект не создается, просто нарисуется (Tolik) //Tolik 01/11/2021 -- // DEngine.DrawMTextToCanvas(tp1, Lines, FontName, FontStyle, Color{clBlack}, FontSize, 0, 0, 0, 0, Region, tw, th, fCanvas); DEngine.DrawMTextToCanvas(tp1, Lines, FontName, FontStyle, aColor{clBlack}, FontSize, 0, 0, 0, 0, Region, tw, th, fCanvas); // twd := tw / 4; thd := th / 4; actualpoints[2] := DoublePoint(ap1.x + twd, ap1.y); actualpoints[3] := DoublePoint(ap4.x + twd, ap4.y); mLine := False; if th > hi then begin thd := 0; mLine := True; xLines := TstringList.Create; cnt := Lines.Count; pCnt := Trunc(hi / (th/cnt))-1; tp1 := Point(0,0); for i := 0 to cnt-1 do begin xLines.Add(Lines[i]); np := Pos('',lines[i]) >0; if (xLines.Count = pCnt) or (i = cnt-1) or np then begin DEngine.DrawMTextToCanvas(tp1,xLines,FontName,FontStyle,Color{clBlack},FontSize,0,0,0,0,Region,tw,th,fCanvas); tp1.x := tp1.x+tw+6; xLines.Clear; end; end; tw := tp1.x; twd := tw/4; thd := thd/4; actualpoints[2] := DoublePoint(ap1.x+twd,ap1.y); actualpoints[3] := DoublePoint(ap4.x+twd,ap4.y); end else begin actualpoints[3] := DoublePoint(ap3.x,ap2.y+thd); actualpoints[4] := DoublePoint(ap4.x,ap1.y+thd); end; fCanvas.free; w := GetLineLenght(ap1,ap2); h := GetLineLenght(ap1,ap4); hi := round(h * 4)+1; wi := round(w * 4)+1; ttMetafile.Height := hi; ttMetafile.Width := wi; fCanvas := TMetafileCanvas.Create(ttMetafile, 0); ttMetafile.Height := hi; ttMetafile.Width := wi; if mLine then begin tp1 := Point(0,0); thd := 0; for i := 0 to cnt-1 do begin xLines.Add(Lines[i]); np := Pos('',lines[i]) >0; if (xLines.Count = pCnt) or (i = cnt-1) or np then begin DEngine.DrawMTextToCanvas(tp1,xLines,FontName,FontStyle,Color{clBlack},FontSize,0,0,0,0,Region,tw,th,fCanvas); tp1.x := tp1.x+tw+6; if th > thd then thd := th; xLines.Clear; end; end; xLines.Free; thd := thd/4; //actualpoints[3] := DoublePoint(ap3.x,ap2.y+thd); //actualpoints[4] := DoublePoint(ap4.x,ap1.y+thd); end else begin DEngine.DrawMTextToCanvas(tp1,Lines,FontName,FontStyle,Color{clBlack},FontSize,0,0,0,0,Region,tw,th,fCanvas); end; fCanvas.free; if OSVersion.dwPlatformId = VER_PLATFORM_WIN32_NT then DEngine.DrawMetafile(ap1,ap2,ap3,ap4,clWhite,0,ord(psClear),ttMetafile,true,RegHandle) else DEngine.DrawTransparentMetafile(ap1,ap2,ap3,ap4,clWhite,0,ord(psClear),ttMetafile,RegHandle); if Dengine.isPrinting then begin try ttMetafile.SaveToFile('c:\baca.wmf'); except end; end; end else begin if ttMetafile = nil then begin ttMetaFile:= TMetaFile.Create; ttMetafile.Enhanced := True; end; if assigned(re) and assigned(owner) and assigned(ttmetafile) then begin w := GetLineLenght(ap1, ap2); h := GetLineLenght(ap1, ap4); ttMetafile.Height := round(h * 4) + 1; ttMetafile.Width := round(w * 4) + 1; fCanvas := TMetafileCanvas.Create(ttMetafile, 0); ttMetafile.Height := round(h * 4) + 1; ttMetafile.Width := round(w * 4) + 1; //Tolik 02/11/2021 -- если оттенки серого if isGrayed then begin xstream := tMemoryStream.Create; re_Change := re.OnChange; re.OnChange := nil; re_SelChange := re.OnSelectionChange; re.OnSelectionChange := nil; GetRTFSelection(TRichEdit(re), xStream); re.SelectAll; //re.Font.Color := GCadForm.PCad.FGrayedColor; re.SelAttributes.Color := GCadForm.PCad.FGrayedColor; end; // DEngine.DrawRTFToCanvas(re, 1, 1, ttMetafile.Width-3, ttMetafile.Height-3, fCanvas, false); // fCanvas.Free; if OSVersion.dwPlatformId = VER_PLATFORM_WIN32_NT then DEngine.DrawMetafile(ap1, ap2, ap3, ap4, clWhite, 0, ord(psClear), ttMetafile, true, RegHandle) //DEngine.DrawMetafile(ap1, ap2, ap3, ap4, aColor, 0, ord(psClear), ttMetafile, true, RegHandle) else DEngine.DrawTransparentMetafile(ap1, ap2, ap3, ap4, clWhite, 0, ord(psClear), ttMetafile, RegHandle); //Tolik 02/11/2021 -- if isGrayed then begin xStream.Position := 0; re.Lines.LoadFromStream(xStream); re.OnChange := re_Change; re.OnSelectionChange := re_SelChange; xStream.Free; end; // end; end; // Tolik 24/05/2019 -- SetLength(points, 0); // //Tolik if RegHandle <> 0 then begin GetRegObject; if TBrushStyle(brs) <> bsClear then RegObject.CheckPointByRects := true; deleteObject(RegHandle); RegHandle := 0; end; ttMetaFile.Free; ttMetafile := nil; // end; class function TRichText.CreateFromShadow(aOwner: TComponent; LHandle: Integer; Shadow: TFigure): TFigure; var cad: TPCDrawing; x1,y1,x2,y2: Double; p1,p2,p3,p4: TDoublePoint; begin cad := TPCDrawing(aOwner); x1 := Shadow.ap1.x; x2 := Shadow.ap3.x; y1 := Shadow.ap1.y; y2 := Shadow.ap3.y; result := TRichText.create( x1,y1,x2,y2, cad.DefaultPenWidth, ord(Cad.DefaultPenStyle), cad.DefaultPenColor, ord(Cad.DefaultBrushStyle), cad.DefaultBrushColor, LHandle, mydsNormal,aOwner); end; function TRichText.isPointIn(x,y:Double): boolean; begin result := inherited isPointIn(x,y); if result then exit; result := IsPointInRegion(x,y); //Tolik Result := IsPointInRegionByRegObj(x,y); // end; Procedure TRichText.Rotate(aAngle: Double; cPoint: TDoublePoint); begin if OSVersion.dwPlatformId = VER_PLATFORM_WIN32_NT then inherited; end; Procedure TRichText.Mirror(Point1,Point2: TDoublePoint); begin if OSVersion.dwPlatformId = VER_PLATFORM_WIN32_NT then inherited; end; Destructor TRichText.Destroy; begin if (owner <> nil) and (owner is TPowerCad) then TPowerCad(owner).DisableAlign; try if assigned(re) then begin FreeAndNil(re); end; { if assigned(metafile) then // metafile.free; FreeAndNil(MetaFile); } { if assigned(frm) then //frm.free; FreeAndNil(frm); // Tolik if self.Lines <> nil then Self.Lines.Free;} // finally if (owner <> nil) and (owner is TPowerCad) then begin if owner.Owner is TForm then begin TForm(owner.Owner).DisableAlign; TPowerCad(owner).EnableAlign; TForm(owner.Owner).ControlState := TForm(owner.Owner).ControlState - [csAlignmentNeeded]; TForm(owner.Owner).EnableAlign; end else TPowerCad(owner).EnableAlign; end; end; // Tolik 24/05/2019 -- FreeAndNil(Lines); // inherited destroy; end; // Tolik 23/05/2019 -- старая закомменчена - см. ниже procedure TRichText.WriteToStream(Stream: TStream); var xStream : TMemoryStream; xSize: integer; xCode: Byte; begin inherited; xStream := TMemoryStream.Create; //re.SelectAll; GetRTFSelection(TRichEdit(re), xStream); xSize := xStream.Size; xStream.Position := 0; xCode := 150; Stream.Write(xCode,1); Stream.Write(xSize,4); StreamToStream(xStream,Stream,xSize); xStream.Free; WriteField(91, Stream, ShowGuide, 1); end; { procedure TRichText.WriteToStream(Stream: TStream); var xStream : TMemoryStream; xSize: integer; xCode: Byte; begin inherited; xStream := TMemoryStream.Create; // try re.Lines.SaveToStream(xStream); //except //on E: Exception do // ShowMessage('Error Writting TRichTextMod to Stream!' + ' re.Text = ' + re.Lines.Text); //end; //re.WideLines.SaveToStream(xStream); xSize := xStream.Size; xStream.Position := 0; xCode := 150; Stream.Write(xCode,1); Stream.Write(xSize,4); StreamToStream(xStream,Stream,xSize); xStream.Free; WriteField(91, Stream, ShowGuide, 1); // WriteField(34, Stream, re.Font.color, 4); end; } { procedure TRichText.WriteToStream(Stream: TStream); var xStream : TMemoryStream; xSize: integer; xCode: Byte; begin inherited; xStream := TMemoryStream.Create; re.Lines.SaveToStream(xStream); //re.WideLines.SaveToStream(xStream); xSize := xStream.Size; xStream.Position := 0; xCode := 150; Stream.Write(xCode,1); Stream.Write(xSize,4); StreamToStream(xStream,Stream,xSize); xStream.Free; WriteField(91, Stream, ShowGuide, 1); // WriteField(34, Stream, re.Font.color, 4); end; } // Tolik 24/05/2019 - - старая закомменчена - - см ниже procedure TRichText.SetPropertyFromStream(xCode:Byte;data:pointer;size:integer); var mstr:TMemoryStream; //Tolik 01/04/2019 i: Integer; aList: TStringList; ss: AnsiString; ttColor: TColor; // begin Case xcode of 150: begin mStr := TMemoryStream.Create; mStr.Write(pByte(data)^,size); mStr.Position := 0; PutRTFSelection(TRichEdit(re), mStr); mStr.Free; end; 91 : ShowGuide := (pByte(data)^ = 1); // 34 : re.Font.color := pInt(data)^; end; end; (* procedure TRichText.SetPropertyFromStream(xCode:Byte;data:pointer;size:integer); var mstr:TMemoryStream; //Tolik 01/04/2019 i: Integer; aList: TStringList; ss: AnsiString; ttColor: TColor; // begin Case xcode of 150: begin mStr := TMemoryStream.Create; mStr.Write(pByte(data)^,size); mStr.Position := 0; re.Lines.LoadFromStream(mStr); //re.WideLines.LoadFromStream(mStr); mStr.Free; // Tolik 01/04/2019 -- correction // Здесь была попытка исправить строчки, т.к. в lines приходил мусор из-за того, что // читается WideLines и неправильно конвертировалось в строки // в function TRichEditStrings98.Get(Index: Integer): string; // begin // Result:= WideToChar(TWideRichEditStrings98(RichEdit.WideLines).Get(Index), RichEdit.FCP); // WideToChar возвращал string а нужно AnsiString { for i := 0 to re.WideLines.Count - 1 do begin if re.Lines.Count < (i + 1) then re.Lines.Add(AnsiString(aList.Strings[i])) else re.Lines[i] := AnsiString(re.WideLines[i]); end; i := re.WideLines.Count; while re.Lines.Count > re.WideLines.Count do re.Lines.Delete(i - 1); } // end; 91 : ShowGuide := (pByte(data)^ = 1); // 34 : re.Font.color := pInt(data)^; end; end; *) function TRichText.duplicate: TFigure; var Res: TRichText; xStream: TmemoryStream; begin res := TRichText.create( originalpoints[1].x, originalpoints[1].y, originalpoints[3].x, originalpoints[3].y, width, style, color, brs, brc, LayerHandle, DrawStyle,Owner); res.actualpoints[1] := actualpoints[1]; res.actualpoints[2] := actualpoints[2]; res.actualpoints[3] := actualpoints[3]; res.actualpoints[4] := actualpoints[4]; res.originalpoints[1] := originalpoints[1]; res.originalpoints[2] := originalpoints[2]; res.originalpoints[3] := originalpoints[3]; res.originalpoints[4] := originalpoints[4]; xStream := TMemoryStream.Create; // Tolik 24/02/2020 -- //re.Lines.SaveToStream(xStream); GetRTFSelection(TRichEdit(re), xStream); xStream.Position := 0; // xStream.Position := 0; res.re.Lines.LoadFromStream(xStream); xStream.Free; res.AngleToPoint := AngleToPoint; res.RotPoint := RotPoint; result := res; end; procedure TRichText.DrawFigureGuides(DEngine: TPCDrawEngine); var points: TDoublePointArr; begin inherited; if DrawStyle = dsTrace then Exit; if not ShowGuide then exit; SetLength(points,4); points[0] := ap1; points[1] := ap2; points[2] := ap3; points[3] := ap4; DEngine.canvas.pen.mode := pmCopy; // DEngine.drawpolygon(points,clRed,1,1,0,ord(bsClear),RegHandle); // Tolik 24/05/2019- - SetLength(points, 0); // end; function TRichText.GetClassName: String; begin result := 'RichText'; end; constructor TRichText.createEx(aX1, aY1, aX2, aY2: Double; w, s, c, abrs, abrc: integer; Lines, FontName: String; FontSize, LHandle: Integer; aDrawStyle: TDrawStyle; aOwner: TComponent); var fCanvas:TMetaFileCanvas; xList: TStringList; xStr:TMemoryStream; begin inherited create(aX1, aY1, aX2, aY2, w, s, c, abrs, abrc, LHandle, aDrawStyle, aOwner); if owner <> nil then begin re.Font.Size := FontSize; re.Font.Name := FontName; re.Perform(WM_PAINT,0,0); xList := TStringList.Create; xList.Text := Lines; xStr := TMemoryStream.Create; xList.SaveToStream(xStr); xStr.Position := 0; re.Lines.LoadFromStream(xStr); xStr.Free; xList.Free; // Tolik -- 13/01/2017 -- ttMetaFile:= TMetaFile.Create; ttMetafile.Enhanced := True; // fCanvas := TMetafileCanvas.Create(ttMetafile, 0); TPCDrawing(Owner).DEngine.DrawRTFToCanvas(re, 1, 1, ttMetafile.Width - 3, ttMetafile.Height - 3, fCanvas, false); fCanvas.Free; // Tolik -- 13/01/2017 -- ttMetaFile.Free; ttMetafile := Nil; // end; // Tolik 24/03/2017 -- { Self.Lines := nil; Self.Frm := nil;} // end; procedure TRichText.CheckAndChangeFont; var size: integer; i, j, k: Integer; NotesList: TStringList; LHandle: Integer; TM: TTextMetric; xCanvas: TMetafileCanvas; h, w: double; TextX, TextY: double; begin // size := re.Font.Size; TextX := abs(ap1.x - ap2.x); TextY := abs(ap1.y - ap3.y); // for k := size downto 1 do // begin // re.Font.Size := k; // получить свойства // Tolik -- 13/01/2017 -- ttMetaFile:= TMetaFile.Create; ttMetafile.Enhanced := True; // xCanvas := TMetafileCanvas.Create(ttMetafile, 0); // xCanvas.Font.Name := re.Font.Name; // xCanvas.Font.Size := re.Font.Size; GetTextMetrics(xCanvas.Handle, TM); h := TM.tmHeight / 4 * re.Lines.Count + 1; w := 0; for i := 0 to re.Lines.Count - 1 do begin if w < xCanvas.TextWidth(Re.Lines[i]) then w := xCanvas.TextWidth(Re.Lines[i]); end; w := (w + 3) / 4 ; FreeAndNil(xCanvas); // Tolik -- 13/01/2017 ttMetaFile.Free; ttMetafile := Nil; // if (k = 1) or (w < TextX) and (h < TextY) then begin // Break; end; // end; end; { TOLEObject } constructor TOleObject.create(aX1, aY1, aX2, aY2:Double;w, s, c, abrs, abrc, LHandle: Integer; aDrawStyle: TDrawStyle; aOwner: TComponent); begin inherited create(ax1,ay1,ax2,ay2,w,s,c,abrs,abrc,LHandle,aDrawStyle,aOwner); //initialize; it is already called from trectangle.create end; class function TOleObject.ShadowType:TShadowType; begin result := stRectangle; end; procedure TOLEObject.Initialize; begin inherited; pointcount := 4; if owner <> nil then begin ole := TMFSOle.Create(owner); ole.name := self.Name; ole.visible := false; ole.Parent := TPCDrawing(owner); MetaFile:= TMetaFile.Create; Metafile.Enhanced := True; end; end; Function TOleObject.Edit: Boolean; var a: integer; v: string; idx: integer; begin result := false; if assigned(ole) and assigned (owner) then begin if ole.OleObjectInterface = nil then begin try if ole.InsertObjectDialog then begin idx := -1; for a := 0 to ole.objectVerbs.Count -1 do begin v := ole.objectVerbs[a]; if v = 'Open' then idx := a; end; if idx > -1 then ole.DoVerb(idx) else ole.DoVerb(0); result := true; ole.Refresh; end; except result := false; end; end else begin try idx := -1; for a := 0 to ole.objectVerbs.Count -1 do begin v := ole.objectVerbs[a]; if v = 'Open' then idx := a; end; if idx > -1 then ole.DoVerb(idx) else ole.DoVerb(0); result := true; ole.Refresh; except result := false;end; end; end; end; procedure TOleObject.draw(DEngine: TPCDrawEngine; isGrayed: Boolean); var acolor,bcolor : Tcolor; points:Array of TPoint; dx,dy: Double; w,h: extended; fCanvas:TMetaFileCanvas; begin if DrawStyle = dsTrace then begin inherited; exit; end; if assigned(ole) and assigned(owner) and assigned(metafile) then begin w := GetLineLenght(ap1,ap2); h := GetLineLenght(ap1,ap4); Metafile.Height := round(h * 4)+1; Metafile.Width := round(w * 4)+1; fCanvas := TMetafileCanvas.Create(Metafile, 0); DEngine.DrawOleToCanvas(ole,1,1,Metafile.Width-3,Metafile.Height-3,fCanvas,false); fCanvas.Free; DEngine.DrawMetafile(ap1,ap2,ap3,ap4,clWhite,0,ord(psClear),Metafile,true,RegHandle); //Tolik if RegHandle <> 0 then begin GetRegObject; if TBrushStyle(brs) <> bsClear then RegObject.CheckPointByRects := true; deleteObject(RegHandle); RegHandle := 0; end; // end; end; class function TOleObject.CreateFromShadow(aOwner: TComponent; LHandle: Integer; Shadow: TFigure): TFigure; var cad: TPCDrawing; begin cad := TPCDrawing(aOwner); Result := TOleObject.create(shadow.ap1.x,shadow.ap1.y, shadow.ap3.x,shadow.ap3.y, cad.DefaultPenWidth, ord(cad.DefaultPenStyle), cad.DefaultPenColor, ord(cad.DefaultBrushStyle), cad.DefaultBrushColor, LHandle, mydsNormal,aOwner); end; function TOleObject.isPointIn(x,y:Double): boolean; begin result := inherited isPointIn(x,y); if result then exit; result := IsPointInRegion(x,y); //Tolik Result := IsPointInRegionByRegObj(x,y); // end; Procedure TOleObject.Rotate(aAngle: Double; cPoint: TDoublePoint); begin if OSVersion.dwPlatformId = VER_PLATFORM_WIN32_NT then inherited; end; Procedure TOleObject.Mirror(Point1,Point2: TDoublePoint); begin if OSVersion.dwPlatformId = VER_PLATFORM_WIN32_NT then inherited; end; Destructor TOleObject.Destroy; begin if assigned(ole) then ole.Free; if assigned(metafile) then metafile.free; inherited destroy; end; procedure TOLEObject.WriteToStream(Stream: TStream); var xStream : TMemoryStream; xSize: integer; xCode: Byte; begin inherited; if (ole.State <> osEmpty) then begin xStream := TMemoryStream.Create; ole.SaveToStream(xStream); xSize := xStream.Size; xStream.Position := 0; WriteStreamField(150,Stream,xStream); xStream.Free; end; end; procedure TOLEObject.SetPropertyFromStream(xCode: Byte; data: pointer; size: integer); var mStr:TMemoryStream; begin Case xcode of 150: begin mStr := TMemoryStream.Create; mStr.Write(pByte(data)^,size); mStr.Position := 0; ole.LoadFromStream(mStr); mStr.Free; end; end; end; function TOleObject.duplicate: TFigure; var Res: TOleObject; xStream: TmemoryStream; begin res := TOleObject.create( originalpoints[1].x, originalpoints[1].y, originalpoints[3].x, originalpoints[3].y, width, style, color, brs, brc, LayerHandle, DrawStyle,Owner); res.actualpoints[1] := actualpoints[1]; res.actualpoints[2] := actualpoints[2]; res.actualpoints[3] := actualpoints[3]; res.actualpoints[4] := actualpoints[4]; res.originalpoints[1] := originalpoints[1]; res.originalpoints[2] := originalpoints[2]; res.originalpoints[3] := originalpoints[3]; res.originalpoints[4] := originalpoints[4]; xStream := TMemoryStream.Create; ole.SaveToStream(xStream); xStream.Position := 0; res.ole.LoadFromStream(xStream); xStream.Free; res.AngleToPoint := AngleToPoint; res.RotPoint := RotPoint; result := res; end; procedure TOleObject.DrawFigureGuides(DEngine: TPCDrawEngine); var points: TDoublePointArr; begin inherited; if DrawStyle = dsTrace then Exit; SetLength(points,4); points[0] := ap1; points[1] := ap2; points[2] := ap3; points[3] := ap4; DEngine.canvas.pen.mode := pmCopy; DEngine.drawpolygon(points,clRed,1,1,0,ord(bsClear),RegHandle); // Tolik 24/05/2019-- SetLength(Points, 0); //Tolik if RegHandle <> 0 then begin GetRegObject; if TBrushStyle(brs) <> bsClear then RegObject.CheckPointByRects := true; deleteObject(RegHandle); RegHandle := 0; end; // end; function TOLEObject.GetClassName: String; begin result := 'OLEObject'; end; { TMathGraph } constructor TMathGraph.create(aX1, aY1, aX2, aY2:Double; w, s, c, abrs, abrc, LHandle: Integer; aDrawStyle: TDrawStyle; aOwner: TComponent); begin inherited; originalpoints[5] := MPoint(ap1,ap3); actualpoints[5] := originalpoints[5]; end; class function TMathGraph.ShadowType:TShadowType; begin result := stRectangle; end; Procedure TMathGraph.SetOriginToCenter; begin originalpoints[5] := MPoint(ap1,ap3); actualpoints[5] := MPoint(ap1,ap3); orgCenter := true; end; procedure TMathGraph.Initialize; begin inherited; pointcount := 5; source := ''; Source := 'Sin(x)'; UnitSize := 8; BorderColor := Color; BorderStyle := Style; BorderWidth := Width; AxisColor := Color; AxisStyle := Style; AxisWidth := Width; OrgCenter := True; ScaleStyle := gsBoth; PolarScale := False; ScaleColor := Color; NumStep := 1; end; function TMathGraph.CreateModification: TFigure; var res: TMathGraph; begin res := TMathGraph.create(ap1.x,ap1.y, ap3.x,ap3.y, 1,1,clLime,1,clWhite,0,dsTrace,nil); res.actualpoints[1] := ap1; res.actualpoints[2] := ap2; res.actualpoints[3] := ap3; res.actualpoints[4] := ap4; res.actualpoints[5] := actualpoints[5]; res.RotPoint := RotPoint; CreateModification := res; end; destructor TMathGraph.Destroy; begin inherited; end; procedure TMathGraph.draw(DEngine: TPCDrawEngine; isGrayed: Boolean); var points: TDoublePointArr; aColor,bColor: integer; dNum,dTick: Boolean; ap5: TDoublePoint; begin if DrawStyle = dsTrace then DEngine.Canvas.Pen.Mode := pmXor else DEngine.Canvas.Pen.Mode := pmCopy; ap5 := actualpoints[5]; acolor := BorderColor; bColor := brc; if (isGrayed) then begin acolor := TPCDrawing(Owner).FGrayedColor; //06.08.2012 GrayedColor; bcolor := TPCDrawing(Owner).FGrayedColor; //06.08.2012 GrayedColor; end; if (aColor = -255) and (LayerHandle <> 0) then begin aColor := TLayer(LayerHandle).PenColor; end; if (bColor = -255) and (LayerHandle <> 0) then begin bColor := TLayer(LayerHandle).BrushColor; end; GetPointArray(points,4); DEngine.drawpolygon(points,acolor,BorderWidth,BorderStyle,bcolor,brs,RegHandle); acolor := AxisColor; if (isGrayed) then acolor := TPCDrawing(Owner).FGrayedColor; //06.08.2012 GrayedColor; DEngine.drawline(ap1.x,ap5.y,ap2.x,ap5.y,acolor,AxisWidth,AxisStyle,0); DEngine.drawline(ap5.x,ap1.y,ap5.x,ap3.y,acolor,AxisWidth,AxisStyle,0); if (drawStyle = mydsNormal) and (source <> '') then begin acolor := color; if (isGrayed) then acolor := TPCDrawing(Owner).FGrayedColor; //06.08.2012 GrayedColor; dNum := False; dTick := False; if ScaleStyle = gsNumbers then dNum := True else if ScaleStyle = gsTick then dTick := True else if ScaleStyle = gsBoth then begin dNum := True; dTick := True; end; Dengine.DrawMathGraph(DoubleRect(ap1.x,ap1.y,ap3.x,ap3.y),ap5.x,ap5.y,acolor, width,style,ScaleColor,UnitSize,Source,dTick,dNum,PolarScale,NumStep); end; //Tolik 24/05/2019 -- SetLength(Points, 0); // //Tolik if RegHandle <> 0 then begin GetRegObject; if TBrushStyle(brs) <> bsClear then RegObject.CheckPointByRects := true; deleteObject(RegHandle); RegHandle := 0; end; // end; procedure TMathGraph.DrawFigureGuides(DEngine: TPCDrawEngine); begin inherited; end; function TMathGraph.duplicate: TFigure; begin end; function TMathGraph.edit: Boolean; var enterstr: string; begin Result := False; EnterStr := Source; // if InputQuery(capMathGraphSource, msEnterFunction , EnterStr) then if InputQuery(cDrawObjects_Mes9, cDrawObjects_Mes10, EnterStr) then begin Source := EnterStr; result := true; end; end; function TMathGraph.isPointIn(x, y: Double): boolean; begin result := inherited isPointIn(x,y); if result then exit; result := isPointInRegion(x,y); //Tolik Result := IsPointInRegionByRegObj(x,y); // end; procedure TMathGraph.mirror(Point1, Point2: TDoublePoint); begin // No mirror end; procedure TMathGraph.rotate(aAngle: Double; cPoint: TDoublePoint); begin //No Rotate end; class function TMathGraph.CreateFromShadow(aOwner: TComponent; LHandle: Integer; Shadow: TFigure): TFigure; var cad: TPCDrawing; begin cad := TPCDrawing(aOwner); Result := TMathGraph.create(shadow.ap1.x,shadow.ap1.y, shadow.ap3.x,shadow.ap3.y, cad.DefaultPenWidth, ord(cad.DefaultPenStyle), cad.DefaultPenColor, ord(cad.DefaultBrushStyle), cad.DefaultBrushColor, LHandle, mydsNormal,aOwner); end; procedure TMathGraph.WriteToStream(Stream: TStream); var xByte: Byte; xInt: Integer; xStr: String; xDbl: Double; begin inherited; // Tolik 22/11/2019 -- //xByte := brs; if brs = -1 then xByte := 255 else xByte := LoByte(LoWord(brs)); // WriteField(90,Stream,xByte,1); // Tolik 22/11/2019 -- if AxisStyle = -1 then xByte := 255 else xByte := LoByte(LoWord(AxisStyle)); //xByte := AxisStyle; // WriteField(91,Stream,xByte,1); if BorderStyle = -1 then xByte := 255 else xByte := LoByte(LoWord(BorderStyle)); // WriteField(92,Stream,xByte,1); xByte := ord(ScaleStyle); WriteField(93,Stream,xByte,1); xInt := brc; WriteField(20,Stream,xInt,4); xInt := AxisColor; WriteField(21,Stream,xInt,4); xInt := BorderColor; WriteField(22,Stream,xInt,4); xInt := AxisWidth; WriteField(23,Stream,xInt,4); xInt := BorderWidth; WriteField(24,Stream,xInt,4); xDbl := UnitSize; WriteField(220,Stream,xDbl,8); xInt := ScaleColor; WriteField(26,Stream,xInt,4); xInt := NumStep; WriteField(27,Stream,xInt,4); xStr := Source; WriteStrField(180,Stream,xStr); end; procedure TMathGraph.SetPropertyFromStream(xCode: Byte; data: pointer; size: integer); begin Case xcode of 90: begin if pByte(data)^ = 255 then brs := -1 else brs := pByte(data)^; end; 91: begin if pByte(data)^ = 255 then AxisStyle := -1 else AxisStyle := pByte(data)^; end; 92: begin if pByte(data)^ = 255 then BorderStyle := -1 else BorderStyle := pByte(data)^; end; 93: ScaleStyle := TMGScaleStyle(pByte(data)^); 20: brc := pInt(data)^; 21: AxisColor := pInt(data)^; 22: BorderColor := pInt(data)^; 23: AxisWidth := pInt(data)^; 24: BorderWidth := pInt(data)^; 25: UnitSize := pInt(data)^/10; 26: ScaleColor := pInt(data)^; 27: NumStep := pInt(data)^; 180: Source := String(pchar(data)); 220: UnitSize := pDouble(data)^; end; end; procedure TMathGraph.GetModPoints(ModList: TMyList); var CControl: TPCDrawing; ap5,MT,MR,MB,ML : TDoublePoint; begin CControl := TPCDrawing(Owner); ap5 := actualpoints[5]; MT := MPoint(ap1,ap2); MR := MPoint(ap2,ap3); MB := MPoint(ap3,ap4); ML := MPoint(ap4,ap1); ModList.Add(CControl.RegisterModPoint(self,ptRectPoint,ptRect,clBlue,PointDim,ap1.x,ap1.y,1)); ModList.Add(CControl.RegisterModPoint(self,ptRectPoint,ptRect,clBlue,PointDim,MT.x,MT.y,2)); ModList.Add(CControl.RegisterModPoint(self,ptRectPoint,ptRect,clBlue,PointDim,ap2.x,ap2.y,3)); ModList.Add(CControl.RegisterModPoint(self,ptRectPoint,ptRect,clBlue,PointDim,MR.x,MR.y,4)); ModList.Add(CControl.RegisterModPoint(self,ptRectPoint,ptRect,clBlue,PointDim,ap3.x,ap3.y,5)); ModList.Add(CControl.RegisterModPoint(self,ptRectPoint,ptRect,clBlue,PointDim,MB.x,MB.y,6)); ModList.Add(CControl.RegisterModPoint(self,ptRectPoint,ptRect,clBlue,PointDim,ap4.x,ap4.y,7)); ModList.Add(CControl.RegisterModPoint(self,ptRectPoint,ptRect,clBlue,PointDim,ML.x,ML.y,8)); ModList.Add(CControl.RegisterModPoint(self,ptRectPoint,ptCircle,clRed,PointDim-1,ap5.x,ap5.y,9)); end; function TMathGraph.TraceModification(CadControl: Pointer;mp: TModPoint;TraceFigure:TFigure; x,y: Double;Shift: TShiftState): boolean; begin inherited TraceModification(CadControl,mp,TraceFigure,x,y,shift); if mp.SeqNbr = 9 then begin TraceFigure.ActualPoints[5] := DoublePoint(x,y); OrgCenter := False; end; if OrgCenter then TmathGraph(TraceFigure).SetOriginToCenter; end; procedure TMathGraph.UpdateMenu(var popMenu: TPopUpMenu; var sIndex: Integer); var mnItem:TMenuItem; begin menuIndex := sIndex; mnItem := TMenuItem.Create(PopMenu); mnItem.Caption := fmSetOrigin; mnItem.Tag := sIndex; PopMenu.Items.Add(mnItem); mnItem := TMenuItem.Create(PopMenu); mnItem.Caption := csZoomIn; mnItem.Tag := sIndex+1; PopMenu.Items.Add(mnItem); mnItem := TMenuItem.Create(PopMenu); mnItem.Caption := csZoomOut; mnItem.Tag := sIndex+2; PopMenu.Items.Add(mnItem); sIndex := sIndex+3; end; procedure TMathGraph.MenuClicked(CommandId: integer); var mnIdx: integer; begin mnIdx := CommandId-MenuIndex; case mnIdx of 0: SetOriginToCenter; 1: ZoomIn; 2: ZoomOut; end; end; Procedure TMathGraph.ZoomIn; begin UnitSize := UnitSize+30; end; Procedure TMathGraph.ZoomOut; begin UnitSize := UnitSize-30; if UnitSize < 10 then UnitSize := 10; end; (* procedure TMathGraph.RegisterToPropertyPage; var fPPage: TObjectInspector; a: integer; strs: TStringList; begin if owner <> nil then begin fPPage := TPCDrawing(Owner).fPPage; fPpObject := fPPage.registerObject(name,'MathGraph',self); fPpObject.ChangeEvent := FigurePropertyChanged; props[1] := TStringProperty.create('Name',false,name); props[2] := TIntegerProperty.create('Handle',true,Handle); props[3] := TStringProperty.create('Source',false,source); props[4] := TExtendedProperty.create('UnitSize',false,UnitSize); props[5] := TLineStyleProperty.create('GraphStyle',false,style); props[6] := TLineWidthProperty.create('GraphWidth',false,width); props[7] := TColorProperty.create('GraphColor',false,Color); props[8] := TLineStyleProperty.create('BorderStyle',false,style); props[9] := TLineWidthProperty.create('BorderWidth',false,width); props[10] := TColorProperty.create('BorderColor',false,Color); props[11] := TLineStyleProperty.create('AxisStyle',false,style); props[12] := TLineWidthProperty.create('AxisWidth',false,width); props[13] := TColorProperty.create('AxisColor',false,Color); props[14] := TBrushStyleProperty.create('FillStyle',false,brs); props[15] := TColorProperty.create('FillColor',false,brc); props[16] := TColorProperty.create('ScaleColor',false,Color); props[17] := TIntegerProperty.create('NumberStep',false,NumStep); strs := TStringList.create; strs.add ( 'None'); strs.add ( 'Ticks'); strs.add ( 'Numbers'); strs.add ( 'Both'); props[18] := TEnumProperty.create('ScaleStyle',false,strs,ord(ScaleStyle)); props[19] := TBoolProperty.create('PolarScale',false,PolarScale); for a := 1 to 19 do fPpObject.AddProperty(props[a]); Strs.Free; end; end; *) function TMathGraph.GetClassName: String; begin result := 'MathGraph'; end; { TWMFObject } constructor TWMFObject.create(X, Y:Double;fName:string; LHandle: Integer; aDrawStyle: TDrawStyle; aOwner: TComponent); var Picw,PicH: Double; begin inherited create(LHandle,aDrawStyle,aOwner); initialize; originalpoints[1] := DoublePoint(x,y); originalpoints[2] := DoublePoint(x,y); originalpoints[3] := DoublePoint(x,y); originalpoints[4] := DoublePoint(x,y); actualpoints[1] := originalpoints[1]; actualpoints[2] := originalpoints[2]; actualpoints[3] := originalpoints[3]; actualpoints[4] := originalpoints[4]; if DrawStyle = mydsNormal then begin PictureName := extractFileName(fName); Metafile.loadfromfile(fName); PicW := Metafile.mmwidth/100; if horzZero = 1 then PicW := -PicW; PicH := Metafile.mmHeight/100; if vertZero = 1 then PicH := -PicH; originalpoints[2] := DoublePoint(x+PicW,y); originalpoints[3] := DoublePoint(x+PicW,y-PicH); originalpoints[4] := DoublePoint(x,y-PicH); actualpoints[2] := originalpoints[2]; actualpoints[3] := originalpoints[3]; actualpoints[4] := originalpoints[4]; end; end; destructor TWMFObject.Destroy; begin if assigned(metafile) then metafile.free; inherited destroy; end; procedure TWMFObject.draw(DEngine: TPCDrawEngine; isGrayed: Boolean); var acolor,bcolor : Tcolor; points: TDoublePointArr; cad: TPCDrawing; dx,dy: Double; w,h: extended; fModes: TFlipModes; begin acolor := color; bColor := brc; if (aColor = -255) and (LayerHandle <> 0) then begin aColor := TLayer(LayerHandle).PenColor; end; if (bColor = -255) and (LayerHandle <> 0) then begin bColor := TLayer(LayerHandle).BrushColor; end; if (isGrayed) then begin acolor := TPCDrawing(Owner).FGrayedColor; //06.08.2012 GrayedColor; bcolor := TPCDrawing(Owner).FGrayedColor; //06.08.2012 GrayedColor; end; if DrawStyle = dsTrace then DEngine.Canvas.Pen.Mode := pmXor else DEngine.Canvas.Pen.Mode := pmCopy; if assigned(metafile) then begin GetPointArray(Points); if (style <> ord(psClear)) or (brs <> ord(bsClear)) then DEngine.drawpolygon(points,acolor,width,style,bcolor,brs,Reghandle); DEngine.DrawMetafile(ap1,ap2,ap3,ap4,clWhite,0,ord(psClear),Metafile,true,Reghandle); end; //Tolik 24/05/2019 -- SetLength(Points, 0); // //Tolik if RegHandle <> 0 then begin GetRegObject; if TBrushStyle(brs) <> bsClear then RegObject.CheckPointByRects := true; deleteObject(RegHandle); RegHandle := 0; end; // end; function TWMFObject.duplicate: TFigure; var res: TWMFObject; i: integer; TempFig: TFigure; TempPath: string; //Buffer: array[0..1023] of Char; Buffer: array[0..MAX_PATH] of Char; begin // Tolik 17/05/2019 - - // SetString(TempPath, Buffer, GetTempPath(Sizeof(Buffer) - 1, Buffer)); SetString(TempPath, Buffer, GetTempPath(MAX_PATH, @Buffer)); // делать отак, а то ебанет объект в памяти...или чего-нибудь другое...нужное // MetaFile.SaveToFile(TempPath + 'tempWMF.bmp'); PictureName := TempPath + 'tempWMF.bmp'; res := TWMFObject.create(originalpoints[1].x, originalpoints[1].y, PictureName, LayerHandle, DrawStyle, Owner); res.angle := angle; res.actualpoints[1] := actualpoints[1]; res.originalpoints[1] := originalpoints[1]; res.actualpoints[2] := actualpoints[2]; res.originalpoints[2] := originalpoints[2]; res.actualpoints[3] := actualpoints[3]; res.originalpoints[3] := originalpoints[3]; res.actualpoints[4] := actualpoints[4]; res.originalpoints[4] := originalpoints[4]; res.Metafile.Assign(Metafile); res.rotPoint := rotPoint; res.AngleToPoint := AngleToPoint; result := res; end; procedure TWMFObject.Initialize; begin inherited; pointcount := 4; //if owner <> nil then begin MetaFile:= TMetaFile.Create; Metafile.Enhanced := True; //end; DiagonalScale := True; width := 1; color := clBlack; brc := clSilver; brs := 1; Style := 5; end; function TWMFObject.isPointIn(x, y: double): boolean; begin result := inherited isPointIn(x,y); if result then exit; result := IsPointInRegion(x,y); //Tolik Result := IsPointInRegionByRegObj(x,y); // end; procedure TWMFObject.mirror(Point1, Point2: TDoublePoint); begin if OSVersion.dwPlatformId = VER_PLATFORM_WIN32_NT then inherited; end; procedure TWMFObject.Rotate(aAngle: Double; cPoint: TDoublePoint); begin if OSVersion.dwPlatformId = VER_PLATFORM_WIN32_NT then inherited; end; procedure TWMFObject.SetPropertyFromStream(xCode: Byte; data: pointer; size: integer); var mstr:TMemoryStream; begin Case xcode of 20: brc := pInt(data)^; 90: begin if pByte(data)^ = 255 then brs := -1 else brs := pByte(data)^; end; 150: begin mStr := TMemoryStream.Create; mStr.Write(pByte(data)^,size); mStr.Position := 0; Metafile.LoadFromStream(mStr); mStr.Free; end; 180: Picturename := String(pchar(data)); end; end; class function TWMFObject.ShadowType: TShadowType; begin result := stRectangle; end; procedure TWMFObject.WriteToStream(Stream: TStream); var xByte,xCode,xZero: Byte; xInt,xSize: Integer; xStr: String; xStream: TMemoryStream; begin inherited; xZero := 0; xStr := PictureName; WriteStrField(180,Stream,xStr); // if brs = -1 then xByte := 255 else xByte := LoByte(LoWord(brs)); // WriteField(90,Stream,xByte,1); xInt := brc; WriteField(20,Stream,xInt,4); xStream := TMemoryStream.Create; Metafile.SaveToStream(xStream); xSize := xStream.Size; WriteStreamField(150,Stream,xStream); xStream.Free; end; class function TWMFObject.CreateFromShadow(aOwner: TComponent; LHandle: Integer; Shadow: TFigure): TFigure; var OPD : TOpenPictureDialog; x,y: double; begin result := nil; OPD := TOpenPictureDialog.Create(nil); OPD.Filter := 'Windows Metafiles (*.emf;*.wmf)|*.emf;*.wmf'; x := shadow.ap1.x; y := shadow.ap1.y; if OPD.Execute then begin result := TWMFObject.create(x,y,OPD.fileName,Lhandle,mydsNormal,aOwner); end; end; class function TWmfObject.IsOneClick: Boolean; begin // normally a rectangle shape is formed with two clicks, // so we should define that this figure will be created after the first click result := true; end; constructor TWMFObject.createEx(x, y: Double; mf: Tmetafile; LHandle: Integer; aDrawStyle: TDrawStyle; aOwner: TComponent); var Picw,PicH: Double; begin inherited create(LHandle,aDrawStyle,aOwner); initialize; originalpoints[1] := DoublePoint(x,y); originalpoints[2] := DoublePoint(x,y); originalpoints[3] := DoublePoint(x,y); originalpoints[4] := DoublePoint(x,y); actualpoints[1] := originalpoints[1]; actualpoints[2] := originalpoints[2]; actualpoints[3] := originalpoints[3]; actualpoints[4] := originalpoints[4]; if DrawStyle = mydsNormal then begin PictureName := ''; Metafile.Assign(mf); PicW := Metafile.mmwidth/100; if horzZero = 1 then PicW := -PicW; PicH := Metafile.mmHeight/100; if vertZero = 1 then PicH := -PicH; originalpoints[2] := DoublePoint(x+PicW,y); originalpoints[3] := DoublePoint(x+PicW,y-PicH); originalpoints[4] := DoublePoint(x,y-PicH); actualpoints[2] := originalpoints[2]; actualpoints[3] := originalpoints[3]; actualpoints[4] := originalpoints[4]; end; end; procedure TWMFObject.UpdateMenu(var PopMenu: TPopUpMenu; var sIndex: integer); var mnItem,mnSub: TMenuItem; begin menuIndex := sIndex; mnItem := TMenuItem.Create(PopMenu); mnItem.Tag := sIndex; mnItem.Caption := fmCloneAsEdit; PopMenu.Items.Add(mnItem); sIndex := SIndex+1; end; procedure TWMFObject.MenuClicked(CommandId: integer); var mnIdx: integer; begin mnIdx := commandId-MenuIndex; case mnIdx of 0: CloneAsEditObjects; end; end; procedure TWMFObject.CloneAsEditObjects; var Cad:TPCDrawing; begin if assigned(Owner) then begin Cad := TPCDrawing(Owner); Cad.ImportMetafile(Cad.ActiveLayer,-1,-1,Metafile,True); end; end; function TWMFObject.GetClassName: String; begin result := 'WMFObject'; end; { TDimLine } constructor TDimLine.Create(LHandle: Integer; aDrawStyle: TDrawStyle; aOwner: TComponent); begin inherited Create(LHandle,aDrawStyle,aOwner); initialize; end; class function TDimLine.CreateFromShadow(aOwner: TComponent; LHandle: Integer; Shadow: TFigure): TFigure; begin end; class function TDimLine.CreateShadow(x, y: Double): TFigure; begin result := TDimLine.Create(0,dsTrace,nil); result.ActualPoints[1] := DoublePoint(x,y); end; function TDimLine.Duplicate: TFigure; begin end; Function TDimLine.Edit:Boolean; var EnterStr: string; dist, distx, disty: double; begin distx := (abs(ap1.x - ap2.x) * MapScale) / 1000; distx := round(distx * 100) / 100; disty := (abs(ap1.y - ap2.y) * MapScale) / 1000; disty := round(disty * 100) / 100; dist := max(distx, disty); DLabel := FormatFloat(ffMask, dist); Result := False; EnterStr := DLabel; // EnterStr := FloatToStr(MetreToUOM(StrToFloat_My(EnterStr))); if InputQuery(cDrawObjects_Mes4, cDrawObjects_Mes5, EnterStr) then begin // EnterStr := FloatToStr(UOMToMetre(StrToFloat_My(EnterStr))); DLabel := EnterStr; AutoText := False; Modified := True; result := true; end; end; procedure TDimLine.Getbounds(var figMaxX, figMaxY, figMinX, figMinY: Double); begin end; procedure TDimLine.GetModPoints(ModList: TMyList); var CControl: TPCDrawing; begin CControl := TPCDrawing(Owner); ModList.Add(CControl.RegisterModPoint(Self,ptLineEnd,ptRect,clBlue,pointDim,ap1.x,ap1.y,1)); ModList.Add(CControl.RegisterModPoint(Self,ptLineEnd,ptRect,clBlue,pointDim,ap2.x,ap2.y,2)); if PointCount > 2 then ModList.Add(CControl.RegisterModPoint(Self,ptLineEnd,ptRect,clBlue,pointDim,ap3.x,ap3.y,3)); end; procedure TDimLine.Initialize; begin inherited; PointCount := 3; Autotext := True; Dlabel := ''; Prefix := ''; Suffix := ''; TextPos := tpAbove; MapScale := 1; if assigned(owner) then begin MapScale := TPCDrawing(Owner).MapScale; end; TextFont := 'Courier New'; TextHeight:= 4; TextBold:= False; TextItalic:= False; EndType := etRow; TextColor := clBlack; Dlabel := 'Label'; end; function TDimLine.IsPointIn(x, y: Double): boolean; begin result := false; end; function TDimLine.ModifyTextAndFont(mm: TModifyMode; valueI: Double; valueS: string; valueSt: TFontStyles; ValueB: Boolean): Boolean; begin result := true; if mm = mmFontName then begin TextFont := ValueS; modified := true; end else if mm = mmFontSize then begin TextHeight := valueI; modified := true; end else if mm = mmFontColor then begin TextColor := Round(valueI); end else if mm = mmFontBold then begin TextBold := ValueB; modified := true; end else if mm = mmFontItalic then begin TextItalic := ValueB; modified := true; end; end; // Tolik 04/03/2020 -- Function TDimLine.DefineHStyle(currStyle: THDimLabelStyle): THDimLabelStyle; // переопределить положение текста, если длина текста превышает длину самой линии var MetaFile: TMetafile; FCanvas: TMetafileCanvas; TxtHeight, Txtwidth, LineWidth: Double; FontRecord : TLogFont; TM : TTextMetric; begin Result := currStyle; if GCadForm <> nil then begin MetaFile := TMetafile.Create; FCanvas := TMetafileCanvas.Create(Metafile, 0); FCanvas.Font.Name := TextFont; GetObject(FCanvas.Font.Handle,sizeof(FontRecord),Addr(FontRecord)); TxtHeight := TextHeight * GCadForm.PCad.DotsPerMil * convertRatio; FontRecord.lfHeight := Round(TxtHeight); FCanvas.Font.handle := CreateFontIndirect(FontRecord); GetTextMetrics(FCanvas.Handle,TM); GetObject(FCanvas.Font.Handle,sizeof(FontRecord),Addr(FontRecord)); FontRecord.lfWidth := round(TM.tmAveCharWidth*0.9); FCanvas.Font.handle := CreateFontIndirect(FontRecord); TxtWidth := FCanvas.TextWidth(DLabel + GetUOMString(GCurrProjUnitOfMeasure)); { FCanvas.Font.Height := Round(TextHeight) + 1; TxtWidth := FCanvas.TextWidth(DLabel + GetUOMString(GCurrProjUnitOfMeasure));} LineWidth := ap1.x - ap2.x; if LineWidth < 0 then LineWidth := LineWidth * (-1); LineWidth := LineWidth * GCadForm.PCad.DotsPerMil * convertRatio; if CompareValue(TxtWidth, LineWidth) > 0 then Result := hlsRight; FCanvas.Free; MetaFile.Free; end; end; Function TDimLine.DefineVStyle(currStyle: TVDimLabelStyle): TVDimLabelStyle; // переопределить положение текста, если длина текста превышает длину самой линии var MetaFile: TMetafile; FCanvas: TMetafileCanvas; TxtHeight, Txtwidth, LineWidth: Double; FontRecord : TLogFont; TM : TTextMetric; begin //Result := currStyle; Result := vlsInner; MetaFile := TMetafile.Create; FCanvas := TMetafileCanvas.Create(Metafile, 0); FCanvas.Font.Name := TextFont; {FCanvas.Font.Height := Round(TextHeight); TxtWidth := FCanvas.TextWidth(DLabel + GetUOMString(GCurrProjUnitOfMeasure));} GetObject(FCanvas.Font.Handle,sizeof(FontRecord),Addr(FontRecord)); TxtHeight := TextHeight * GCadForm.PCad.DotsPerMil * convertRatio; FontRecord.lfHeight := Round(TxtHeight); FCanvas.Font.handle := CreateFontIndirect(FontRecord); GetTextMetrics(FCanvas.Handle,TM); GetObject(FCanvas.Font.Handle,sizeof(FontRecord),Addr(FontRecord)); FontRecord.lfWidth := round(TM.tmAveCharWidth*0.9); FCanvas.Font.handle := CreateFontIndirect(FontRecord); TxtWidth := FCanvas.TextWidth(DLabel + GetUOMString(GCurrProjUnitOfMeasure)); LineWidth := ap1.y - ap2.y; if LineWidth < 0 then LineWidth := LineWidth * (-1); LineWidth := LineWidth * GCadForm.PCad.DotsPerMil * convertRatio; if CompareValue(TxtWidth, LineWidth) > 0 then //Result := vlsTopRight; Result := vlsTop; FCanvas.Free; MetaFile.Free; end; // procedure TDimLine.SetPropertyFromStream(xCode: Byte; data: pointer; size: integer); begin inherited; end; function TDimLine.ShadowClick(ClickIndex:Integer;x,y:Double): Boolean; begin result := false; ActualPoints[ClickIndex] := DoublePoint(x,y); if ClickIndex = 3 then result := true; end; function TDimLine.ShadowTrace(ClickIndex:Integer;x,y:Double): Boolean; begin if ClickIndex = 1 then begin ActualPoints[2] := DoublePoint(x,y); ActualPoints[3] := DoublePoint(x,y); end else if ClickIndex = 2 then begin ActualPoints[3] := DoublePoint(x,y); end; result := true; end; procedure TDimLine.WriteToStream(Stream: TStream); begin inherited; end; { THDimLine } class function THDimLine.CreateFromShadow(aOwner: TComponent; LHandle: Integer; Shadow: TFigure): TFigure; var x3,y3: double; begin result := THDimLine.Create(LHandle,mydsNormal,aOwner); result.ActualPoints[1] := Shadow.ap1; result.ActualPoints[2] := Shadow.ap2; y3 := Shadow.ap3.y; x3 := (Shadow.ap1.x+Shadow.ap2.x) / 2; result.ActualPoints[3] := DoublePoint(x3,y3); THDimLine(result).LStyle := THDimLine(Shadow).Lstyle; // THDimLine(result).EndType := THDimLine(Shadow).EndType; if GCadForm.FDimLinesType = dlt_None then THDimLine(result).EndType := etClear; if GCadForm.FDimLinesType = dlt_Row then THDimLine(result).EndType := etRow; if GCadForm.FDimLinesType = dlt_Stroke then THDimLine(result).EndType := etNick; end; function THDimLine.CreateModification: TFigure; begin result := THDimLine.Create(0,dsTrace,nil); result.ActualPoints[1] := ap1; result.ActualPoints[2] := ap2; result.ActualPoints[3] := ap3; result.color := clLime; result.RotPoint := RotPoint; THDimLine(result).EndType := EndType; THDimLine(result).Lstyle := Lstyle; end; class function THDimLine.CreateShadow(x, y: Double): TFigure; begin result := THDimLine.Create(0,dsTrace,nil); result.ActualPoints[1] := DoublePoint(x,y); result.ActualPoints[2] := DoublePoint(x,y); result.ActualPoints[3] := DoublePoint(x,y); result.color := clLime; THDimLine(result).Lstyle := hlsInner; end; procedure THDimLine.Draw(DEngine: TPCDrawEngine; isGrayed: Boolean); var acolor : Tcolor; p3 : TDoublepoint; x3,y3,tx,ty: Double; text:string; dist: double; l: integer; st: TFontStyles; begin aColor := Color; if (aColor = -255) and (LayerHandle <> 0) then begin aColor := TLayer(LayerHandle).PenColor; end; if isGrayed then acolor := TPCDrawing(Owner).FGrayedColor; //06.08.2012 GrayedColor; if DrawStyle = dsTrace then DEngine.Canvas.pen.mode := pmXor else DEngine.canvas.pen.mode := pmCopy; if DrawStyle = dsTrace then RegHandle := 1; y3 := ap3.y; x3 := (ap1.x + ap2.x) / 2; p3 := DoublePoint(x3, y3); text := ''; if DrawStyle = mydsNormal then begin if autotext then begin if assigned(owner) then MapScale := TPCDrawing(Owner).MapScale; dist := (abs(ap1.x - ap2.x) * MapScale) / 1000; if self is TSCSHDimLine then dist := round(dist * 10000) / 10000 else dist := round(dist * 100) / 100; dist := MetreToUOM(dist); if self is TSCSHDimLine then text := FormatFloat(ffMask + '#', dist)+ GetUOMString(GCurrProjUnitOfMeasure) else text := FormatFloat(ffMask, dist)+ GetUOMString(GCurrProjUnitOfMeasure); text := Prefix + text + Suffix; end else text := DLabel; caption := text; end; st := []; if TextBold then st := st + [fsBold]; if TextItalic then st := st + [fsItalic]; DEngine.DrawHDim(ap1,ap2,p3,Text,TextFont,st,aColor,TextColor,TextHeight,LStyle, TextPos,EndType,RegHandle); //Tolik if RegHandle > 1 then begin GetRegObject; if (TBrushStyle(brs) <> bsClear) then RegObject.CheckPointByRects := true; deleteObject(RegHandle); RegHandle := 0; end; // end; function THDimLine.Duplicate: TFigure; var res: THDimLine; begin res := THDimLine.Create(LayerHandle,DrawStyle,Owner); res.DLabel := Dlabel; res.Prefix := Prefix; res.Suffix := Suffix; res.AutoText := AutoText; res.TextPos := TextPos; res.TextFont := TextFont; res.TextHeight := TextHeight; res.TextBold := TextBold; res.TextItalic := TextItalic; res.EndType := EndType; res.MapScale := MapScale; res.LStyle := Lstyle; CopyProperties(res); result := res; end; function THDimLine.Edit: Boolean; var EnterStr: string; dist, distx, disty: double; begin if autotext then begin distx := (abs(ap1.x - ap2.x) * MapScale) / 1000; distx := round(distx * 100) / 100; distx := MetreToUOM(distx); DLabel := FormatFloat(ffMask, distx); end; Result := False; EnterStr := DLabel; // EnterStr := FloatToStr(MetreToUOM(StrToFloat_My(EnterStr))); if InputQuery(cDrawObjects_Mes4, cDrawObjects_Mes5, EnterStr) then begin // EnterStr := FloatToStr(UOMToMetre(StrToFloat_My(EnterStr))); DLabel := EnterStr; AutoText := False; Modified := True; result := true; end; end; function THDimLine.EndModification(CadControl: Pointer; mp: TModPoint; TraceFigure: TFigure; x, y: Double; Shift: TShiftState): boolean; var x3,y3: Double; begin if mp.SeqNbr = 3 then begin x3 := (ap1.x+ap2.x) / 2; ActualPoints[3] := DoublePoint(x3,y); end else begin ActualPoints[mp.SeqNbr] := DoublePoint(x,y); x3 := (ap1.x+ap2.x) / 2; y3 := ap3.y; ActualPoints[3] := DoublePoint(x3,y3); LStyle := THDimLine(TraceFigure).LStyle; end; ResetRegion; Modified := True; LStyle := DefineHStyle(LStyle); //// Tolik 04/03/2020 -- end; procedure THDimLine.Getbounds(var figMaxX, figMaxY, figMinX, figMinY: Double); begin if regHandle = 0 then begin figMaxX := Max(ap1.x,ap2.x); figMinX := Min(ap1.x,ap2.x);; figMaxY := MaxValue([ap1.y,ap2.y,ap3.y]); figMinY := MinValue([ap1.y,ap2.y,ap3.y]); end else GetRegionBounds(figMaxX, figMaxY, figMinX,figMinY); end; function THDimLine.GetClassName: String; begin result := 'HDimLine'; end; function THDimLine.IsPointIn(x, y: Double): boolean; begin result := false; result := inherited isPointIn(x,y); if result then exit; if isPointInRegion(x,y) then result := true; //Tolik if IsPointInRegionByRegObj(x,y) then result := true; // end; procedure THDimLine.MenuClicked(CommandId: integer); var idx: integer; begin idx := commandID-menuIndex; case idx of 1: EndType := etClear; 2: EndType := etRow; 3: EndType := etDot; 4: EndType := etNick; 5: AutoText := not Autotext; 7: TextPos := tpOnLine; 8: TextPos := tpAbove; 9: TextPos := tpBelow; 11: LStyle := hlsInner; 12: LStyle := hlsLeft; 13: LStyle := hlsRight; 14: LStyle := hlsLeftTop; 15: LStyle := hlsLeftBottom; 16: LStyle := hlsRightTop; 17: LStyle := hlsRightBottom; end; ResetRegion; Modified := true; end; procedure THDimLine.Mirror(Point1, Point2: TDoublePoint); begin end; procedure THDimLine.Rotate(aAngle: Double; cPoint: TDoublePoint); begin end; procedure THDimLine.SetPropertyFromStream(xCode: Byte; data: pointer; size: integer); begin Case xcode of 90 : TextBold := ((pByte(data)^) = 1); 91 : TextItalic := ((pByte(data)^) = 1); 92 : AutoText := ((pByte(data)^) = 1); 93 : TextPos := TDimTextPos(pByte(data)^); 94 : EndType := TEndType(pByte(data)^); 95 : LStyle := THDimLabelStyle(pByte(data)^); 180: DLabel := string(pchar(data)); 181: Prefix := string(pchar(data)); 182: Suffix := string(pchar(data)); 183: TextFont := string(pchar(data)); 220: TextHeight := pDouble(data)^; end; end; function THDimLine.ShadowClick(ClickIndex:Integer; x, y: Double): Boolean; begin result := false; ActualPoints[ClickIndex] := DoublePoint(x,y); if ClickIndex = 3 then result := true; end; function THDimLine.ShadowTrace(ClickIndex:Integer; x, y:Double): Boolean; begin if ClickIndex = 1 then begin ActualPoints[2] := DoublePoint(x,y); ActualPoints[3] := DoublePoint(x,y); if abs(ActualPoints[1].x-ActualPoints[2].x) < 10 then Lstyle := hlsRight else LStyle := hlsInner; end else if ClickIndex = 2 then begin ActualPoints[3] := DoublePoint(x,y); end; result := true; end; function THDimLine.TraceModification(CadControl: Pointer; mp: TModPoint; TraceFigure: TFigure; x, y: Double; Shift: TShiftState): boolean; begin TraceFigure.ActualPoints[mp.SeqNbr] := DoublePoint(x,y); if mp.SeqNbr < 3 then begin if abs(TraceFigure.ActualPoints[1].x-TraceFigure.ActualPoints[2].x) < 10 then THDimLine(TraceFigure).LStyle := hlsRight else THDimLine(TraceFigure).Lstyle := hlsInner; end; end; procedure THDimLine.UpdateMenu(var popMenu: TPopUpMenu; var sIndex: Integer); var mnItem,mnSub: TMenuItem; begin menuIndex:= sIndex; mnItem := TMenuItem.Create(PopMenu); mnItem.Tag := sIndex; mnItem.Caption := fmEndType; PopMenu.Items.Add(mnItem); mnSub := TMenuItem.Create(PopMenu); mnSub.Caption := fmClearEnd; mnSub.Tag := sIndex+1; if EndType = etClear then mnSub.Checked := True; mnItem.Add(mnSub); mnSub := TMenuItem.Create(PopMenu); mnSub.Caption := fmRowEnd ; mnSub.Tag := sIndex+2; if EndType = etRow then mnSub.Checked := True; mnItem.Add(mnSub); mnSub := TMenuItem.Create(PopMenu); mnSub.Caption := fmDotEnd; mnSub.Tag := sIndex+3; if EndType = etDot then mnSub.Checked := True; mnItem.Add(mnSub); mnSub := TMenuItem.Create(PopMenu); mnSub.Caption := fmNickEnd; mnSub.Tag := sIndex+4; if EndType = etNick then mnSub.Checked := True; mnItem.Add(mnSub); mnItem := TMenuItem.Create(PopMenu); mnItem.Tag := sIndex+5; mnItem.Caption := fmAutoLabel ; if Autotext then mnItem.Checked := True; PopMenu.Items.Add(mnItem); mnItem := TMenuItem.Create(PopMenu); mnItem.Tag := sIndex+6; mnItem.Caption := fmTextPosition; PopMenu.Items.Add(mnItem); mnSub := TMenuItem.Create(PopMenu); mnSub.Caption := fmOnline; mnSub.Tag := sIndex+7; if textPos = tpOnline then mnSub.Checked := True; mnItem.Add(mnSub); mnSub := TMenuItem.Create(PopMenu); mnSub.Caption := fmAboveLine; mnSub.Tag := sIndex+8; if textPos = tpAbove then mnSub.Checked := True; mnItem.Add(mnSub); mnSub := TMenuItem.Create(PopMenu); mnSub.Caption := fmBelowLine; mnSub.Tag := sIndex+9; if textPos = tpBelow then mnSub.Checked := True; mnItem.Add(mnSub); mnItem := TMenuItem.Create(PopMenu); mnItem.Tag := sIndex+10; mnItem.Caption := fmLabeling; PopMenu.Items.Add(mnItem); mnSub := TMenuItem.Create(PopMenu); mnSub.Caption := fmInside ; mnSub.Tag := sIndex+11; if LStyle = hlsInner then mnSub.Checked := True; mnItem.Add(mnSub); mnSub := TMenuItem.Create(PopMenu); mnSub.Caption := fmLeft; mnSub.Tag := sIndex+12; if LStyle = hlsLeft then mnSub.Checked := True; mnItem.Add(mnSub); mnSub := TMenuItem.Create(PopMenu); mnSub.Caption := fmRight; mnSub.Tag := sIndex+13; if LStyle = hlsRight then mnSub.Checked := True; mnItem.Add(mnSub); mnSub := TMenuItem.Create(PopMenu); mnSub.Caption := fmLeftTop; mnSub.Tag := sIndex+14; if LStyle = hlsLeftTop then mnSub.Checked := True; mnItem.Add(mnSub); mnSub := TMenuItem.Create(PopMenu); mnSub.Caption := fmLeftBottom; mnSub.Tag := sIndex+15; if LStyle = hlsLeftBottom then mnSub.Checked := True; mnItem.Add(mnSub); mnSub := TMenuItem.Create(PopMenu); mnSub.Caption := fmRigthTop; mnSub.Tag := sIndex+16; if LStyle = hlsRightTop then mnSub.Checked := True; mnItem.Add(mnSub); mnSub := TMenuItem.Create(PopMenu); mnSub.Caption := fmRightBottom; mnSub.Tag := sIndex+17; if LStyle = hlsRightBottom then mnSub.Checked := True; mnItem.Add(mnSub); sIndex := sIndex+18; end; procedure THDimLine.WriteToStream(Stream: TStream); var xByte: Byte; xInt: Integer; xStr: String; xDbl: Double; begin inherited; xStr := DLabel; WriteStrField(180,Stream,xStr); xStr := Prefix; WriteStrField(181,Stream,xStr); xStr := Suffix; WriteStrField(182,Stream,xStr); xStr := TextFont; WriteStrField(183,Stream,xStr); xDbl := TextHeight; WriteField(220,Stream,xDbl,8); if TextBold then xByte := 1 else xByte := 0; WriteField(90,Stream,xByte,1); if TextItalic then xByte := 1 else xByte := 0; WriteField(91,Stream,xByte,1); if AutoText then xByte := 1 else xByte := 0; WriteField(92,Stream,xByte,1); xByte := ord(TextPos);WriteField(93,Stream,xByte,1); xByte := ord(EndType);WriteField(94,Stream,xByte,1); xByte := ord(LStyle);WriteField(95,Stream,xByte,1); end; { TVDimLine } class function TVDimLine.CreateFromShadow(aOwner: TComponent; LHandle: Integer; Shadow: TFigure): TFigure; var x3,y3: Double; begin result := TVDimLine.Create(LHandle,mydsNormal,aOwner); result.ActualPoints[1] := Shadow.ActualPoints[1]; result.ActualPoints[2] := Shadow.ActualPoints[2]; x3 := Shadow.ActualPoints[3].x; y3 := (Shadow.ActualPoints[1].y+Shadow.ActualPoints[2].y) / 2; result.ActualPoints[3] := DoublePoint(x3,y3); TVDimLine(result).Lstyle := TVDimLine(Shadow).Lstyle; // TVDimLine(result).EndType := TVDimLine(Shadow).EndType; if GCadForm.FDimLinesType = dlt_None then TVDimLine(result).EndType := etClear; if GCadForm.FDimLinesType = dlt_Row then TVDimLine(result).EndType := etRow; if GCadForm.FDimLinesType = dlt_Stroke then TVDimLine(result).EndType := etNick; end; function TVDimLine.CreateModification: TFigure; begin result := TVDimLine.Create(0,dsTrace,nil); result.ActualPoints[1] := ActualPoints[1]; result.ActualPoints[2] := ActualPoints[2]; result.ActualPoints[3] := ActualPoints[3]; result.color := clLime; result.RotPoint := RotPoint; TVDimLine(result).EndType := EndType; TVDimLine(result).Lstyle := Lstyle; end; class function TVDimLine.CreateShadow(x,y: Double): TFigure; begin result := TVDimLine.Create(0,dsTrace,nil); result.ActualPoints[1] := DoublePoint(x,y); result.ActualPoints[2] := DoublePoint(x,y); result.ActualPoints[3] := DoublePoint(x,y); result.color := clLime; end; procedure TVDimLine.Draw(DEngine: TPCDrawEngine; isGrayed: Boolean); var acolor : Tcolor; p3 : TDoublepoint; text:string; x3,y3,tx,ty: Double; dist: double; l: integer; st: TFontStyles; begin aColor := Color; if (aColor = -255) and (LayerHandle <> 0) then begin aColor := TLayer(LayerHandle).PenColor; end; if isGrayed then acolor := TPCDrawing(Owner).FGrayedColor; //06.08.2012 GrayedColor; if DrawStyle = dsTrace then DEngine.Canvas.pen.mode := pmXor else DEngine.canvas.pen.mode := pmCopy; x3 := ap3.x; y3 := (ap1.y+ap2.y) / 2; p3 := DoublePoint(x3,y3); text := ''; if DrawStyle = mydsNormal then begin if autotext then begin if assigned(owner) then MapScale := TPCDrawing(Owner).MapScale; dist := (abs(ap1.y - ap2.y) * MapScale) / 1000; if self is TSCSVDimLine then dist := round(dist * 10000) / 10000 else dist := round(dist * 100) / 100; dist := MetreToUOM(dist); if self is TSCSVDimLine then text := FormatFloat(ffMask + '#', dist)+ GetUOMString(GCurrProjUnitOfMeasure) else text := FormatFloat(ffMask, dist) + GetUOMString(GCurrProjUnitOfMeasure); text := Prefix + text + Suffix; end else text := DLabel; caption := text; end; st := []; if TextBold then st := st + [fsBold]; if TextItalic then st := st + [fsItalic]; DEngine.DrawVDim(ap1,ap2,p3,Text,TextFont,st,aColor,TextColor,TextHeight,LStyle, TextPos,EndType,RegHandle); // Tolik if RegHandle > 1 then begin GetRegObject; if (TBrushStyle(brs) <> bsClear) then RegObject.CheckPointByRects := True; deleteObject(RegHandle); RegHandle := 0; end; // end; function TVDimLine.Duplicate: TFigure; var res: TVDimLine; begin res := TVDimLine.Create(LayerHandle,DrawStyle,Owner); res.DLabel := Dlabel; res.Prefix := Prefix; res.Suffix := Suffix; res.AutoText := AutoText; res.TextPos := TextPos; res.TextFont := TextFont; res.TextHeight := TextHeight; res.TextBold := TextBold; res.TextItalic := TextItalic; res.EndType := EndType; res.MapScale := MapScale; res.LStyle := Lstyle; CopyProperties(res); result := res; end; function TVDimLine.Edit: Boolean; var EnterStr: string; dist, distx, disty: double; begin if autotext then begin disty := (abs(ap1.y - ap2.y) * MapScale) / 1000; disty := round(disty * 100) / 100; disty := MetreToUOM(disty); DLabel := FormatFloat(ffMask, disty); end; Result := False; EnterStr := DLabel; // EnterStr := FloatToStr(MetreToUOM(StrToFloat_My(EnterStr))); if InputQuery(cDrawObjects_Mes4, cDrawObjects_Mes5, EnterStr) then begin // EnterStr := FloatToStr(UOMToMetre(StrToFloat_My(EnterStr))); DLabel := EnterStr; AutoText := False; Modified := True; result := true; end; end; function TVDimLine.EndModification(CadControl: Pointer; mp: TModPoint; TraceFigure: TFigure; x, y: Double; Shift: TShiftState): boolean; var x3,y3: Double; begin if mp.SeqNbr = 3 then begin y3 := (ActualPoints[1].y+ActualPoints[2].y) / 2; ActualPoints[3] := DoublePoint(x,y3); end else begin ActualPoints[mp.SeqNbr] := DoublePoint(x,y); y3 := (ActualPoints[1].y+ActualPoints[2].y) / 2; x3 := ActualPoints[3].x; ActualPoints[3] := DoublePoint(x3,y3); LStyle := TVDimLine(TraceFigure).LStyle; end; ResetRegion; Modified := True; LStyle := DefineVStyle(LStyle); // Tolik 04/03/2020 -- end; procedure TVDimLine.Getbounds(var figMaxX, figMaxY, figMinX, figMinY: Double); begin if regHandle = 0 then begin figMaxY := Max(ap1.y,ap2.y); figMinY := Min(ap1.y,ap2.y);; figMaxX := MaxValue([ap1.x,ap2.x,ap3.x]); figMinX := MinValue([ap1.x,ap2.x,ap3.x]); end else GetRegionBounds(figMaxX, figMaxY, figMinX,figMinY); end; function TVDimLine.GetClassName: String; begin result := 'VDimLine'; end; function TVDimLine.IsPointIn(x, y: Double): boolean; begin result := inherited isPointIn(x,y); if result then exit; result := isPointInRegion(x,y); // Tolik result := IsPointInRegionByRegObj(x,y); // end; procedure TVDimLine.MenuClicked(CommandId: integer); var idx: integer; begin idx := commandID-menuIndex; case idx of 1: EndType := etClear; 2: EndType := etRow; 3: EndType := etDot; 4: EndType := etNick; 5: AutoText := not Autotext; 7: TextPos := tpOnLine; 8: TextPos := tpAbove; 9: TextPos := tpBelow; 11: LStyle := vlsInner; 12: LStyle := vlsTop; 13: LStyle := vlsBottom; 14: LStyle := vlsTopLeft; 15: LStyle := vlsTopRight; 16: LStyle := vlsBottomLeft; 17: LStyle := vlsBottomRight; end; ResetRegion; Modified := true; end; procedure TVDimLine.Mirror(Point1, Point2: TDoublePoint); begin end; procedure TVDimLine.Rotate(aAngle: Double; cPoint: TDoublePoint); begin end; procedure TVDimLine.SetPropertyFromStream(xCode: Byte; data: pointer; size: integer); begin Case xcode of 90 : TextBold := ((pByte(data)^) = 1); 91 : TextItalic := ((pByte(data)^) = 1); 92 : AutoText := ((pByte(data)^) = 1); 93 : TextPos := TDimTextPos(pByte(data)^); 94 : EndType := TEndType(pByte(data)^); 95 : LStyle := TVDimLabelStyle(pByte(data)^); 180: DLabel := string(pchar(data)); 181: Prefix := string(pchar(data)); 182: Suffix := string(pchar(data)); 183: TextFont := string(pchar(data)); 220 : TextHeight := pDouble(data)^; end; end; function TVDimLine.ShadowClick(ClickIndex:Integer; x, y: Double): Boolean; begin result := false; ActualPoints[ClickIndex] := DoublePoint(x,y); if ClickIndex = 3 then result := true; end; function TVDimLine.ShadowTrace(ClickIndex:Integer;x,y: Double): Boolean; begin if ClickIndex = 1 then begin ActualPoints[2] := DoublePoint(x,y); ActualPoints[3] := DoublePoint(x,y); end else if ClickIndex = 2 then begin ActualPoints[3] := DoublePoint(x,y); end; if abs(ActualPoints[1].y-ActualPoints[2].y) < 10 then LStyle := vlsTop else Lstyle := vlsInner; result := true; end; function TVDimLine.TraceModification(CadControl: Pointer; mp: TModPoint; TraceFigure: TFigure; x, y: Double; Shift: TShiftState): boolean; begin TraceFigure.ActualPoints[mp.SeqNbr] := DoublePoint(x,y); end; procedure TVDimLine.UpdateMenu(var popMenu: TPopUpMenu; var sIndex: Integer); var mnItem,mnSub: TMenuItem; begin menuIndex:= sIndex; mnItem := TMenuItem.Create(PopMenu); mnItem.Tag := sIndex; mnItem.Caption := fmEndType; PopMenu.Items.Add(mnItem); mnSub := TMenuItem.Create(PopMenu); mnSub.Caption := fmClearEnd; mnSub.Tag := sIndex+1; if EndType = etClear then mnSub.Checked := True; mnItem.Add(mnSub); mnSub := TMenuItem.Create(PopMenu); mnSub.Caption := fmRowEnd; mnSub.Tag := sIndex+2; if EndType = etRow then mnSub.Checked := True; mnItem.Add(mnSub); mnSub := TMenuItem.Create(PopMenu); mnSub.Caption := fmDotEnd; mnSub.Tag := sIndex+3; if EndType = etDot then mnSub.Checked := True; mnItem.Add(mnSub); mnSub := TMenuItem.Create(PopMenu); mnSub.Caption := fmNickEnd; mnSub.Tag := sIndex+4; if EndType = etNick then mnSub.Checked := True; mnItem.Add(mnSub); mnItem := TMenuItem.Create(PopMenu); mnItem.Tag := sIndex+5; mnItem.Caption :=fmAutoLabel; if Autotext then mnItem.Checked := True; PopMenu.Items.Add(mnItem); mnItem := TMenuItem.Create(PopMenu); mnItem.Tag := sIndex+6; mnItem.Caption := fmTextPosition; PopMenu.Items.Add(mnItem); mnSub := TMenuItem.Create(PopMenu); mnSub.Caption := fmOnLine; mnSub.Tag := sIndex+7; if textPos = tpOnline then mnSub.Checked := True; mnItem.Add(mnSub); mnSub := TMenuItem.Create(PopMenu); mnSub.Caption := fmAboveLine; mnSub.Tag := sIndex+8; if textPos = tpAbove then mnSub.Checked := True; mnItem.Add(mnSub); mnSub := TMenuItem.Create(PopMenu); mnSub.Caption := fmBelowLine; mnSub.Tag := sIndex+9; if textPos = tpBelow then mnSub.Checked := True; mnItem.Add(mnSub); mnItem := TMenuItem.Create(PopMenu); mnItem.Tag := sIndex+10; mnItem.Caption := fmLabeling; PopMenu.Items.Add(mnItem); mnSub := TMenuItem.Create(PopMenu); mnSub.Caption := fmInside; mnSub.Tag := sIndex+11; if LStyle = vlsInner then mnSub.Checked := True; mnItem.Add(mnSub); mnSub := TMenuItem.Create(PopMenu); mnSub.Caption := fmTop; mnSub.Tag := sIndex+12; if LStyle = vlsTop then mnSub.Checked := True; mnItem.Add(mnSub); mnSub := TMenuItem.Create(PopMenu); mnSub.Caption := fmBottom; mnSub.Tag := sIndex+13; if LStyle = vlsBottom then mnSub.Checked := True; mnItem.Add(mnSub); mnSub := TMenuItem.Create(PopMenu); mnSub.Caption := fmTopLeft; mnSub.Tag := sIndex+14; if LStyle = vlsTopLeft then mnSub.Checked := True; mnItem.Add(mnSub); mnSub := TMenuItem.Create(PopMenu); mnSub.Caption := fmTopRight; mnSub.Tag := sIndex+15; if LStyle = vlsTopRight then mnSub.Checked := True; mnItem.Add(mnSub); mnSub := TMenuItem.Create(PopMenu); mnSub.Caption := fmBottomLeft; mnSub.Tag := sIndex+16; if LStyle = vlsBottomLeft then mnSub.Checked := True; mnItem.Add(mnSub); mnSub := TMenuItem.Create(PopMenu); mnSub.Caption := fmBottomRight; mnSub.Tag := sIndex+17; if LStyle = vlsBottomRight then mnSub.Checked := True; mnItem.Add(mnSub); sIndex := sIndex+18; end; procedure TVDimLine.WriteToStream(Stream: TStream); var xByte: Byte; xInt: Integer; xStr: String; xDbl: Double; begin inherited; xStr := DLabel; WriteStrField(180,Stream,xStr); xStr := Prefix; WriteStrField(181,Stream,xStr); xStr := Suffix; WriteStrField(182,Stream,xStr); xStr := TextFont; WriteStrField(183,Stream,xStr); xDbl := TextHeight; WriteField(220,Stream,xDbl,8); xByte := 1; if TextBold then xByte := 1 else xByte := 0; WriteField(90,Stream,xByte,1); if TextItalic then xByte := 1 else xByte := 0; WriteField(91,Stream,xByte,1); if AutoText then xByte := 1 else xByte := 0; WriteField(92,Stream,xByte,1); xByte := ord(TextPos); WriteField(93,Stream,xByte,1); xByte := ord(EndType); WriteField(94,Stream,xByte,1); xByte := ord(LStyle); WriteField(95,Stream,xByte,1); end; { TADimLine } class function TADimline.CreateFromShadow(aOwner: TComponent; LHandle: Integer; Shadow: TFigure): TFigure; var x3,y3: Double; p3: TDoublePoint; begin result := TADimline.Create(LHandle,mydsNormal,aOwner); result.ActualPoints[1] := Shadow.ActualPoints[1]; result.ActualPoints[2] := Shadow.ActualPoints[2]; x3 := Shadow.ActualPoints[3].x; y3 := Shadow.ActualPoints[3].y; PointToParallelLine(Shadow.ActualPoints[1],Shadow.ActualPoints[2],x3,y3); result.ActualPoints[3] := DoublePoint(x3,y3); TADimline(result).LStyle := TADimline(Shadow).Lstyle; TADimline(result).EndType := TADimline(Shadow).EndType; end; function TADimline.CreateModification: TFigure; begin result := TADimline.Create(0,dsTrace,nil); result.ActualPoints[1] := ActualPoints[1]; result.ActualPoints[2] := ActualPoints[2]; result.ActualPoints[3] := ActualPoints[3]; result.color := clLime; result.RotPoint := RotPoint; TADimline(result).EndType := EndType; TADimline(result).Lstyle := Lstyle; end; class function TADimline.CreateShadow(x, y: Double): TFigure; begin result := TADimline.Create(0,dsTrace,nil); result.ActualPoints[1] := DoublePoint(x,y); result.ActualPoints[2] := DoublePoint(x,y); result.ActualPoints[3] := DoublePoint(x,y); result.color := clLime; TADimline(result).Lstyle := alsInner; TADimline(result).HorzText := False; end; procedure TADimline.Draw(DEngine: TPCDrawEngine; isGrayed: Boolean); var acolor : Tcolor; text:string; dist: double; l: integer; st: TFontStyles; begin aColor := Color; if (aColor = -255) and (LayerHandle <> 0) then begin aColor := TLayer(LayerHandle).PenColor; end; if isGrayed then acolor := TPCDrawing(Owner).FGrayedColor; //06.08.2012 GrayedColor; if DrawStyle = dsTrace then DEngine.Canvas.pen.mode := pmXor else DEngine.canvas.pen.mode := pmCopy; if DrawStyle = dsTrace then RegHandle := 1; text := ''; if DrawStyle = mydsNormal then begin if autotext then begin if assigned(owner) then MapScale := TPCDrawing(Owner).MapScale; dist := (GetLineLenght(ap1,ap2) *MapScale)/1000; dist := round(dist*100)/100; {//22.12.2011 text := FormatFloat(ffMask, dist)+ ' m'; if assigned(Owner) and (TPCDrawing(Owner).RulerSystem = rsWhitworth) then begin dist := (((GetLineLenght(ap1,ap2) *MapScale)/10)/2.54)/12; dist := round(dist*100)/100; text := FormatFloat(ffMask, dist)+ ' ft'; end;} dist := MetreToUOM(dist); text := FormatFloat(ffMask, dist)+ GetUOMString(GCurrProjUnitOfMeasure); text := Prefix+text+Suffix; end else text := DLabel; end; st := []; if TextBold then st := st + [fsBold]; if TextItalic then st := st + [fsItalic]; DEngine.DrawAlignedDim(ap1,ap2,ap3,Text,TextFont,st,aColor,TextColor,TextHeight,LStyle, TextPos,EndType,HorzText,RegHandle); // Tolik if RegHandle > 1 then begin GetRegObject; if (TBrushStyle(brs) <> bsClear) then RegObject.CheckPointByRects := True; deleteObject(RegHandle); RegHandle := 0; end; // end; function TADimline.Duplicate: TFigure; var res: TADimline; begin res := TADimline.Create(LayerHandle,DrawStyle,Owner); res.DLabel := Dlabel; res.Prefix := Prefix; res.Suffix := Suffix; res.AutoText := AutoText; res.TextPos := TextPos; res.TextFont := TextFont; res.TextHeight := TextHeight; res.TextBold := TextBold; res.TextItalic := TextItalic; res.EndType := EndType; res.MapScale := MapScale; res.LStyle := Lstyle; CopyProperties(res); result := res; end; function TADimline.EndModification(CadControl: Pointer; mp: TModPoint; TraceFigure: TFigure; x, y: Double; Shift: TShiftState): boolean; var x3,y3: Double; begin if mp.SeqNbr = 3 then begin PointToParallelLine(ActualPoints[1],ActualPoints[2],x,y); ActualPoints[3] := DoublePoint(x,y); end else begin ActualPoints[mp.SeqNbr] := DoublePoint(x,y); x3 := ActualPoints[3].x; y3 := ActualPoints[3].y; PointToParallelLine(ActualPoints[1],ActualPoints[2],x3,y3); ActualPoints[3] := DoublePoint(x3,y3); LStyle := TADimline(TraceFigure).LStyle; end; ResetRegion; Modified := True; end; procedure TADimline.Getbounds(var figMaxX, figMaxY, figMinX, figMinY:Double); begin GetRegionBounds(figMaxX, figMaxY, figMinX,figMinY); end; function TADimLine.GetClassName: String; begin result := 'ADimLine'; end; function TADimline.IsPointIn(x, y: Double): boolean; begin result := inherited isPointIn(x,y); if result then exit; result := isPointInRegion(x,y); // Tolik result := IsPointInRegionByRegObj(x,y); // end; procedure TADimline.MenuClicked(CommandId: integer); var idx: integer; begin idx := commandID-menuIndex; case idx of 1: EndType := etClear; 2: EndType := etRow; 3: EndType := etDot; 4: EndType := etNick; 5: AutoText := not Autotext; 7: TextPos := tpOnLine; 8: TextPos := tpAbove; 9: TextPos := tpBelow; 11: LStyle := alsInner; 12: LStyle := alsLeft; 13: LStyle := alsRight; 14: HorzText := not HorzText; end; ResetRegion; Modified := true; end; procedure TADimline.SetPropertyFromStream(xCode: Byte; data: pointer; size: integer); begin Case xcode of 90 : TextBold := ((pByte(data)^) = 1); 91 : TextItalic := ((pByte(data)^) = 1); 92 : AutoText := ((pByte(data)^) = 1); 93 : HorzText := ((pByte(data)^) = 1); 94 : TextPos := TDimTextPos(pByte(data)^); 95 : EndType := TEndType(pByte(data)^); 96 : LStyle := TADimLabelStyle(pByte(data)^); 180: DLabel := string(pchar(data)); 181: Prefix := string(pchar(data)); 182: Suffix := string(pchar(data)); 183: TextFont := string(pchar(data)); 220: TextHeight := pDouble(data)^; end; end; function TADimline.ShadowClick(ClickIndex:Integer; x, y:Double): Boolean; begin result := false; ActualPoints[ClickIndex] := DoublePoint(x,y); if ClickIndex = 3 then result := true; end; function TADimline.ShadowTrace(ClickIndex:Integer; x, y: Double): Boolean; begin if ClickIndex = 1 then begin ActualPoints[2] := DoublePoint(x,y); ActualPoints[3] := DoublePoint(x,y); end else if ClickIndex = 2 then begin ActualPoints[3] := DoublePoint(x,y); end; result := true; end; function TADimline.TraceModification(CadControl: Pointer; mp: TModPoint; TraceFigure: TFigure; x, y: Double; Shift: TShiftState): boolean; begin TraceFigure.ActualPoints[mp.SeqNbr] := DoublePoint(x,y); end; procedure TADimline.UpdateMenu(var popMenu: TPopUpMenu; var sIndex: Integer); var mnItem,mnSub: TMenuItem; begin menuIndex:= sIndex; mnItem := TMenuItem.Create(PopMenu); mnItem.Tag := sIndex; mnItem.Caption := fmEndType; PopMenu.Items.Add(mnItem); mnSub := TMenuItem.Create(PopMenu); mnSub.Caption := fmClearEnd; mnSub.Tag := sIndex+1; if EndType = etClear then mnSub.Checked := True; mnItem.Add(mnSub); mnSub := TMenuItem.Create(PopMenu); mnSub.Caption := fmRowEnd; mnSub.Tag := sIndex+2; if EndType = etRow then mnSub.Checked := True; mnItem.Add(mnSub); mnSub := TMenuItem.Create(PopMenu); mnSub.Caption := fmDotEnd; mnSub.Tag := sIndex+3; if EndType = etDot then mnSub.Checked := True; mnItem.Add(mnSub); mnSub := TMenuItem.Create(PopMenu); mnSub.Caption := fmNickEnd; mnSub.Tag := sIndex+4; if EndType = etNick then mnSub.Checked := True; mnItem.Add(mnSub); mnItem := TMenuItem.Create(PopMenu); mnItem.Tag := sIndex+5; mnItem.Caption := fmAutoLabel; if Autotext then mnItem.Checked := True; PopMenu.Items.Add(mnItem); mnItem := TMenuItem.Create(PopMenu); mnItem.Tag := sIndex+6; mnItem.Caption := fmTextPosition; PopMenu.Items.Add(mnItem); mnSub := TMenuItem.Create(PopMenu); mnSub.Caption := fmOnLine; mnSub.Tag := sIndex+7; if textPos = tpOnline then mnSub.Checked := True; mnItem.Add(mnSub); mnSub := TMenuItem.Create(PopMenu); mnSub.Caption := fmAboveLine; mnSub.Tag := sIndex+8; if textPos = tpAbove then mnSub.Checked := True; mnItem.Add(mnSub); mnSub := TMenuItem.Create(PopMenu); mnSub.Caption := fmBelowLine; mnSub.Tag := sIndex+9; if textPos = tpBelow then mnSub.Checked := True; mnItem.Add(mnSub); mnItem := TMenuItem.Create(PopMenu); mnItem.Tag := sIndex+10; mnItem.Caption := fmLabeling; PopMenu.Items.Add(mnItem); mnSub := TMenuItem.Create(PopMenu); mnSub.Caption := fmInside; mnSub.Tag := sIndex+11; if LStyle = alsInner then mnSub.Checked := True; mnItem.Add(mnSub); mnSub := TMenuItem.Create(PopMenu); mnSub.Caption := fmLeft; mnSub.Tag := sIndex+12; if LStyle = alsLeft then mnSub.Checked := True; mnItem.Add(mnSub); mnSub := TMenuItem.Create(PopMenu); mnSub.Caption := fmRight; mnSub.Tag := sIndex+13; if LStyle = alsRight then mnSub.Checked := True; mnItem.Add(mnSub); mnItem := TMenuItem.Create(PopMenu); mnItem.Tag := sIndex+14; mnItem.Caption := fmAlwaysHorizontal; if Horztext then mnItem.Checked := True; PopMenu.Items.Add(mnItem); sIndex := sIndex+15; end; procedure TADimline.WriteToStream(Stream: TStream); var xByte: Byte; xInt: Integer; xStr: String; xDbl: Double; begin inherited; xStr := DLabel; WriteStrField(180,Stream,xStr); xStr := Prefix; WriteStrField(181,Stream,xStr); xStr := Suffix; WriteStrField(182,Stream,xStr); xStr := TextFont; WriteStrField(183,Stream,xStr); xDbl := TextHeight; WriteField(220,Stream,xDbl,8); if TextBold then xByte := 1 else xByte := 0; WriteField(90,Stream,xByte,1); if TextItalic then xByte := 1 else xByte := 0; WriteField(91,Stream,xByte,1); if AutoText then xByte := 1 else xByte := 0; WriteField(92,Stream,xByte,1); if HorzText then xByte := 1 else xByte := 0; WriteField(93,Stream,xByte,1); xByte := ord(TextPos); WriteField(94,Stream,xByte,1); xByte := ord(EndType); WriteField(95,Stream,xByte,1); xByte := ord(LStyle); WriteField(96,Stream,xByte,1); end; { TPattern } constructor TPattern.CreateFromFigure(aFigure: TFigure); var r: TDoublerect; baseP: TDoublepoint; baseX,baseY: Double; begin inherited; r := aFigure.GetBoundRect; pwidth := abs(r.right - r.left); if pwidth = 0 then pWidth := 10; Vector := TVector.Create(0); if aFigure.vertZero = 1 then baseY := r.bottom else baseY := r.Top; if aFigure.HorzZero = 0 then baseX := r.Left else baseX := r.Right; baseP := DoublePoint(baseX,baseY); aFigure.GetVectorObjects(Vector.Objects,baseP); end; constructor TPattern.Create(aVector: TVector;aWidth,aGap:Double); begin inherited Create; if assigned(avector) then begin Vector := aVector.Duplicate; end; pWidth := aWidth; Gap := aGap; end; destructor TPattern.destroy; begin if assigned(Vector) then Vector.Free; inherited; end; Procedure TPattern.Draw(DEngine:TPCDrawEngine;sCoord,eCoord:TDoublepoint;Scale:Double); begin Vector.Draw(DEngine,sCoord,eCoord,Scale); end; procedure TPattern.DrawObjects(DEngine: TPCDrawEngine; sCoord, eCoord: TDoublepoint; Scale: Double); begin Vector.DrawObjects(DEngine,sCoord,eCoord,Scale); end; function TPattern.Duplicate: TPattern; begin Result := TPattern.Create(Vector,pWidth,Gap); Result.PatName := PatName; end; procedure TPattern.LoadFromStream(Stream: TStream); var version: Integer; begin Stream.Read(Version,4); if version <> 100 then begin Stream.Position := 0; LoadFromStreamOldFormat(Stream); exit; end; Stream.Read(Gap,8); if CompareValue(Gap, 0, 0.0000001) = 0 then // Tolik 23/06/2021 -- Gap := 0; Stream.Read(PWidth,8); if CompareValue(PWidth, 0, 0.0000001) = 0 then // Tolik 23/06/2021 -- PWidth := 0; PatName := ReadStringFromStream(Stream); Vector := Tvector.Create(0); Vector.LoadFromStream(Stream); end; procedure TPattern.LoadFromStreamOldFormat(Stream: Tstream); var pType: Byte; figure: Tfigure; r: TDoublerect; baseP: TDoublepoint; baseX,baseY: Double; val: double; begin Stream.Read(Gap,8); if CompareValue(Gap, 0, 0.0000001) = 0 then // Tolik 23/06/2021 -- Gap := 0; Gap := Gap /10; Stream.Read(val,8); // it was vertgap if CompareValue(val, 0, 0.0000001) = 0 then // Tolik 23/06/2021 -- val := 0; Stream.Read(PWidth,8); if CompareValue(PWidth, 0, 0.0000001) = 0 then // Tolik 23/06/2021 -- PWidth := 0; PWidth := PWidth / 10; Stream.Read(pType,1); if pType = 2 then // old style figure pattern begin figure := Tfigure.CreateFromStream(Stream,0,mydsNormal,nil); r := Figure.GetBoundRect; if pwidth = 0 then pwidth := abs(r.right - r.left); if pwidth = 0 then pWidth := 10; Vector := TVector.Create(0); if Figure.VertZero = 1 then baseY := r.bottom else baseY := r.Top; if Figure.HorzZero = 0 then baseX := r.Left else baseX := r.Right; baseP := DoublePoint(baseX,baseY); Figure.GetVectorObjects(Vector.Objects,baseP); if figure is TfigureGrp then TfigureGrp(figure).DestroyInFigures; Figure.Free; exit; end else if pType = 1 then begin Vector := Tvector.Create(0); Vector.LoadFromStreamOldFormat(Stream); end; end; procedure TPattern.SaveToStream(Stream: TStream); var version: Integer; begin version := 100; Stream.Write(Version,4); Stream.Write(Gap,8); Stream.Write(PWidth,8); WriteString(Stream,PatName); if assigned(vector) then Vector.SaveToStream(Stream); end; procedure TPattern.Scale(px, py: double); begin pWidth := pwidth*px; Gap := Gap*px; Vector.Scale(px,py); end; procedure TPattern.StartDraw(DEngine: TPCDrawEngine; sCoord: TDoublePoint); begin Dengine.MoveTo(DoublePOint(sCoord.x,Vector.StartY+sCoord.Y,SCoord.Z)); end; { TVectorSegment } constructor TVectorSegment.CreateBezierSegment(ePoint, cp1, cp2: TDoublepoint); begin inherited Create; EndPoint := ePoint; Cpoint1 := cp1; CPoint2 := cp2; SegmentType := vstBezier; end; constructor TVectorSegment.CreateFromStream(Stream: TStream); begin inherited Create; Stream.Read(SegmentType,1); Stream.Read(endPoint.x,8); if CompareValue(endPoint.x, 0, 0.0000001) = 0 then // Tolik 23/06/2021 -- endPoint.x := 0; Stream.Read(endPoint.y,8); if CompareValue(endPoint.y, 0, 0.0000001) = 0 then // Tolik 23/06/2021 -- endPoint.y := 0; if SegmentType = vstBezier then begin Stream.Read(Cpoint1.x,8); if CompareValue(Cpoint1.x, 0, 0.0000001) = 0 then // Tolik 23/06/2021 -- Cpoint1.x := 0; Stream.Read(Cpoint1.y,8); if CompareValue(Cpoint1.y, 0, 0.0000001) = 0 then // Tolik 23/06/2021 -- Cpoint1.y := 0; Stream.Read(Cpoint2.x,8); if CompareValue(Cpoint2.x, 0, 0.0000001) = 0 then // Tolik 23/06/2021 -- Cpoint2.x := 0; Stream.Read(Cpoint2.y,8); if CompareValue(Cpoint2.y, 0, 0.0000001) = 0 then // Tolik 23/06/2021 -- Cpoint2.y := 0; end; end; constructor TVectorSegment.CreateFromStreamOldFormat(Stream: TStream); var val: Integer; begin inherited Create; Stream.Read(SegmentType,1); Stream.Read(val,4); endPoint.x := val/10; Stream.Read(val,4); endPoint.y := val/10; if SegmentType = vstBezier then begin Stream.Read(val,4); Cpoint1.x := val/10; Stream.Read(val,4); Cpoint1.y := val/10; Stream.Read(val,4); Cpoint2.x := val/10; Stream.Read(val,4); Cpoint2.y := val/10; end; end; Destructor TVectorSegment.Destroy; begin inherited; end; constructor TVectorSegment.CreateLineSegment(ePoint: TDoublePoint); begin inherited Create; EndPoint := ePoint; SegmentType := vstLine; end; function TVectorSegment.Duplicate: TVectorSegment; begin Result := TvectorSegment.Create; Result.SegmentType := SegmentType; Result.EndPoint := EndPoint; Result.Cpoint1 := Cpoint1; Result.Cpoint2 := Cpoint2; end; procedure TVectorSegment.Move(dx, dy: Double); begin EndPoint.x := EndPoint.x + dx; EndPoint.y := EndPoint.y + dy; CPoint1.x := CPoint1.x + dx; CPoint1.y := CPoint1.y + dy; CPoint2.x := CPoint2.x + dx; CPoint2.y := CPoint2.y + dy; end; procedure TVectorSegment.SaveToStream(Stream: TStream); begin Stream.Write(SegmentType,1); Stream.Write(endPoint.x,8); Stream.Write(endPoint.y,8); if SegmentType = vstBezier then begin Stream.Write(Cpoint1.x,8); Stream.Write(Cpoint1.y,8); Stream.Write(Cpoint2.x,8); Stream.Write(Cpoint2.y,8); end; end; procedure TVectorSegment.Scale(px, py: double); begin EndPoint := ScalePoint(DoublePoint(0,0),EndPoint,px,py); if SegmentType = vstbezier then begin CPoint1 := ScalePoint(DoublePoint(0,0),CPoint1,px,py); CPoint2 := ScalePoint(DoublePoint(0,0),CPoint2,px,py); end; end; { TVector } function TVector.AddBezierSegment(ePoint, cPoint1, cPoint2: TDoublePoint): TVectorSegment; var Segment: TVectorSegment; begin Segment := TVectorSegment.CreateBezierSegment(ePoint,cPoint1,cPoint2); Segments.Add(Segment); end; function TVector.AddLineSegment(ePoint: TDoublePoint): TVectorSegment; var Segment: TVectorSegment; begin Segment := TVectorSegment.CreateLineSegment(ePoint); Segments.Add(Segment); end; Procedure TVector.Draw(DEngine:TPCDrawEngine;sCoord,eCoord:TDoublepoint;Scale:Double); var i: Integer; Segment: TvectorSegment; sPoint,ePoint,cP1,cp2: TDoublepoint; Angle: Double; begin Angle := GetRadOfLine(sCoord,eCoord); For i := 0 to Segments.Count -1 do begin Segment := TvectorSegment(Segments[i]); if segment.SegmentType = vstLine then begin ePoint := Segment.EndPoint; ePoint.x := ePoint.x*Scale; ePoint := DoublePoint(ePoint.x+sCoord.x,ePoint.y+sCoord.y); ePoint := RotatePoint(sCoord,ePoint,angle); DEngine.LineTo(ePoint); end else begin ePoint := Segment.EndPoint; ePoint.x := ePoint.x*Scale; ePoint := DoublePoint(ePoint.x+sCoord.x,ePoint.y+sCoord.y); ePoint := RotatePoint(sCoord,ePoint,angle); cP1 := Segment.CPoint1; cP1.x := cp1.x*Scale; cP1 := DoublePoint(CP1.x+sCoord.x,CP1.y+sCoord.y); cP1 := RotatePoint(sCoord,cP1,angle); cP2 := Segment.CPoint2; cP2.x := cP2.x*Scale; cP2 := DoublePoint(CP2.x+sCoord.x,CP2.y+sCoord.y); cP2 := RotatePoint(sCoord,cP2,angle); DEngine.BezierTo(cp1.x,cp1.y,cp2.x,cp2.y,ePoint.x,ePoint.y); end; end; end; constructor TVector.Create(SPointY: Double); begin inherited create; Segments := TList.Create; Objects := TList.Create; StartY := sPointY; end; Function TVector.Duplicate:Tvector; var i: Integer; begin Result := TVector.Create(StartY); For i := 0 to Segments.Count -1 do begin Result.Segments.Add(TvectorSegment(Segments[i]).Duplicate); end; For i := 0 to Objects.Count -1 do begin Result.Objects.Add(TvectorObject(Objects[i]).Duplicate); end; end; Destructor TVector.Destroy; var i: Integer; begin try For i := 0 to Segments.Count -1 do begin TvectorSegment(Segments[i]).Free; end; For i := 0 to Objects.Count -1 do begin TvectorObject(Objects[i]).Free; end; //Tolik { Segments.Clear; Objects.Clear;} // Segments.Free; Objects.Free; except // on E: Exception do AddExceptionToLog(CPowerCadMessage + 'TVector.Destroy' + E.Message); end; inherited; end; Procedure TVector.SaveToStream(Stream:TStream); var i: Integer; begin Stream.Write(StartY,8); Stream.Write(Segments.Count,4); For i := 0 to Segments.Count -1 do begin TvectorSegment(Segments[i]).SaveToStream(Stream); end; Stream.Write(Objects.Count,4); For i := 0 to Objects.Count -1 do begin TvectorObject(Objects[i]).SaveToStream(Stream); end; end; Procedure TVector.LoadFromStream(Stream:TStream); var i,cnt: Integer; Segment: TVectorSegment; xObject: TvectorObject; begin Stream.Read(StartY,8); if CompareValue(StartY, 0, 0.0000001) = 0 then // Tolik 23/06/2021 -- StartY := 0; Stream.Read(cnt,4); For i := 1 to cnt do begin Segment := TvectorSegment.CreateFromStream(Stream); Segments.Add(Segment); end; Stream.Read(cnt,4); For i := 1 to cnt do begin xObject := TvectorObject.CreateFromStream(Stream); Objects.Add(xObject); end; end; procedure TVector.AddVectorObject(cObject: TVectorObject); begin Objects.add(cObject); end; procedure TVector.DrawObjects(DEngine: TPCDrawEngine; sCoord, eCoord: TDoublePoint; Scale: Double); var i,k: Integer; xObject: TVectorObject; Values: TDoublePointArr; xPoint: TDoublePoint; Angle: Double; begin Angle := GetRadOfLine(sCoord,eCoord); For i := 0 to Objects.Count -1 do begin xObject := TVectorObject(Objects[i]); SetLength(Values,xObject.ArrayLen); xObject.GetLocalValues(Values,sCoord,scale,angle); case xObject.ObjectType of votLine: DEngine.DrawLine(Values[0],Values[1]); votBezier: DEngine.DrawBezier(Values[0],Values[1],Values[2],Values[3]); votEllipse: DEngine.DrawEllipse(Values[0],Values[1].x,Values[1].y,angle); votCircle: DEngine.DrawCircle(Values[0],Values[1].x); votPolyline: DEngine.DrawPolyline(Values,False); votPolygon: DEngine.DrawPolyline(Values,True); votPoint: DEngine.DrawPoint(Values[0]); end; end; end; procedure TVector.MoveContent(dx, dy: Double); var i: Integer; begin for i := 0 to Segments.Count -1 do begin TVectorSegment(Segments[i]).Move(dx,dy); end; for i := 0 to Objects.Count -1 do begin TVectorObject(objects[i]).Move(dx,dy); end; end; procedure TVector.LoadFromStreamOldFormat(Stream: TStream); var i,cnt,sY: Integer; Segment: TvectorSegment; begin Stream.Read(sY,4); StartY := sY/10; Stream.Read(cnt,4); For i := 1 to cnt do begin Segment := TvectorSegment.CreateFromStreamOldFormat(Stream); Segments.Add(Segment); end; end; procedure TVector.Scale(px, py: double); var i: Integer; begin StartY := StartY*py; for i := 0 to Segments.Count -1 do TvectorSegment(Segments[i]).Scale(px,py); for i := 0 to Objects.Count -1 do TvectorObject(Objects[i]).Scale(px,py); end; { TVectorObject } constructor TVectorObject.CreateBezierObject(p1, p2, cp1, cp2: TDoublePoint); begin inherited Create; ObjectType := votBezier; Setlength(Values,4); ArrayLen := 4; Values[0] := p1; Values[1] := cp1; Values[2] := cp2; Values[3] := p2; end; constructor TVectorObject.CreateCircleObject(p1: TDoublePoint; r: Double); begin inherited Create; ObjectType := votCircle; ArrayLen := 2; Setlength(Values,2); Values[0] := p1; Values[1] := DoublePoint(r,0) ; end; constructor TVectorObject.CreateEllipseObject(p1: TDoublePoint; a,b: Double); begin inherited Create; ObjectType := votEllipse; ArrayLen := 2; Setlength(Values,2); Values[0] := p1; Values[1] := DoublePoint(a,b) ; end; constructor TVectorObject.CreateFromStream(Stream: TStream); var valx,valy: Double; i: Integer; begin inherited Create; Stream.Read(ObjectType,1); Stream.Read(arrayLen,4); SetLength(Values,ArrayLen); for i := 0 to ArrayLen -1 do begin Stream.Read(valx,8); if CompareValue(valx, 0, 0.0000001) = 0 then // Tolik 23/06/2021 -- valx := 0; Stream.Read(valy,8); if CompareValue(valy, 0, 0.0000001) = 0 then // Tolik 23/06/2021 -- valy := 0; Values[i] := DoublePoint(valx,valy); end; end; constructor TVectorObject.CreateLineObject(p1, p2: TDoublePoint); begin inherited Create; ArrayLen := 2; ObjectType := votLine; Setlength(Values,2); Values[0] := p1; Values[1] := p2; end; constructor TVectorObject.CreatePointObject(p: TDoublepoint); begin inherited Create; ArrayLen := 1; ObjectType := votPoint; Setlength(Values,1); Values[0] := p; end; constructor TVectorObject.CreatePolygonObject(nbrPoint: Integer; p: array of TDoublePoint); var i: Integer; begin inherited Create; ArrayLen := nbrPoint; ObjectType := votPolygon; Setlength(Values,nbrPoint); for i := 0 to nbrPoint-1 do Values[i] := p[i]; end; constructor TVectorObject.CreatePolyLineObject(nbrPoint: Integer; p: array of TDoublePoint); var i: Integer; begin inherited Create; ArrayLen := nbrPoint; ObjectType := votPolyline; Setlength(Values,nbrPoint); for i := 0 to nbrPoint-1 do Values[i] := p[i]; end; destructor TVectorObject.Destroy; begin Setlength(values,0); inherited destroy; end; function TVectorObject.Duplicate: TVectorObject; var i: Integer; begin Result := TVectorObject.Create; Result.ObjectType := ObjectType; Result.ArrayLen := ArrayLen; SetLength(Result.Values,ArrayLen); for i := 0 to ArrayLen -1 do begin Result.Values[i] := Values[i]; end; end; procedure TVectorObject.GetLocalValues(LValues: TDoublePointArr; sCoord: TDoublePoint; Scale, Angle: Double); var len,k: Integer; xPoint: TDoublePoint; begin len := ArrayLen; if (ObjectType = votCircle) or (ObjectType = votEllipse) then begin len := Arraylen -1; LValues[1] := Doublepoint(Values[1].x * Scale,Values[1].y * 1); end; for k := 0 to Len-1 do begin xPoint := Values[k]; xPoint := DoublePoint(xPoint.x+sCoord.x,xPoint.y+sCoord.y); xPoint := ScalePoint(sCoord,xPoint,Scale,1); xPoint := RotateDPoint(DoublePoint(scoord.x,scoord.y),xPoint,angle); LValues[k] := xPoint; end; end; procedure TVectorObject.Move(dx, dy: Double); var i,pCnt: Integer; begin if ObjectType in [votCircle,votEllipse] then pCnt := ArrayLen -1 else pCnt := ArrayLen; for i := 0 to pCnt-1 do begin Values[i] := DoublePoint(Values[i].x+dx,Values[i].y+dy); end; end; procedure TVectorObject.SaveToStream(Stream: TStream); var i: Integer; val: Double; begin Stream.Write(ObjectType,1); Stream.Write(ArrayLen,4); for i := 0 to ArrayLen -1 do begin val := Values[i].x;Stream.Write(val,8); val := Values[i].y;Stream.Write(val,8); end; end; procedure TVectorObject.Scale(px, py: double); var len,k: Integer; xPoint: TDoublePoint; begin len := ArrayLen; if (ObjectType = votCircle) or (ObjectType = votEllipse) then begin len := Arraylen -1; Values[1] := Doublepoint(Values[1].x * px,Values[1].y * py); end; for k := 0 to Len-1 do begin xPoint := Values[k]; xPoint := ScalePoint(DoublePoint(0,0),xPoint,px,py); Values[k] := xPoint; end; end; procedure TFigure.SendSignal(port, value: Integer); begin //*** end; procedure TLine.Move(deltax, deltay: Double); begin InMoveList := False; if (JoinFigure1 = nil) or (JoinFigure2 = nil) then inherited; end; function TFigure.GetClassName: String; begin Result := 'Figure'; end; { TUserRectangle } procedure TUserRectangle.draw(DEngine: TPCDrawEngine; isGrayed: Boolean); var cad: TPCDrawing; begin if assigned(Owner) then begin cad := TPCDrawing(Owner); DEngine.Canvas.Pen.Mode := pmCopy; if not Cad.DrawUserFigureEvent(UserClass,DEngine.Canvas.Handle,Handle,isGrayed) then inherited; end else begin inherited; end; end; class function TUserRectangle.CreateFromShadow(aOwner: TComponent; LHandle: Integer; Shadow: TFigure): TFigure; var cad: TPCDrawing; begin cad := TPCDrawing(aOwner); Result := TUserRectangle.create(Shadow.ap1.x,Shadow.ap1.y, Shadow.ap3.x,Shadow.ap3.y, cad.DefaultPenWidth, ord(cad.DefaultPenStyle), cad.DefaultPenColor, ord(cad.DefaultBrushStyle), cad.DefaultBrushColor, LHandle, mydsNormal,aOwner); TUserRectangle(Result).UserClass := Cad.CurrentUserClass; end; function TUserRectangle.duplicate:TFigure; var res : TUserRectangle; begin res := TUserRectangle.create( originalpoints[1].x, originalpoints[1].y, originalpoints[3].x, originalpoints[3].y, width, style, color, brs, brc, LayerHandle, DrawStyle,Owner); res.angle := angle; res.actualpoints[1] := actualpoints[1]; res.actualpoints[2] := actualpoints[2]; res.actualpoints[3] := actualpoints[3]; res.actualpoints[4] := actualpoints[4]; res.originalpoints[1] := originalpoints[1]; res.originalpoints[2] := originalpoints[2]; res.originalpoints[3] := originalpoints[3]; res.originalpoints[4] := originalpoints[4]; res.rotPoint.x := rotPoint.x ; res.rotPoint.y := rotPoint.y ; res.AngleToPoint := AngleToPoint; res.UserClass := UserClass; result := res; end; function TUserRectangle.isPointIn(x, y: double): boolean; var cad: TPCDrawing; test: Boolean; begin if assigned(Owner) then begin cad := TPCDrawing(Owner); if not Cad.PointInUserFigureEvent(UserClass,Handle,x,y,Test) then result := inherited isPointIn(x,y) else result := Test; end else begin result := inherited isPointIn(x,y); end; end; function TUserRectangle.GetClassName: String; begin result := 'UserRectangle'; end; { TUserLine } class function TUserLine.CreateFromShadow(aOwner: TComponent; LHandle: Integer; Shadow: TFigure): TFigure; var cad: TPCDrawing; begin cad := TPCDrawing(aOwner); Result := TUserLine.create( Shadow.ActualPoints[1].x, Shadow.ActualPoints[1].y, Shadow.ActualPoints[2].x, Shadow.ActualPoints[2].y, cad.DefaultPenWidth, ord(cad.DefaultPenStyle), cad.DefaultPenColor, ord(cad.DefaultRowStyle), LHandle,mydsNormal,cad); TUserLine(Result).UserClass := Cad.CurrentUserClass; end; procedure TUserLine.draw(DEngine: TPCDrawEngine; isGrayed: Boolean); var cad: TPCDrawing; begin if assigned(Owner) then begin cad := TPCDrawing(Owner); DEngine.Canvas.Pen.Mode := pmCopy; if not Cad.DrawUserFigureEvent(UserClass,DEngine.Canvas.Handle,Handle,isGrayed) then inherited; end else begin inherited; end; end; function TUserLine.duplicate: TFigure; var res : TUserLine; begin res := TUserLine.create( originalpoints[1].x, originalpoints[1].y, originalpoints[2].x, originalpoints[2].y, width, style, color, RowStyle, LayerHandle, DrawStyle,Owner); res.angle := angle; res.actualpoints[1] := actualpoints[1]; res.actualpoints[2] := actualpoints[2]; res.actualpoints[1] := actualpoints[1]; res.actualpoints[2] := actualpoints[2]; res.rotpoint.x := rotpoint.x ; res.rotpoint.y := rotpoint.y ; res.AngleToPoint := AngleToPoint; res.UserClass := UserClass; result := res; end; function TUserLine.GetClassName: String; begin result := 'UserLine'; end; function TUserLine.isPointIn(x, y: double): boolean; var cad: TPCDrawing; test: Boolean; begin if assigned(Owner) then begin cad := TPCDrawing(Owner); if not Cad.PointInUserFigureEvent(UserClass,Handle,x,y,Test) then result := inherited isPointIn(x,y) else result := Test; end else begin result := inherited isPointIn(x,y); end; end; { TUserVertex } class function TUserVertex.CreateFromShadow(aOwner: TComponent; LHandle: Integer; Shadow: TFigure): TFigure; var cad: TPCDrawing; begin cad := TPCDrawing(aOwner); result := TUserVertex.create(shadow.ap1.x,shadow.ap1.y,LHandle,mydsNormal,aOwner); TUserVertex(Result).UserClass := Cad.CurrentUserClass; end; procedure TUserVertex.draw(DEngine: TPCDrawEngine; isGrayed: Boolean); var cad: TPCDrawing; begin if assigned(Owner) then begin cad := TPCDrawing(Owner); DEngine.Canvas.Pen.Mode := pmCopy; if not Cad.DrawUserFigureEvent(UserClass,DEngine.Canvas.Handle,Handle,isGrayed) then inherited; end else begin inherited; end; end; function TUserVertex.duplicate: TFigure; begin result := TVertex.create(originalpoints[1].x, originalpoints[1].y, LayerHandle, DrawStyle,Owner); result.actualpoints[1] := actualpoints[1]; result.AngleToPoint := AngleToPoint; TUserVertex(Result).UserClass := UserClass; end; function TUserVertex.GetClassName: String; begin result := 'UserVertext'; end; function TUserVertex.isPointIn(x, y: double): boolean; var cad: TPCDrawing; test: Boolean; begin if assigned(Owner) then begin cad := TPCDrawing(Owner); if not Cad.PointInUserFigureEvent(UserClass,Handle,x,y,Test) then result := inherited isPointIn(x,y) else result := Test; end else begin result := inherited isPointIn(x,y); end; end; { TUserCircle } class function TUserCircle.CreateFromShadow(aOwner: TComponent; LHandle: Integer; Shadow: TFigure): TFigure; var cad: TPCDrawing; begin cad := TPCDrawing(aOwner); Result := TUserCircle.create(shadow.ap1.x,shadow.ap1.y, shadow.radius, cad.DefaultPenWidth, ord(cad.DefaultPenStyle), cad.DefaultPenColor, ord(cad.DefaultBrushStyle), cad.DefaultBrushColor, LHandle, mydsNormal,aOwner); TUserCircle(Result).UserClass := Cad.CurrentUserClass; end; procedure TUserCircle.draw(DEngine: TPCDrawEngine; isGrayed: Boolean); var cad: TPCDrawing; begin if assigned(Owner) then begin DEngine.Canvas.Pen.Mode := pmCopy; cad := TPCDrawing(Owner); DEngine.Canvas.Pen.Mode := pmCopy; if not Cad.DrawUserFigureEvent(UserClass,DEngine.Canvas.Handle,Handle,isGrayed) then inherited; end else begin inherited; end; end; function TUserCircle.duplicate: TFigure; var res : TuserCircle; begin res := TUserCircle.create( originalpoints[1].x, originalpoints[1].y, radius, width, style, color, brs, brc, LayerHandle, drawstyle,Owner); res.angle := angle; res.actualpoints[1] := actualpoints[1]; res.rotPoint.x := rotPoint.x ; res.rotPoint.y := rotPoint.y ; res.AngleToPoint := AngleToPoint; res.UserClass := UserClass; result := res; end; function TUserCircle.GetClassName: String; begin result := 'UserCircle'; end; function TUserCircle.isPointIn(x, y: double): boolean; var cad: TPCDrawing; test: Boolean; begin if assigned(Owner) then begin cad := TPCDrawing(Owner); if not Cad.PointInUserFigureEvent(UserClass,Handle,x,y,Test) then result := inherited isPointIn(x,y) else result := Test; end else begin result := inherited isPointIn(x,y); end; end; { TUserArc } class function TUserArc.CreateFromShadow(aOwner: TComponent; LHandle: Integer; Shadow: TFigure): TFigure; var cad: TPCDrawing; begin cad := TPCDrawing(aOwner); Result := TUserArc.Create( shadow.ap1.x, shadow.ap1.y, shadow.radius, TArc(Shadow).SAngle, TArc(Shadow).FAngle, cad.DefaultPenWidth, ord(cad.DefaultPenStyle), cad.DefaultPenColor, ord(cad.DefaultBrushStyle), cad.DefaultBrushColor, ord(cad.DefaultArcStyle),LHandle,mydsNormal,aOwner); TUserArc(Result).UserClass := Cad.CurrentUserClass; end; procedure TUserArc.draw(DEngine: TPCDrawEngine; isGrayed: Boolean); var cad: TPCDrawing; begin if assigned(Owner) then begin cad := TPCDrawing(Owner); DEngine.Canvas.Pen.Mode := pmCopy; if not Cad.DrawUserFigureEvent(UserClass,DEngine.Canvas.Handle,Handle,isGrayed) then inherited; end else begin inherited; end; end; function TUserArc.duplicate: TFigure; var res : TUserArc; begin res := TUserArc.create( originalpoints[1].x, originalpoints[1].y, radius, sAngle, FAngle, width, style, color, brs, brc, ord(ArcStyle), LayerHandle, DrawStyle,Owner); res.angle := angle; res.actualpoints[1] := actualpoints[1]; res.actualpoints[2] := actualpoints[2]; res.actualpoints[3] := actualpoints[3]; res.originalpoints[1] := originalpoints[1]; res.originalpoints[2] := originalpoints[2]; res.originalpoints[3] := originalpoints[3]; res.rotPoint.x := rotPoint.x ; res.rotPoint.y := rotPoint.y ; res.AngleToPoint := AngleToPoint; res.UserClass := UserClass; result := res; end; function TUserArc.GetClassName: String; begin result := 'UserArc'; end; function TUserArc.isPointIn(x, y: double): boolean; var cad: TPCDrawing; test: Boolean; begin if assigned(Owner) then begin cad := TPCDrawing(Owner); if not Cad.PointInUserFigureEvent(UserClass,Handle,x,y,Test) then result := inherited isPointIn(x,y) else result := Test; end else begin result := inherited isPointIn(x,y); end; end; { TUserEllipse } class function TUserEllipse.CreateFromShadow(aOwner: TComponent; LHandle: Integer; Shadow: TFigure): TFigure; var cad: TPCDrawing; begin cad := TPCDrawing(aOwner); Result := TUserEllipse.create(shadow.ap1.x,shadow.ap1.y, TEllipse(Shadow).alen, TEllipse(Shadow).blen, TEllipse(Shadow).Angle, cad.DefaultPenWidth, ord(cad.DefaultPenStyle), cad.DefaultPenColor, ord(cad.DefaultBrushStyle), cad.DefaultBrushColor, LHandle, mydsNormal,aOwner); Result.UserClass := Cad.CurrentUserClass; end; procedure TUserEllipse.draw(DEngine: TPCDrawEngine; isGrayed: Boolean); var cad: TPCDrawing; begin if assigned(Owner) then begin cad := TPCDrawing(Owner); DEngine.Canvas.Pen.Mode := pmCopy; if not Cad.DrawUserFigureEvent(UserClass,DEngine.Canvas.Handle,Handle,isGrayed) then inherited; end else begin inherited; end; end; function TUserEllipse.duplicate: TFigure; var res : TUserEllipse; begin res := TUserEllipse.create( originalpoints[1].x, originalpoints[1].y, alen, blen, angle, width, style, color, brs, brc, LayerHandle, DrawStyle,Owner); res.angle := angle; res.actualpoints[1] := actualpoints[1]; res.actualpoints[2] := actualpoints[2]; res.actualpoints[3] := actualpoints[3]; res.rotPoint.x := rotPoint.x ; res.rotPoint.y := rotPoint.y ; res.AngleToPoint := AngleToPoint; res.userClass := UserClass; result := res; end; function TUserEllipse.GetClassName: String; begin result := 'UserEllipse'; end; function TUserEllipse.isPointIn(x, y: double): boolean; var cad: TPCDrawing; test: Boolean; begin if assigned(Owner) then begin cad := TPCDrawing(Owner); if not Cad.PointInUserFigureEvent(UserClass,Handle,x,y,Test) then result := inherited isPointIn(x,y) else result := Test; end else begin result := inherited isPointIn(x,y); end; end; { TUserPolyline } class function TUserPolyline.CreateFromShadow(aOwner: TComponent; LHandle: Integer; Shadow: TFigure): TFigure; var cad: TPCDrawing; points: TDoublePointArr; a: integer; begin cad := TPCDrawing(aOwner); SetLength(points,Shadow.PointCount-2); for a := 1 to Shadow.PointCount-2 do begin points[a-1] := Shadow.ActualPoints[a]; end; result := TUserPolyline.create(points, cad.DefaultPenWidth, ord(cad.DefaultPenStyle), cad.DefaultPenColor, ord(cad.DefaultBrushStyle), cad.DefaultBrushColor, ord(cad.DefaultRowStyle), Cad.DefaultPLineClosed, LHandle,mydsNormal,aOwner); Result.USerClass := Cad.CurrentUserClass; end; procedure TUserPolyline.draw(DEngine: TPCDrawEngine; isGrayed: Boolean); var cad: TPCDrawing; begin if assigned(Owner) then begin cad := TPCDrawing(Owner); DEngine.Canvas.Pen.Mode := pmCopy; if not Cad.DrawUserFigureEvent(UserClass,DEngine.Canvas.Handle,Handle,isGrayed) then inherited; end else begin inherited; end; end; function TUserPolyline.duplicate: TFigure; var res : TPolyLine; newpoints : TDoublePointArr; a: integer; ps: TBezierPoint; begin SetLength(newPoints,2); newPoints[0] := ap1; newPoints[1] := ap2; res := TPolyLine.create( newPoints, width, style, color, brs, brc, RowStyle, Closed, LayerHandle, DrawStyle,Owner); res.angle := angle; res.PointCount := PointCount; for a := 1 to PointCount do begin res.originalpoints[a] := originalpoints[a]; res.actualpoints[a] := actualpoints[a] ; end; res.ClearSegments; for a := 0 to Segments.Count-1 do res.Segments.Add(TplSegment(segments[a]).Duplicate); res.rotPoint.x := rotpoint.x ; res.rotPoint.y := rotpoint.y ; res.AngleToPoint := AngleToPoint; if assigned(PenPattern) then res.PenPattern := PenPattern.Duplicate else res.PenPattern := nil; res.UserClass := UserClass; result := res; end; function TUserPolyline.GetClassName: String; begin result := 'UserPolyline'; end; function TUserPolyline.isPointIn(x, y: double): boolean; var cad: TPCDrawing; test: Boolean; begin if assigned(Owner) then begin cad := TPCDrawing(Owner); if not Cad.PointInUserFigureEvent(UserClass,Handle,x,y,Test) then result := inherited isPointIn(x,y) else result := Test; end else begin result := inherited isPointIn(x,y); end; end; { TFreeHand } function TFreeHand.ShadowClick(ClickIndex: Integer; x, y: Double): Boolean; begin result := false; if clickindex > 1 then begin result := true; Info := ''; end; end; function TFreeHand.ShadowTrace(ClickIndex: Integer; x, y: Double): Boolean; var dx,dy: Double; begin result := false; dx := ABS(actualPoints[1].x - x); dy := ABS(actualPoints[1].y - y); if (dx > 5) or (dy > 5) then Info := 'X'; if (Info = 'X') and (PointCount > 2) and (dx < 3) and (dy < 3) then begin x := actualPoints[1].x; y := actualPoints[1].y; end; if not ((PointCount > 0) and eqd(x,actualPoints[PointCount].x) and eqd(y,actualPoints[PointCount].y)) then begin PointCount := PointCount+1; actualPoints[PointCount] := DoublePoint(x,y); end; end; class Function TFreeHand.CreateShadow(x,y:Double): TFigure; var points: TDoublePointArr; begin SetLength(points,2); points[0] := DoublePoint(x,y); points[1] := DoublePoint(x,y); CreateShadow := TFreeHand.create(Points,1,1,clLime,0,0,ord(rsNone),false,0,dsTrace,nil); CreateShadow.PointCount := 1; end; procedure TFigure.SetInCombined(const Value: Boolean); begin fIncombined := Value; end; function TFreeHand.GetClassName: String; begin result := 'FreeHand'; end; { TCDimLine } class function TCDimLine.CreateFromShadow(aOwner: TComponent; LHandle: Integer; Shadow: TFigure): TFigure; var x3,y3: Double; p3: TDoublePoint; begin result := TCDimLine.Create(LHandle,mydsNormal,aOwner); result.ActualPoints[1] := Shadow.ActualPoints[1]; result.ActualPoints[2] := Shadow.ActualPoints[2]; x3 := Shadow.ActualPoints[3].x; y3 := Shadow.ActualPoints[3].y; PointToParallelLine(Shadow.ActualPoints[1],Shadow.ActualPoints[2],x3,y3); result.ActualPoints[3] := DoublePoint(x3,y3); TCDimline(result).LStyle := TCDimline(Shadow).Lstyle; TCDimline(result).EndType := TCDimline(Shadow).EndType; end; Procedure TCDimLine.Initialize; begin inherited; PointCount := 2; Prefix := 'Ш'; OuterGuide := True; InnerGuide := False; HorzText := True; end; procedure TCDimLine.getRotatePoints(ModList: TList); var CControl: TPCDrawing; figMaxX, figMaxY, figMinX,figMinY:Double; p1,p2,p3,p4,p5: TDoublePoint; a: integer; begin if not assigned(owner) then exit; CControl :=TPCDrawing(Owner); getbounds(figMaxX,figMaxY,figMinX,figMinY); p1 := ap1; p2 := ap1; p3 := ap2; p4 := ap2; RotPoint := MPoint(ap1,ap2); ModList.Add(CControl.RegisterModPoint(self,ptRotPoint,ptCircle,clGreen,pointdim,p1.x,p1.y,1)); ModList.Add(CControl.RegisterModPoint(self,ptRotPoint,ptCircle,clGreen,pointdim,p2.x,p2.y,2)); ModList.Add(CControl.RegisterModPoint(self,ptRotPoint,ptCircle,clGreen,pointdim,p3.x,p3.y,3)); ModList.Add(CControl.RegisterModPoint(self,ptRotPoint,ptCircle,clGreen,pointdim,p4.x,p4.y,4)); ModList.Add(CControl.RegisterModPoint(self,ptRotCenter,ptRCenter,clRed,pointdim,RotPoint.x,RotPoint.y,5)); end; function TCDimLine.CreateModification: TFigure; begin result := TCDimLine.Create(0,dsTrace,nil); result.ActualPoints[1] := ActualPoints[1]; result.ActualPoints[2] := ActualPoints[2]; result.ActualPoints[3] := ActualPoints[3]; result.color := clLime; result.RotPoint := RotPoint; TCDimLine(result).EndType := EndType; TCDimLine(result).Lstyle := Lstyle; end; class function TCDimLine.CreateShadow(x, y: Double): TFigure; begin result := TCDimline.Create(0,dsTrace,nil); result.ActualPoints[1] := DoublePoint(x,y); result.ActualPoints[2] := DoublePoint(x,y); result.ActualPoints[3] := DoublePoint(x,y); result.color := clLime; TCDimLine(result).Lstyle := clsInner; TCDimLine(result).HorzText := False; end; procedure TCDimLine.Draw(DEngine: TPCDrawEngine; isGrayed: Boolean); var acolor : Tcolor; text:string; dist: double; l: integer; st: TFontStyles; begin aColor := Color; if (aColor = -255) and (LayerHandle <> 0) then begin aColor := TLayer(LayerHandle).PenColor; end; if isGrayed then acolor := TPCDrawing(Owner).FGrayedColor; //06.08.2012 GrayedColor; if DrawStyle = dsTrace then DEngine.Canvas.pen.mode := pmXor else DEngine.canvas.pen.mode := pmCopy; if DrawStyle = dsTrace then RegHandle := 1; text := ''; if DrawStyle = mydsNormal then begin if autotext then begin if assigned(owner) then MapScale := TPCDrawing(Owner).MapScale; dist := (GetLineLenght(ap1,ap2) *MapScale)/1000; dist := round(dist*100)/100; text := FormatFloat(ffMask, dist)+ ' m'; if assigned(Owner) and (TPCDrawing(Owner).RulerSystem = rsWhitworth) then begin dist := (((GetLineLenght(ap1,ap2) *MapScale)/10)/2.54)/12; dist := round(dist*100)/100; text := FormatFloat(ffMask, dist)+ ' ft'; end; text := Prefix+text+Suffix; end else text := DLabel; end; st := []; if TextBold then st := st + [fsBold]; if TextItalic then st := st + [fsItalic]; DEngine.DrawCircleDim(ap1,ap2,Text,TextFont,st,aColor,TextColor,TextHeight,LStyle, TextPos,EndType,HorzText,OuterGuide,InnerGuide,RegHandle); // Tolik if RegHandle > 1 then begin GetRegObject; if (TBrushStyle(brs) <> bsClear) then RegObject.CheckPointByRects := True; deleteObject(RegHandle); RegHandle := 0; end; // end; function TCDimLine.Duplicate: TFigure; var res: TCDimLine; begin res := TCDimLine.Create(LayerHandle,DrawStyle,Owner); res.DLabel := Dlabel; res.Prefix := Prefix; res.Suffix := Suffix; res.AutoText := AutoText; res.TextPos := TextPos; res.TextFont := TextFont; res.TextHeight := TextHeight; res.TextBold := TextBold; res.TextItalic := TextItalic; res.EndType := EndType; res.MapScale := MapScale; res.LStyle := Lstyle; res.InnerGuide := InnerGuide; res.OuterGuide := OuterGuide; res.HorzText := HorzText; CopyProperties(res); result := res; end; function TCDimLine.EndModification(CadControl: Pointer; mp: TModPoint; TraceFigure: TFigure; x, y: Double; Shift: TShiftState): boolean; var x3,y3: Double; begin if mp.SeqNbr = 3 then begin PointToParallelLine(ActualPoints[1],ActualPoints[2],x,y); ActualPoints[3] := DoublePoint(x,y); end else begin ActualPoints[mp.SeqNbr] := DoublePoint(x,y); x3 := ActualPoints[3].x; y3 := ActualPoints[3].y; PointToParallelLine(ActualPoints[1],ActualPoints[2],x3,y3); ActualPoints[3] := DoublePoint(x3,y3); LStyle := TCDimLine(TraceFigure).LStyle; end; ResetRegion; Modified := True; end; procedure TCDimLine.Getbounds(var figMaxX, figMaxY, figMinX, figMinY:Double); begin GetRegionBounds(figMaxX, figMaxY, figMinX,figMinY); end; function TCDimLine.IsPointIn(x, y: Double): boolean; begin result := inherited isPointIn(x,y); if result then exit; result := isPointInRegion(x,y); // Tolik result := IsPointInRegionByRegObj(x,y); // end; procedure TCDimLine.MenuClicked(CommandId: integer); var idx: integer; begin idx := commandID-menuIndex; case idx of 1: EndType := etClear; 2: EndType := etRow; 3: EndType := etDot; 4: EndType := etNick; 5: AutoText := not Autotext; 7: TextPos := tpOnLine; 8: TextPos := tpAbove; 9: TextPos := tpBelow; 11: LStyle := clsInner; 12: LStyle := clsLeft; 13: LStyle := clsRight; 14: HorzText := not HorzText; 15: InnerGuide := not InnerGuide; 16: OuterGuide := not OuterGuide; end; ResetRegion; Modified := true; end; procedure TCDimLine.SetPropertyFromStream(xCode: Byte; data: pointer; size: integer); begin Case xcode of 90 : TextBold := ((pByte(data)^) = 1); 91 : TextItalic := ((pByte(data)^) = 1); 92 : AutoText := ((pByte(data)^) = 1); 93 : HorzText := ((pByte(data)^) = 1); 94 : TextPos := TDimTextPos(pByte(data)^); 95 : EndType := TEndType(pByte(data)^); 96 : LStyle := TCDimLabelStyle(pByte(data)^); 97 : InnerGuide := ((pByte(data)^) = 1); 98 : OuterGuide := ((pByte(data)^) = 1); 180: DLabel := string(pchar(data)); 181: Prefix := string(pchar(data)); 182: Suffix := string(pchar(data)); 183: TextFont := string(pchar(data)); 220: TextHeight := pDouble(data)^; end; end; function TCDimLine.ShadowClick(ClickIndex:Integer; x, y:Double): Boolean; begin result := false; ActualPoints[ClickIndex] := DoublePoint(x,y); if ClickIndex = 2 then begin result := true; ActualPoints[3] := DoublePoint(x,y); end; end; function TCDimLine.ShadowTrace(ClickIndex:Integer; x, y: Double): Boolean; begin if ClickIndex = 1 then begin ActualPoints[2] := DoublePoint(x,y); ActualPoints[3] := DoublePoint(x,y); end else if ClickIndex = 2 then begin ActualPoints[3] := DoublePoint(x,y); end; result := true; end; function TCDimLine.TraceModification(CadControl: Pointer; mp: TModPoint; TraceFigure: TFigure; x, y: Double; Shift: TShiftState): boolean; begin TraceFigure.ActualPoints[mp.SeqNbr] := DoublePoint(x,y); end; procedure TCDimLine.UpdateMenu(var popMenu: TPopUpMenu; var sIndex: Integer); var mnItem,mnSub: TMenuItem; begin menuIndex:= sIndex; mnItem := TMenuItem.Create(PopMenu); mnItem.Tag := sIndex; mnItem.Caption := fmEndType; PopMenu.Items.Add(mnItem); mnSub := TMenuItem.Create(PopMenu); mnSub.Caption := fmClearEnd; mnSub.Tag := sIndex+1; if EndType = etClear then mnSub.Checked := True; mnItem.Add(mnSub); mnSub := TMenuItem.Create(PopMenu); mnSub.Caption := fmRowEnd; mnSub.Tag := sIndex+2; if EndType = etRow then mnSub.Checked := True; mnItem.Add(mnSub); mnSub := TMenuItem.Create(PopMenu); mnSub.Caption := fmDotEnd; mnSub.Tag := sIndex+3; if EndType = etDot then mnSub.Checked := True; mnItem.Add(mnSub); mnSub := TMenuItem.Create(PopMenu); mnSub.Caption := fmNickEnd; mnSub.Tag := sIndex+4; if EndType = etNick then mnSub.Checked := True; mnItem.Add(mnSub); mnItem := TMenuItem.Create(PopMenu); mnItem.Tag := sIndex+5; mnItem.Caption := fmAutoLabel; if Autotext then mnItem.Checked := True; PopMenu.Items.Add(mnItem); mnItem := TMenuItem.Create(PopMenu); mnItem.Tag := sIndex+6; mnItem.Caption := fmTextPosition; PopMenu.Items.Add(mnItem); mnSub := TMenuItem.Create(PopMenu); mnSub.Caption := fmOnLine; mnSub.Tag := sIndex+7; if textPos = tpOnline then mnSub.Checked := True; mnItem.Add(mnSub); mnSub := TMenuItem.Create(PopMenu); mnSub.Caption := fmAboveLine; mnSub.Tag := sIndex+8; if textPos = tpAbove then mnSub.Checked := True; mnItem.Add(mnSub); mnSub := TMenuItem.Create(PopMenu); mnSub.Caption := fmBelowLine; mnSub.Tag := sIndex+9; if textPos = tpBelow then mnSub.Checked := True; mnItem.Add(mnSub); mnItem := TMenuItem.Create(PopMenu); mnItem.Tag := sIndex+10; mnItem.Caption := fmLabeling; PopMenu.Items.Add(mnItem); mnSub := TMenuItem.Create(PopMenu); mnSub.Caption := fmInside; mnSub.Tag := sIndex+11; if LStyle = clsInner then mnSub.Checked := True; mnItem.Add(mnSub); mnSub := TMenuItem.Create(PopMenu); mnSub.Caption := fmLeft; mnSub.Tag := sIndex+12; if LStyle = clsLeft then mnSub.Checked := True; mnItem.Add(mnSub); mnSub := TMenuItem.Create(PopMenu); mnSub.Caption := fmRight; mnSub.Tag := sIndex+13; if LStyle = clsRight then mnSub.Checked := True; mnItem.Add(mnSub); mnItem := TMenuItem.Create(PopMenu); mnItem.Tag := sIndex+14; mnItem.Caption := fmAlwaysHorizontal; if Horztext then mnItem.Checked := True; PopMenu.Items.Add(mnItem); mnItem := TMenuItem.Create(PopMenu); mnItem.Tag := sIndex+15; mnItem.Caption := fmInnerGuide; if InnerGuide then mnItem.Checked := True; PopMenu.Items.Add(mnItem); mnItem := TMenuItem.Create(PopMenu); mnItem.Tag := sIndex+16; mnItem.Caption := fmOuterGuide; if OuterGuide then mnItem.Checked := True; PopMenu.Items.Add(mnItem); sIndex := sIndex+17; end; procedure TCDimLine.WriteToStream(Stream: TStream); var xByte: Byte; xInt: Integer; xStr: String; xDbl: Double; begin inherited; xStr := DLabel;WriteStrField(180,Stream,xStr); xStr := Prefix;WriteStrField(181,Stream,xStr); xStr := Suffix;WriteStrField(182,Stream,xStr); xStr := TextFont;WriteStrField(183,Stream,xStr); xDbl := TextHeight; WriteField(220,Stream,xDbl,8); if TextBold then xByte := 1 else xByte := 0; WriteField(90,Stream,xByte,1); if TextItalic then xByte := 1 else xByte := 0; WriteField(91,Stream,xByte,1); if AutoText then xByte := 1 else xByte := 0; WriteField(92,Stream,xByte,1); if HorzText then xByte := 1 else xByte := 0; WriteField(93,Stream,xByte,1); xByte := ord(TextPos);WriteField(94,Stream,xByte,1); xByte := ord(EndType);WriteField(95,Stream,xByte,1); xByte := ord(LStyle);WriteField(96,Stream,xByte,1); if InnerGuide then xByte := 1 else xByte := 0; WriteField(97,Stream,xByte,1); if OuterGuide then xByte := 1 else xByte := 0; WriteField(98,Stream,xByte,1); end; function TCDimLine.GetClassName: String; begin result := 'CDimLine'; end; { TArcDimLine } class function TArcDimLine.CreateFromShadow(aOwner: TComponent; LHandle: Integer; Shadow: TFigure): TFigure; var cad: TPCDrawing; begin cad := TPCDrawing(aOwner); Result := TArcDimline.Create( shadow.ap1.x, shadow.ap1.y, shadow.radius, TArc(Shadow).SAngle, TArc(Shadow).FAngle,LHandle,mydsNormal,aOwner); TArcDimline(Result).GuideLen := shadow.radius; end; function TArcDimLine.CreateModification: TFigure; begin result := TArcDimLine.create(ap1.x, ap1.y, Radius, SAngle, FAngle,0,dsTrace,nil); TArcDimLine(result).LStyle := LStyle; TArcDimLine(result).GuideLen := GuideLen; TArcDimLine(result).DrawGuides := DrawGuides; result.color := clLime; result.RotPoint := RotPoint; end; class function TArcDimLine.CreateShadow(x, y: Double): TFigure; begin result := TArcDimline.create(x,y,0,0,0,0,dsTrace,nil); result.color := clLime; end; procedure TArcDimLine.Draw(DEngine: TPCDrawEngine; isGrayed: Boolean); var acolor,bcolor : Tcolor; dx,dy: real; Angle,rad,MAngle: Double; p4,p1,p2: TDOublePoint; st: TFontstyles; text: String; gLen: Double; begin //07.10.2011 - сброс углов для пересчета, если вышли за пределы 2*pi if (DrawStyle = mydsNormal) and ((FAngle > 2*pi) or (SAngle > 2*pi)) then begin SAngle := 0; FAngle := 0; end; if (FAngle = 0) and (SAngle = 0) and (DrawStyle = mydsNormal) then begin Angle := GetradOfLine(ap1,ap2); SAngle := Angle; Angle := GetradOfLine(ap1,ap3); FAngle := Angle; end; acolor := color; if (aColor = -255) and (LayerHandle <> 0) then begin aColor := TLayer(LayerHandle).PenColor; end; if (isGrayed) then begin acolor := TPCDrawing(Owner).FGrayedColor; //06.08.2012 GrayedColor; end; if DrawStyle = dsTrace then DEngine.Canvas.Pen.Mode := pmXor else DEngine.Canvas.Pen.Mode := pmCopy; st := []; if TextBold then st := st + [fsBold]; if TextItalic then st := st + [fsItalic]; text := ''; if DrawStyle = mydsNormal then begin if autotext then begin if FAngle = SAngle then begin MAngle := 2*PI; end else begin if (FAngle < SAngle) then begin MAngle := 2*Pi - SAngle+ FAngle; end else begin MAngle := FAngle-SAngle; end; end; text := FloatToStr(Round2((MAngle/PI)*180)); //07.10.2011 inttostr(round((MAngle/PI)*180)); text := Prefix+text+Suffix; end else text := DLabel; end; if DrawGuides then gLen := GuideLen else gLen := 0; Dengine.DrawArcDim(ap1,radius,SAngle,FAngle,text,TextFont,st,aColor,TextColor,TextHeight,gLen,LStyle, RegHandle,p1,p2); actualpoints[2] := p1; actualpoints[3] := p2; // Tolik if RegHandle > 1 then begin GetRegObject; if TBrushStyle(brs) <> bsClear then RegObject.CheckPointByRects := True; deleteObject(RegHandle); RegHandle := 0; end; // end; function TArcDimLine.Duplicate: TFigure; var res : TArcDimLine; begin res := TArcDimLine.create( originalpoints[1].x, originalpoints[1].y, radius, sAngle, FAngle, LayerHandle, DrawStyle,Owner); res.angle := angle; res.actualpoints[1] := actualpoints[1]; res.actualpoints[2] := actualpoints[2]; res.actualpoints[3] := actualpoints[3]; res.originalpoints[1] := originalpoints[1]; res.originalpoints[2] := originalpoints[2]; res.originalpoints[3] := originalpoints[3]; res.rotPoint.x := rotPoint.x ; res.rotPoint.y := rotPoint.y ; res.AngleToPoint := AngleToPoint; res.GuideLen := GuideLen; result := res; end; function TArcDimLine.EndModification(CadControl: Pointer; mp: TModPoint; TraceFigure: TFigure; x, y: double; Shift: TShiftState): boolean; var Angle: Double; cp: TDoublepoint; r: Double; bool:Boolean; begin bool := (radius = GuideLen); result := Inherited EndModification(CadControl,mp,TraceFigure,x,y,shift); if mp.SeqNbr = 4 then begin if bool then GuideLen := Radius; if GuideLen > Radius then GuideLen := Radius; end else if mp.SeqNbr = 5 then begin cp := ap1; R := sqrt( sqr(x - cp.x)+sqr(y - cp.y) ); GuideLen := Radius-r; end; end; procedure TArcDimLine.Getbounds(var figMaxX, figMaxY, figMinX, figMinY: Double); begin inherited GetBounds(figMaxX, figMaxY, figMinX,figMinY); end; procedure TArcDimLine.getModPoints(ModList: TMyList); var p4: TDoublePoint; MAngle: Double; CControl: TPCDrawing; begin if DrawGuides then begin CControl := TPCDrawing(Owner); if (FAngle < SAngle) then begin MAngle := SAngle+((2*pi)-SAngle+FAngle)/2; end else begin MAngle := (SAngle+FAngle)/2; end; p4 := DoublePoint(ap1.x+Radius-GuideLen,ap1.y); p4 := RotatePoint(ap1,p4,MAngle); ModList.Add(CControl.RegisterModPoint(self,ptArcEnd,ptCircle,clRed,2,p4.x,p4.y,5)); end; inherited GetModPoints(ModList); end; procedure TArcDimLine.Initialize; begin inherited; GuideLen := 10; DrawGuides:= True; Autotext := True; Dlabel := ''; Prefix := ''; Suffix := '°'; TextFont := 'Courier New'; TextHeight:= 4; TextBold:= False; TextItalic:= False; Dlabel := 'Label'; LStyle := rlsInner; TextColor := clBlack; end; Function TArcDimLine.Edit:Boolean; var enterstr: string; begin Result := False; EnterStr := FloatToStr(Round2(GetAngle)); //06.10.2011 DLabel; // if InputQuery(capDimensionLabel, msEnterNewLabelText, EnterStr) then //06.10.2011 if InputQuery(cDrawObjects_Mes4, cDrawObjects_Mes5, EnterStr) then if InputQuery(cDrawObjects_Mes4, cDrawObjects_Mes5, EnterStr) then begin //DLabel := EnterStr; //AutoText := False; //Modified := True; //result := true; result := SetAngle(StrToFloat_My(EnterStr)); end; end; function TArcDimLine.IsPointIn(x, y: Double): boolean; begin result := inherited isPointIn(x,y); if not result then begin result := isPointInRegion(x,y); // Tolik result := IsPointInRegionByRegObj(x,y); // end; end; procedure TArcDimLine.MenuClicked(CommandId: integer); var mnIdx: integer; begin mnIdx := CommandId-MenuIndex; case mnIdx of 0: DrawGuides:= not DrawGuides; 1: LStyle:= rlsInner; 2: LStyle:= rlsOuter; 3: Invert; 4: AutoText := not AutoText; end; end; procedure TArcDimLine.WriteToStream(Stream: TStream); var xByte: Byte; xInt: Integer; xStr: String; xDbl: Double; begin inherited WriteToStream(Stream); xStr := DLabel;WriteStrField(180,Stream,xStr); xStr := Prefix;WriteStrField(181,Stream,xStr); xStr := Suffix;WriteStrField(182,Stream,xStr); xStr := TextFont;WriteStrField(183,Stream,xStr); xDbl := TextHeight; WriteField(230,Stream,xDbl,8); xDbl := GuideLen; WriteField(231,Stream,xDbl,8); if TextBold then xByte := 1 else xByte := 0; WriteField(100,Stream,xByte,1); if TextItalic then xByte := 1 else xByte := 0; WriteField(101,Stream,xByte,1); if AutoText then xByte := 1 else xByte := 0; WriteField(102,Stream,xByte,1); if DrawGuides then xByte := 1 else xByte := 0; WriteField(103,Stream,xByte,1); xByte := ord(LStyle);WriteField(104,Stream,xByte,1); end; procedure TArcDimLine.SetPropertyFromStream(xCode: Byte; data: pointer; size: integer); begin inherited; Case xcode of 100 : TextBold := ((pByte(data)^) = 1); 101 : TextItalic := ((pByte(data)^) = 1); 102 : AutoText := ((pByte(data)^) = 1); 103 : DrawGuides := ((pByte(data)^) = 1); 104 : LStyle := TArcDimLabelStyle(pByte(data)^); 180: DLabel := string(pchar(data)); 181: Prefix := string(pchar(data)); 182: Suffix := string(pchar(data)); 183: TextFont := string(pchar(data)); 230: TextHeight := pDouble(data)^; 231: GuideLen := pDouble(data)^; end; end; function TArcDimLine.ShadowClick(ClickIndex: Integer; x, y: Double): Boolean; begin result := inherited ShadowClick(ClickIndex,x,y); end; function TArcDimLine.ShadowTrace(ClickIndex: Integer; x, y: Double): Boolean; begin result := inherited ShadowTrace(ClickIndex,x,y); end; function TArcDimLine.TraceModification(CadControl: Pointer; mp: TModPoint; TraceFigure: TFigure; x, y: double; Shift: TShiftState): boolean; begin result := inherited TraceModification(CadControl,mp,TraceFigure,x,y,shift); end; procedure TArcDimLine.UpdateMenu(var popMenu: TPopUpMenu; var sIndex: Integer); var mnItem,subItem:TMenuItem; begin menuIndex := sIndex; mnItem := TMenuItem.Create(PopMenu); mnItem.Caption := fmDrawGuides; mnItem.Tag := sIndex; if DrawGuides then mnItem.Checked := true; PopMenu.Items.Add(mnItem); mnItem := TMenuItem.Create(PopMenu); mnItem.Caption := fmDimPosition; mnItem.Tag := 0; PopMenu.Items.Add(mnItem); subItem := TMenuItem.Create(PopMenu); subItem.Caption := fmInsideArc; subItem.Tag := sIndex+1; if LStyle = rlsInner then subItem.Checked := true; mnItem.Add(subItem); subItem := TMenuItem.Create(PopMenu); subItem.Caption := fmOutsideArc; subItem.Tag := sIndex+2; if LStyle = rlsOuter then subItem.Checked := true; mnItem.Add(subItem); mnItem := TMenuItem.Create(PopMenu); mnItem.Caption := fmInvertArc; mnItem.Tag := sIndex+3; PopMenu.Items.Add(mnItem); mnItem := TMenuItem.Create(PopMenu); mnItem.Caption := fmAutoLabel; mnItem.Tag := sIndex+4; if AutoText then mnItem.Checked := true; PopMenu.Items.Add(mnItem); sIndex := sIndex+5; end; function TFigure.GetEndPoint: TDoublePoint; begin result := FigurePoints[PointCount]; end; function TFigure.GetStartPoint: TDoublePoint; begin result := FigurePoints[1]; end; function TArc.GetEndPoint: TDoublePoint; begin result := ap3; end; function TArc.GetStartPoint: TDoublePoint; begin result := ap2; end; function TElpArc.GetEndPoint: TDoublePoint; begin result := ap3; end; function TElpArc.GetStartPoint: TDoublePoint; begin result := ap2; end; function TFigure.IsWelded(f: Tfigure): Integer; var p1,p2,x1,x2: TDoublePoint; w1,w2: Boolean; begin result := 0; p1 := GetStartPoint; p2 := GetEndPoint; x1 := f.GetStartPoint; x2 := f.GetEndPoint; w1 := EQDP(p1,x1) or EQDP(p1,x2); w2 := EQDP(p2,x1) or EQDP(p2,x2); if (w1 and w2) then result := 3 else if w1 then result := 1 else if w2 then result := 2; end; function TArcDimLine.GetClassName: String; begin result := 'ArcDimLine'; end; function TArcDimLine.ModifyTextAndFont(mm: TModifyMode; valueI: Double; valueS: string; valueSt: TFontStyles; ValueB: Boolean): Boolean; begin result := true; if mm = mmFontName then begin TextFont := ValueS; modified := true; end else if mm = mmFontSize then begin TextHeight := valueI; modified := true; end else if mm = mmFontColor then begin TextColor := Round(valueI); end else if mm = mmFontBold then begin TextBold := ValueB; modified := true; end else if mm = mmFontItalic then begin TextItalic := ValueB; modified := true; end; end; function TArcDimLine.GetAngle: Double; var Angle1, Angle2: Double; begin Result := 0; Angle2 := GetradOfLine(ap1,ap2); Angle1 := GetradOfLine(ap1,ap3); if Angle1 = Angle2 then Result := 2*PI else begin if (Angle1 < Angle2) then Result := 2*Pi - Angle2+ Angle1 else Result := Angle1-Angle2; end; Result := Result *(180/pi); end; procedure TArcDimLine.Scale(percentx, percenty: Double; rPoint: TDoublePoint); var p1,p2:TDoublePoint; cp: TDoublePOint; division: Double; Begin division := $FFFF; if GuideLen > 0 then division := Radius / GuideLen; Inherited; if (division <> $FFFF) and (division <> 0) then GuideLen := Radius / division; end; function TArcDimLine.SetAngle(AValue: Double): Boolean; var NewAngle, AngleDelta: Double; begin Result := false; if (FAngle = 0) and (SAngle = 0) then begin SAngle := GetradOfLine(ap1,ap2); FAngle := GetradOfLine(ap1,ap3); end; if (AValue >= 0) and (AValue <= 360) then begin NewAngle := (AValue/180)*pi; //if (NewAngle = 0) or (NewAngle = 2*Pi) then //begin // SAngle := 0; // FAngle := 0; //end //else begin AngleDelta := 0; if (FAngle < SAngle) then begin AngleDelta := NewAngle - (2*Pi - SAngle + FAngle); SAngle := SAngle - AngleDelta; if SAngle > 2*pi then SAngle := SAngle - (2*pi); end else begin AngleDelta := NewAngle - (FAngle-SAngle); FAngle := FAngle + AngleDelta; if FAngle > 2*pi then FAngle := FAngle - (2*pi); end; // Если углы почти одинаковы if Abs(FAngle - SAngle) < 0.01 then SAngle := FAngle; Result := true; ResetRegion; Modified := True; end; end; end; constructor TArcDimLine.Create(cx, cy, rad, a1, a2: Double; LHandle: Integer; aDrawStyle: TDrawStyle; aOwner: TComponent); begin inherited Create(cx,cy,rad,a1,a2,1,ord(psSolid),clBlack,ord(bsClear), clWhite,ord(asOpen),LHandle,adrawStyle,aOwner) end; { TElpArc } constructor TElpArc.create(cx, cy, radA, radB, a1, a2: Double;aAngle:Double; w, s, c, abrs, abrc, aArcStyle, LHandle: Integer; aDrawStyle: TDrawStyle; aOwner: TComponent); begin inherited create(LHandle,aDrawStyle,aOwner); Initialize; originalpoints[1] := DoublePoint(cx,cy); actualpoints[1] := DoublePoint(cx,cy); originalpoints[2] := DoublePoint(cx,cy); actualpoints[2] := DoublePoint(cx,cy); originalpoints[3] := DoublePoint(cx,cy); actualpoints[3] := DoublePoint(cx,cy); originalpoints[4] := RotatePoint(ap1,DoublePoint(ap1.x + radA,ap1.y),aAngle); actualpoints[4] := Originalpoints[4]; SAngle:= a1; FAngle:= a2; ALen := rada; BLen := radb; ArcStyle := TArcStyle(aArcStyle); width := w; color := c; style := s; brs := abrs; brc := abrc; angle := aAngle; end; function TElpArc.CreateModification: TFigure; begin result := TElpArc.create(ap1.x, ap1.y, ALen, BLen, SAngle, FAngle, Angle, 1,1,clLime,0,0,0,0,dsTrace,nil); Result.ActualPoints[1] := ap1; Result.ActualPoints[2] := ap2; Result.ActualPoints[3] := ap3; Result.ActualPoints[4] := ap4; TElpArc(result).ArcStyle := asOpen; //TElpArc(result).Angle := Angle; result.RotPoint := RotPoint; end; class function TElpArc.CreateShadow(x, y: Double): TFigure; begin result := TElpArc.create(x,y,0.1,0.1,0,0,0,1,1,clLime,0,0,0,0,dsTrace,nil); end; procedure TElpArc.Initialize; begin inherited; pointcount := 4; end; function TElpArc.EndModification(CadControl: Pointer;mp: TModPoint; TraceFigure: TFigure; x,y: Double;Shift: TShiftState): boolean; var xAngle: Double; p1: TDoublepoint; begin p1 := DoublePoint(x,y); if mp.SeqNbr = 2 then begin p1 := RotatePoint(ap1,p1,-1*Angle); xAngle := GetRadOfLine(ap1,p1); SAngle := xAngle; end else if mp.SeqNbr = 3 then begin p1 := RotatePoint(ap1,p1,-1*Angle); xAngle := GetRadOfLine(ap1,p1); FAngle := xAngle; end else if (mp.SeqNbr = 4) then begin ALen := sqrt( sqr(x - ap1.x)+sqr(y - ap1.y)); end else if (mp.SeqNbr = 5) then begin BLen := sqrt( sqr(x - ap1.x)+sqr(y - ap1.y)); end else if (mp.SeqNbr = 6) then begin xAngle := GetRadOfLine(ap1,p1); p1 := DoublePoint(ap1.x+ALen,ap1.y); ActualPoints[4] := RotatePoint(ap1,p1,xAngle); end; ResetRegion; Modified := True; end; function TElpArc.ShadowClick(ClickIndex:Integer;x,y: Double): Boolean; var cp,p1: TDoublePoint; begin result := false; Angle := 0; if clickIndex = 2 then begin ALen := sqrt(sqr(x - ap1.x) + sqr(y - ap1.y)); BLen := ALen; end else if clickIndex = 3 then begin BLen := sqrt(sqr(x - ap1.x) + sqr(y - ap1.y)); cp := ap1; p1 := DoublePoint(x,y); p1 := RotatePoint(cp,p1,-1*Angle); SAngle := GetradOfLine(cp,p1); FAngle := SAngle; result := false; end else if clickindex = 4 then begin cp := ap1; p1 := DoublePoint(x,y); p1 := RotatePoint(cp,p1,-1*Angle); FAngle := GetradOfLine(cp,p1); result := true; end; end; class function TElpArc.CreateFromShadow(aOwner: TComponent; LHandle: Integer; Shadow: TFigure): TFigure; var cad: TPCDrawing; begin cad := TPCDrawing(aOwner); Result := TElpArc.Create( shadow.ap1.x, shadow.ap1.y, TElpArc(Shadow).ALen, TElpArc(Shadow).BLen, TElpArc(Shadow).SAngle, TElpArc(Shadow).FAngle, TElpArc(Shadow).Angle, cad.DefaultPenWidth, ord(cad.DefaultPenStyle), cad.DefaultPenColor, ord(cad.DefaultBrushStyle), cad.DefaultBrushColor, ord(cad.DefaultArcStyle),LHandle,mydsNormal,aOwner); end; function TElpArc.ShadowTrace(ClickIndex:Integer;x,y:Double): Boolean; var rad:Double; cp,p1,p2: TDoublepoint; begin Angle := 0; If ClickIndex = 1 then begin rad := sqrt(sqr(x - ap1.x)+ sqr(y - ap1.y)); ALen := rad; BLen := rad; end else If ClickIndex = 2 then begin rad := sqrt(sqr(x - ap1.x)+ sqr(y - ap1.y)); BLen := Rad; cp := ap1; p1 := DoublePoint(x,y); p1 := RotatePoint(cp,p1,-1*Angle); SAngle := GetradOfLine(cp,p1); FAngle := SAngle; end else if ClickIndex = 3 then begin cp := ap1; p1 := DoublePoint(x,y); p1 := RotatePoint(cp,p1,-1*Angle); FAngle := GetradOfLine(cp,p1); end; end; function TElpArc.TraceModification(CadControl: Pointer;mp: TModPoint;TraceFigure:TFigure; x, y: Double;Shift: TShiftState): boolean; var xAngle: Double; p1: TDoublepoint; begin p1 := DoublePoint(x,y); if mp.SeqNbr = 2 then begin p1 := RotatePoint(ap1,p1,-1*Angle); xAngle := GetRadOfLine(ap1,p1); TElpArc(TraceFigure).SAngle := xAngle; end else if mp.SeqNbr = 3 then begin p1 := RotatePoint(ap1,p1,-1*Angle); xAngle := GetRadOfLine(ap1,p1); TElpArc(TraceFigure).FAngle := xAngle; end else if (mp.SeqNbr = 4) then begin TElpArc(TraceFigure).ALen := sqrt( sqr(x - ap1.x)+sqr(y - ap1.y)); end else if (mp.SeqNbr = 5) then begin TElpArc(TraceFigure).BLen := sqrt( sqr(x - ap1.x)+sqr(y - ap1.y)); end else if (mp.SeqNbr = 6) then begin xAngle := GetRadOfLine(ap1,p1); p1 := DoublePoint(ap1.x+ALen,ap1.y); TraceFigure.ActualPoints[4] := RotatePoint(ap1,p1,xAngle); end; end; procedure TElpArc.WriteToStream(Stream: TStream); var xByte: Byte; xInt: Integer; xDbl: Double; begin inherited; if brs = -1 then xByte := 255 else xByte := LoByte(LoWord(brs)); //xByte := brs; WriteField(90,Stream,xByte,1); xByte := ord(ArcStyle); WriteField(91,Stream,xByte,1); xInt := brc; WriteField(20,Stream,xInt,4); xDbl := ALen; WriteField(222,Stream,xDbl,8); xDbl := BLen; WriteField(223,Stream,xDbl,8); xDbl := SAngle; WriteField(220,Stream,xDbl,8); xDbl := FAngle; WriteField(221,Stream,xDbl,8); end; Procedure TElpArc.SetPropertyFromStream(xCode:Byte;data:pointer;size:integer); begin Case xcode of 20: brc := pInt(data)^; 21: Radius := pInt(data)^/10; 90: begin if pByte(data)^ = 255 then brs := -1 else brs := pByte(data)^; end; 91: ArcStyle := TArcStyle(pByte(data)^); 220: SAngle := pDouble(data)^; 221: FAngle := pDouble(data)^; 222: ALen := pDouble(data)^; 223: BLen := pDouble(data)^; end; end; procedure TElpArc.draw(DEngine: TPCDrawEngine;isGrayed:Boolean); var acolor, bColor : Tcolor; dx, dy: real; xAngle: Double; p1, p2: TDOublePoint; aawidth: integer; begin aawidth := width; if width > 1 then begin if TPCDrawing(owner).ZoomScale < 100 then begin aawidth := Trunc(width * (TPCDrawing(owner).ZoomScale / 100)); if aawidth = 0 then aawidth := 1; end; end; if (ap4.y = ap1.y) then begin if (ap4.x > ap1.x) then angle := 0 else angle := pi end else if (ap4.x = ap1.x) then begin if (ap4.y > ap1.y) then angle := -1 * (pi / 2) else angle := pi / 2 end else begin Angle := GetRadOfLine(ap1, ap4); end; Angle := 0; if (FAngle = 0) and (SAngle = 0) then begin p1 := RotatePoint(ap1, ap2, -1 * Angle); p2 := RotatePoint(ap1, ap3, -1 * Angle); xAngle := GetradOfLine(ap1,p1); SAngle := xAngle; xAngle := GetradOfLine(ap1,p2); FAngle := xAngle; end; acolor := color; if (aColor = -255) and (LayerHandle <> 0) then begin aColor := TLayer(LayerHandle).PenColor; end; bColor := brc; if (bColor = -255) and (LayerHandle <> 0) then begin bColor := TLayer(LayerHandle).BrushColor; end; if (isGrayed) then begin acolor := TPCDrawing(Owner).FGrayedColor; //06.08.2012 GrayedColor; bcolor := TPCDrawing(Owner).FGrayedColor; //06.08.2012 GrayedColor; end; if DrawStyle = dsTrace then DEngine.Canvas.Pen.Mode := pmXor else DEngine.Canvas.Pen.Mode := pmCopy; if NeedRegion and (ArcStyle <> asOpen) then DEngine.drawbezelparc(ap1.x,ap1.y,ALen,BLen,SAngle,FAngle,Angle,acolor, aawidth,style, bColor,GDIbrs,Ord(ArcStyle),RegHandle,p1,p2,InCombined,RowStyle); if ArcStyle <> asOpen then DrawFill(Dengine,isGrayed); DrawClipFigures(Dengine,isGrayed); DEngine.drawbezelparc(ap1.x,ap1.y,ALen,BLen,SAngle,FAngle,Angle,acolor, aawidth,style, bColor,GDIbrs,Ord(ArcStyle),RegHandle,p1,p2,InCombined,RowStyle); actualpoints[2] := NormalizePoint(p1); actualpoints[3] := NormalizePoint(p2); // Tolik if RegHandle > 1 then begin GetRegObject; if (TBrushStyle(brs) <> bsClear) then RegObject.CheckPointByRects := True; deleteObject(RegHandle); RegHandle := 0; end; // end; procedure TElpArc.getModPoints(ModList: TMyList); var p4,p5,p6: TDoublePoint; CControl: TPCDrawing; dx,dy: Double; MAngle: Double; begin CControl := TPCDrawing(Owner); p4 := DoublePoint(ap1.x-ALen,ap1.y); p5 := DoublePoint(ap1.x,ap1.y+BLen); p6 := DoublePoint(ap1.x+ALen,ap1.y); p4 := RotatePoint(ap1,p4,Angle); p5 := RotatePoint(ap1,p5,Angle); p6 := RotatePoint(ap1,p6,Angle); if (ALen = 0) and (BLen = 0) then begin ModList.Add(CControl.RegisterModPoint(self,ptArcEnd,ptCircle,clRed,2,p4.x,p4.y,4)); end else begin ModList.Add(CControl.RegisterModPoint(self,ptUndefined,ptCross,clBlue,pointdim,ap1.x,ap1.y,1)); ModList.Add(CControl.RegisterModPoint(self,ptArcEnd,ptRect,clBlue,pointdim,ap2.x,ap2.y,2)); ModList.Add(CControl.RegisterModPoint(self,ptArcEnd,ptRect,clBlue,pointdim,ap3.x,ap3.y,3)); ModList.Add(CControl.RegisterModPoint(self,ptArcEnd,ptRect,clRed,2,p4.x,p4.y,4)); ModList.Add(CControl.RegisterModPoint(self,ptArcEnd,ptRect,clRed,2,p5.x,p5.y,5)); ModList.Add(CControl.RegisterModPoint(self,ptArcEnd,ptCircle,clGreen,4,p6.x,p6.y,6)); end; end; procedure TElpArc.getbounds(var figMaxX,figMaxY,figMinX,figMinY:Double); begin GetArcBounds(ap1,ALen,BLen,ord(arcstyle),sAngle,fAngle,Angle,figMaxX,figMaxY,figMinX,figMinY); end; function TElpArc.isAngleIn(a: Double): boolean; begin if FAngle > SAngle then begin result := Between(a,SAngle,FAngle); end else if FAngle = SAngle then begin result := true; end else begin result := not Between(a,SAngle,FAngle); end; end; function TElpArc.isPointIn(x,y:Double):boolean; var CControl:TPCdrawing; pt: TDoublePoint; a: Double; begin result := false; result := inherited isPointIn(x,y); if result then exit; pt := DoublePoint(x,y); pt := RotatePoint(ap1,pt,-1*angle); a := GetRadOfLine(ap1,pt); result := isPointinEllipse(x,y,ap1.x,ap1.y,Alen,Blen,Angle) and isAngleIn(a); if ((ArcStyle <> asOpen) or (SAngle = FAngle)) and (brs <> ord(bsClear)) then begin if IsPointInRegion(x,y) then result := true; //Tolik if IsPointInRegionByRegObj(x,y) then Result := True; // end; end; function TElpArc.DuplicateAsBezier: TFigure; var Points: T2DPointArray; cnt,cntA,i: Integer; p: TDoublePoint; pp: TDoublePointArr; res: TPolyline; cx,cy: Double; begin cx := ap1.x; cy := ap1.y; BezierElpArcPoints(Points,ap1.x,ap1.y,Alen,Blen,Angle,SAngle,FAngle); cnt := Length(Points); cntA := 0; if arcStyle = asPie then cntA := 6 else if ArcStyle = asChord then cntA := 3; SetLength(pp,cnt+cntA); for i := 0 to cnt-1 do begin p := DoublePoint(Points[i].x,Points[i].y); pp[i] := p; end; if arcStyle = asPie then begin pp[cnt-1+1] := QrPoint(pp[cnt-1],ap1); pp[cnt-1+2] := QrPoint(ap1,pp[cnt-1]); pp[cnt-1+3] := ap1; pp[cnt-1+4] := QrPoint(ap1,pp[0]); pp[cnt-1+5] := QrPoint(pp[0],ap1); pp[cnt-1+6] := pp[0]; end else if ArcStyle = asChord then begin pp[cnt-1+1] := QrPoint(pp[cnt-1],pp[0]); pp[cnt-1+2] := QrPoint(pp[0],pp[cnt-1]); pp[cnt-1+3] := pp[0]; end; SetLength(Points,0); result := TPolyline.createFromBezierPoints(pp,Width,Style,color,Brs,Brc,0, (ArcStyle <> asOpen),Layerhandle,mydsNormal,owner); end; function TElpArc.duplicate:TFigure; var res : TElpArc; begin res := TElpArc.create( originalpoints[1].x, originalpoints[1].y, ALen, BLen, sAngle, FAngle, Angle, width, style, color, brs, brc, ord(ArcStyle), LayerHandle, DrawStyle,Owner); res.angle := angle; res.actualpoints[1] := actualpoints[1]; res.actualpoints[2] := actualpoints[2]; res.actualpoints[3] := actualpoints[3]; res.actualpoints[4] := actualpoints[4]; res.originalpoints[1] := originalpoints[1]; res.originalpoints[2] := originalpoints[2]; res.originalpoints[3] := originalpoints[3]; res.originalpoints[4] := originalpoints[4]; res.rotPoint.x := rotPoint.x ; res.rotPoint.y := rotPoint.y ; res.AngleToPoint := AngleToPoint; result := res; end; function TElpArc.GetLinearInterSections(p1, p2: TDoublePoint; var pArr: TDoublePointArr): Boolean; var np1,np2,pt:TDoublePoint; iCnt,xCnt: Integer; a: Double; begin result := false; if GetLineEllipseIntersection(p1,p2,ap1,aLen,bLen,Angle,np1,np2,icnt,false) then begin xCnt := 0; if iCnt > 0 then begin pt := np1; pt := RotatePoint(ap1,pt,-1*angle); a := GetRadOfLine(ap1,pt); if isPointInEllipse(np1.x,np1.y,ap1.x,ap1.y,aLen,bLen,angle) and isAngleIn(a) then begin xCnt := xcnt+1; SetLength(pArr,xCnt); pArr[xCnt-1] := np1; end; end; if iCnt > 1 then begin pt := np2; pt := RotatePoint(ap1,pt,-1*angle); a := GetRadOfLine(ap1,pt); if isPointInEllipse(np2.x,np2.y,ap1.x,ap1.y,aLen,bLen,angle) and isAngleIn(a) then begin xCnt := xcnt+1; SetLength(pArr,xCnt); pArr[xCnt-1] := np2; end; end; if xCnt > 0 then result := True; end; end; function TElpArc.BreakByPoint(p: TdoublePoint;var Figures: TList): boolean; var a: Double; Fig: Tfigure; pt:TdoublePoint; begin result := false; pt := p; pt := RotatePoint(ap1,pt,-1*angle); a := GetRadOfLine(ap1,pt); if isPointInEllipse(p.x,p.y,ap1.x,ap1.y,aLen,blen,Angle) and isAngleIn(a) then begin fig := TElpArc.create(ap1.x,ap1.y,aLen,bLen,SAngle,a,Angle,width,style,color, brs,brc,ord(arcStyle),LayerHandle,mydsNormal,owner); Figures.Add(fig); fig := TElpArc.create(ap1.x,ap1.y,aLen,bLen,a,Fangle,Angle,width,style,color, brs,brc,ord(arcStyle),LayerHandle,mydsNormal,owner); Figures.Add(fig); result := true; end; end; Procedure TElpArc.Invert; var tA: double; Begin ta := SAngle; Sangle := FAngle; FAngle := ta; Resetregion; Modified := true; End; procedure TElpArc.VerifyZeroPoints(orgV, orgH: Byte); begin inherited; if (orgV <> VertZero) then begin SAngle := 2*pi - SAngle; FAngle := 2*pi - FAngle; Invert; end; if (orgH <> HorzZero) then begin SAngle := pi - SAngle; FAngle := pi - FAngle; Invert; end; end; procedure TElpArc.ArrangeStyle(val: TArcStyle); begin ArcStyle := val; Resetregion; end; Procedure TElpArc.Mirror(Point1,Point2: TDoublePoint); var p1: TDoublePoint; dx,dy:Double; begin inherited Mirror(Point1,Point2); SAngle := 0; FAngle := 0; p1 := ap2; ActualPoints[2] := ap3; ActualPoints[3] := p1; ResetRegion; end; procedure TElpArc.Rotate(aAngle: Double; cPoint: TDoublePoint); var a: integer; point1,point2 :TPoint; pd1 :TDoublePoint; fig: TFigure; Cad: TPCDrawing; elp: TEllipse; ElpArc: TElpArc; Arc: TElpArc; begin inherited; (* Cad := TPCdrawing(owner); Cad.ClearUndoList; Arc := TElpArc(self); fig := Arc; pd1.X := Arc.ap1.x; pd1.y := Arc.ap1.y; pd1 := RotatePoint(cPoint, pd1); ElpArc := TElpArc.create(pd1.x, pd1.y, arc.Radius, arc.Radius, arc.SAngle + aAngle, arc.FAngle + aAngle, arc.Angle, fig.Width, fig.Style, fig.Color, fig.brs, fig.brc, ord(asOpen), fig.LayerHandle, mydsNormal, fig.Owner); // ElpArc.Scale(percentx, percenty, rPoint); Arc.Destroy; *) (* If modified or ((cPoint.x <> rotpoint.x) or (cPoint.y <> rotpoint.y)) then begin angletoPoint := 0; for a := 1 to pointcount do originalpoints[a] := actualpoints[a]; rotpoint.x := cPoint.x; rotpoint.y := cPoint.y; end; angletoPoint := angletoPoint + Aangle; for a:= 1 to pointcount do begin actualpoints[a] := RotatePoint(cPoint,originalpoints[a],angletoPoint); end; if DimLines.Count > 0 then CreateDimLines; if assigned(Fill) then Fill.Rotate(aAngle,cPoint); ResetRegion; *) Fangle := 0; SAngle := 0; draw(GCadForm.PCad.DEngine, False); // SAngle := GetradOfLine(ap1, ap2); // FAngle := GetradOfLine(ap1, ap3); // SAngle := SAngle + aAngle; // if SAngle > 2 * pi then // SAngle := SAngle - 2 * pi; // FAngle := FAngle + aAngle; // if FAngle > 2 * pi then // FAngle := FAngle - 2 * pi; end; Procedure TElpArc.Scale(percentx,percenty: double; rPoint: TDoublepoint); var p1, p2: TDoublePoint; cp: TDoublePOint; x: double; Realp1, Realp2: TDoublePoint; ta: double; a1, a2: double; Begin cp := ap1; Inherited; p1 := DoublePoint(cp.x + Alen, cp.y); p2 := DoublePoint(cp.x, cp.y + Blen); p1 := RotatePoint(cp, p1, Angle); p2 := RotatePoint(cp, p2, Angle); p1 := ScalePoint(rPoint, p1, percentx, percenty); p2 := ScalePoint(rPoint, p2, percentx, percenty); ALen := GetLineLenght(ap1, p1); Blen := GetLineLenght(ap1, p2); a1 := SAngle; a2 := FAngle; if percentx < 0 then begin a1 := a1 + 2 * (pi / 2 - a1); a2 := a2 + 2 * (pi / 2 - a2); ta := a2; a2 := a1; a1 := ta; end; if percenty < 0 then begin a1 := a1 + 2 * (pi - a1); a2 := a2 + 2 * (pi - a2); ta := a2; a2 := a1; a1 := ta; end; Sangle := a1; FAngle := a2; Fangle := 0; SAngle := 0; draw(GCadForm.PCad.DEngine, False); End; procedure TElpArc.MenuClicked(CommandId: integer); var mnIdx: integer; begin mnIdx := CommandId-MenuIndex; case mnIdx of 0: ArcStyle:= asOpen; 1: ArcStyle:= asPie; 2: ArcStyle:= asChord; 3: Invert; end; end; procedure TElpArc.UpdateMenu(var popMenu: TPopUpMenu; var sIndex: Integer); var mnItem:TMenuItem; begin menuIndex := sIndex; mnItem := TMenuItem.Create(PopMenu); mnItem.Caption := fmOpenArc; mnItem.Tag := sIndex; if arcStyle = asOpen then mnItem.Checked := true; PopMenu.Items.Add(mnItem); mnItem := TMenuItem.Create(PopMenu); mnItem.Caption := fmPieArc; mnItem.Tag := sIndex+1; if arcStyle = asPie then mnItem.Checked := true; PopMenu.Items.Add(mnItem); mnItem := TMenuItem.Create(PopMenu); mnItem.Caption := fmChordArc; mnItem.Tag := sIndex+2; if arcStyle = asChord then mnItem.Checked := true; PopMenu.Items.Add(mnItem); mnItem := TMenuItem.Create(PopMenu); mnItem.Caption := fmInvertArc; mnItem.Tag := sIndex+3; PopMenu.Items.Add(mnItem); sIndex := sIndex+4; end; Function TFigure.Knife(p1,p2:TdoublePoint;Figures:TList):Boolean; var pArr: TdoublePointArr; begin result := false; if GetLinearInterSections(p1,p2,pArr) then begin result := BreakByPoints(parr,Figures); SetLength(parr,0); end; end; function TFigure.BreakByPoint(p: TdoublePoint; var Figures: TList): boolean; begin result := false; end; Function TFigure.GetLinearInterSections(p1,p2:TDoublePoint; var pArr:TDoublePointArr):Boolean; begin result := false; end; function TFigure.BreakbyPoints(p: TdoublePointArr; var Figures: TList):Boolean; var pcnt,i,k,fcnt: Integer; p1: TDoublePoint; Fig: Tfigure; iList: Tlist; begin pCnt := Length(p); Figures.Add(Self); result := false; iList := TList.Create; for i := 0 to pcnt-1 do begin k := 0; p1 := p[i]; fcnt := Figures.Count; for k := 0 to fCnt-1 do begin Fig := Tfigure(Figures[k]); if Fig.BreakByPoint(p1,Figures) then begin iList.Add(Fig); result := true; end; end; try for k := 0 to iList.Count - 1 do Figures.Remove(iList[k]); iList.Clear; except // on E: Exception do AddExceptionToLog(CPowerCadMessage + 'TFigure.BreakbyPoints' + E.Message); end; end; Figures.Remove(Self); //Tolik iList.Free; end; function TElpArc.Offset(Thick: Double): TFigure; begin if vertZero = ord(vzBottom) then Thick := -Thick; result := TElpArc.create(ap1.x,ap1.y,aLen-thick,bLen-thick,SAngle,FAngle, angle,width,style,color,brs,brc,ord(arcStyle),LayerHandle,mydsNormal,owner); end; function TElpArc.GetClassName: String; begin result := 'ElpArc'; end; { TKnife } class function TKnife.CreateFromShadow(aOwner: TComponent; LHandle: Integer; Shadow: TFigure): TFigure; var cad: TPCDrawing; begin cad := TPCDrawing(aOwner); cad.KnifeSelection(Shadow.ap1,Shadow.ap2); result := nil; end; class function TKnife.CreateShadow(x, y: Double): TFigure; begin CreateShadow := TKnife.create(DoublePoint(x,y),DoublePoint(x,y)); end; function TFigure.Offset(Thick: Double): TFigure; begin result := nil; end; function TLine.Offset(Thick: Double): TFigure; var p1,p2: TDoublePoint; begin GetParallelPoints(ap1,ap2,p1,p2,Thick); Result := TLine.create(p1.x,p1.y,p2.x,p2.y,Width,Style,Color,ord(RowStyle), LayerHandle,mydsNormal,owner);; end; function TPolyline.Offset(Thick: Double): TFigure; var NewSegments: TList; pArr: TDoublePointArr; pl: TPolyline; mSeg,nSeg: TPLSegment; i,pCnt:Integer; begin result := nil; NewSegments := TList.Create; OffsetSegments(NewSegments,Thick); // Tolik 18/05/2018 -- //if newsegments.Count = 0 then exit; if newsegments.Count = 0 then begin NewSegments.Free; // free mem exit; end; // if Closed then pCnt := newSegments.Count else pCnt := newSegments.Count+1; SetLength(pArr,pCnt); for i := 0 to newSegments.Count-1 do begin pArr[i] := TPLSegment(newSegments[i]).tp1; end; if not Closed then pArr[pCnt-1] := TPLSegment(newSegments[pCnt-2]).tp2; pl := TPolyline.create(pArr,width,style,color,brs,brc,ord(rowStyle), Closed,LayerHandle,mydsNormal,owner); for i := 0 to newSegments.Count - 1 do begin mSeg := TPLSegment(pl.Segments[i]); nSeg := TPLSegment(newSegments[i]); mSeg.CopyFrom(nSeg); end; try for i := 0 to newSegments.Count - 1 do begin TPLSegment(newSegments[i]).Free; end; newSegments.Free; except // on E: Exception do AddExceptionToLog(CPowerCadMessage + 'TPolyline.Offset' + E.Message); end; result := pl; NeedBounds := True; //Tolik 02/08/2021 -- end; function TEllipse.Offset(Thick: Double): TFigure; begin if vertZero = ord(vzBottom) then Thick := -Thick; result := TEllipse.create(ap1.x,ap1.y,aLen-thick,bLen-thick, angle,width,style,color,brs,brc,LayerHandle,mydsNormal,owner); end; function TCircle.Offset(Thick: Double): TFigure; begin if vertZero = ord(vzBottom) then Thick := -Thick; result := TCircle.create(ap1.x,ap1.y,Radius-thick,width,style,color,brs,brc, LayerHandle,mydsNormal,owner); end; function TRectangle.Offset(Thick: Double): TFigure; var p1,p2,p3,p4,cp: TdoublePoint; ang: Double; fig : Tfigure; begin if vertZero = ord(vzBottom) then Thick := -Thick; if (ap4.x = ap3.x) or (ap4.y = ap3.y) then ang := 0 else ang := GetRadOfLine(ap4,ap3); p1 := RotatePoint(ap4,ap1,-ang); p2 := RotatePoint(ap4,ap2,-ang); p3 := RotatePoint(ap4,ap3,-ang); p4 := ap4; cp := MPoint(MPoint(p1,p2),MPoint(p3,p4)); p1 := MovePointTo(p1,cp,thick,thick); p2 := MovePointTo(p2,cp,thick,thick); p3 := MovePointTo(p3,cp,thick,thick); p4 := MovePointTo(p4,cp,thick,thick); p1 := RotatePoint(ap4,p1,ang); p2 := RotatePoint(ap4,p2,ang); p3 := RotatePoint(ap4,p3,ang); p4 := RotatePoint(ap4,p4,ang); result := TRectangle.create(0,0,0,0,width,style,color,brs,brc,LayerHandle,mydsNormal,owner); result.ActualPoints[1] := p1; result.ActualPoints[2] := p2; result.ActualPoints[3] := p3; result.ActualPoints[4] := p4; end; function TArc.Offset(Thick: Double): TFigure; begin if vertZero = ord(vzBottom) then Thick := -Thick; result := TArc.create(ap1.x,ap1.y,radius-thick,SAngle,FAngle,width,style,color, brs,brc,ord(arcstyle),LayerHandle,mydsNormal,owner); end; function TPolyline.DuplicateAsBezier: TFigure; begin result := nil; end; { TDuplicateAsBezier } class function TDuplicateAsBezier.CreateFromShadow(aOwner: TComponent; LHandle: Integer; Shadow: TFigure): TFigure; var cad: TPCDrawing; begin cad := TPCDrawing(aOwner); cad.DuplicateSelectionAsBezier(Shadow.ap2.x-Shadow.ap1.x,Shadow.ap2.y-Shadow.ap1.y); result := nil; end; class function TDuplicateAsBezier.CreateShadow(x, y: Double): TFigure; begin CreateShadow := TDuplicateAsBezier.create(DoublePoint(x,y),DoublePoint(x,y)); end; function TText.DuplicateAsBezier: TFigure; var Layer: TLayer; acolor : TColor; a,i,k : integer; TestX,TestY1,TestY2,Z: Double; TopY : boolean; lMult: integer; points: TDoublePointArr; xlen: Double; nLen,nH: Integer; pt: TPoint; typ: Byte; PointArr:array of TPoint; TypeArr: array of Byte; Dengine: TPCDrawEngine; pCnt,kCnt: Integer; fCnt: Integer; fClosed: Boolean; pArr: TDoublePointArr; Segments: TList; plSegment,dSegment: TPLSegment; x,y: Double; dp: TDoublePOint; bezIndex: Integer; grp: TFigureGrp; pl: TPolyline; begin result := nil; if assigned(owner) then begin Dengine := TPCDrawing(Owner).Dengine; end else exit; Segments := TList.Create; TestX := 0; TestY1:= 100; TestY2 := 200; Z := 0; DEngine.ConvertPoint(TestX,TestY1,Z); DEngine.ConvertPoint(TestX,TestY2,Z); if TestY2 > TestY1 then topY := true else topY := false; if TopY then lMult := 1 else lMult := -1; DEngine.Canvas.Pen.Mode := pmCopy; BeginPath(DEngine.Canvas.Handle); if fKeepA then begin DEngine.drawtext(ap1,ap2,ap3,ap4,lMult*angle,text,font,height,0,cSpace,nH,nLen); fKeepA := False; end else DEngine.drawtext(ap1,ap2,ap3,ap4,lMult*angle,text,font,height,CWidth,cSpace,nH,nLen); TextHeight := nH; TextLength := nLen; EndPath(DEngine.Canvas.Handle); SetLength(PointArr,1000); SetLength(TypeArr,1000); pCnt := GetPath(DEngine.Canvas.Handle,PointArr,TypeArr,0); SetLength(PointArr,pCnt); SetLength(TypeArr,pCnt); pCnt := GetPath(DEngine.Canvas.Handle,PointArr[0],TypeArr[0],pcnt); fCnt := 0; kCnt := 0; bezIndex := 0; grp := TFigureGrp.create(LayerHandle,Owner); for i:= 0 to pcnt-1 do begin pt := PointArr[i]; x := pt.x; y := pt.y; z := 0; Dengine.DeConvertPoint(x,y,z); dp := DoublePOint(x,y); typ := TypeArr[i]; Case typ of PT_LINETO or PT_CLOSEFIGURE: begin fClosed := True; kCnt := kCnt+1; SetLength(pArr,kCnt); pArr[kCnt-1] := dp; plSegment := TPlSegment.Create(0,sLine,dp,dp); Segments.Add(plSegment); end; PT_BEZIERTO or PT_CLOSEFIGURE: begin fClosed := True; bezIndex := 0; kCnt := kCnt+1; SetLength(pArr,kCnt); pArr[kCnt-1] := dp; end; PT_LINETO: begin kCnt := kCnt+1; SetLength(pArr,kCnt); pArr[kCnt-1] := dp; plSegment := TPlSegment.Create(0,sLine,dp,dp); Segments.Add(plSegment); end; PT_BEZIERTO: begin bezIndex := BezIndex+1; if bezIndex = 1 then begin plSegment := TPlSegment.Create(0,sCurve,dp,dp); Segments.Add(plSegment); end else if bezIndex = 2 then begin plSegment.Cpoint2 := dp; end else if BezIndex = 3 then begin bezIndex := 0; kCnt := kCnt+1; SetLength(pArr,kCnt); pArr[kCnt-1] := dp; end; end; PT_MOVETO: begin fcnt := fcnt+1; if fcnt > 1 then begin pl := TPolyline.create(parr,width,ord(psSolid),color,ord(bsClear),color, 0,fClosed,LayerHandle,mydsNormal,owner); grp.AddFigure(pl); for k := 0 to Segments.Count-1 do begin plSegment := TPLSegment(Segments[k]); if plSegment.SType = sCurve then begin dSegment := TPLSegment(pl.Segments[k]); dSegment.SType := sCurve; dSegment.CPoint1 := plSegment.CPoint1; dSegment.CPoint2 := plSegment.CPoint2; end; plSegment.free; end; Segments.Clear; end; fClosed := false; kCnt := 0; kCnt := kCnt+1; SetLength(pArr,kCnt); pArr[kCnt-1] := dp; end; end; end; if kcnt > 0 then begin pl := TPolyline.create(parr,width,ord(psSolid),color,ord(bsClear),color, 0,fClosed,LayerHandle,mydsNormal,owner); grp.AddFigure(pl); for k := 0 to Segments.Count-1 do begin plSegment := TPLSegment(Segments[k]); if plSegment.SType = sCurve then begin dSegment := TPLSegment(pl.Segments[k]); dSegment.SType := sCurve; dSegment.CPoint1 := plSegment.CPoint1; dSegment.CPoint2 := plSegment.CPoint2; end; plSegment.free; end; Segments.Clear; end; Segments.Free; if assigned(pl) then result := grp else begin grp.DestroyInFigures; grp.Destroy; end; end; function TFigure.DuplicateAsBezier: TFigure; var Layer: TLayer; acolor : TColor; a,i,k : integer; TestX,TestY1,TestY2,Z: Double; TopY : boolean; lMult: integer; points: TDoublePointArr; xlen: Double; nLen,nH: Integer; pt: TPoint; typ: Byte; PointArr:array of TPoint; TypeArr: array of Byte; Dengine: TPCDrawEngine; pCnt,kCnt: Integer; fCnt: Integer; fClosed: Boolean; pArr: TDoublePointArr; Segments: TList; plSegment,dSegment: TPLSegment; x,y: Double; dp: TDoublePOint; bezIndex: Integer; grp: TFigureGrp; pl: TPolyline; begin result := nil; exit; if assigned(owner) then begin Dengine := TPCDrawing(Owner).Dengine; end else exit; Segments := TList.Create; BeginPath(DEngine.Canvas.Handle); Draw(Dengine,false); EndPath(DEngine.Canvas.Handle); //WidenPath(DEngine.Canvas.Handle); SetLength(PointArr,1000); SetLength(TypeArr,1000); pCnt := GetPath(DEngine.Canvas.Handle,PointArr,TypeArr,0); SetLength(PointArr,pCnt); SetLength(TypeArr,pCnt); pCnt := GetPath(DEngine.Canvas.Handle,PointArr[0],TypeArr[0],pcnt); fCnt := 0; kCnt := 0; bezIndex := 0; grp := TFigureGrp.create(LayerHandle,Owner); for i:= 0 to pcnt-1 do begin pt := PointArr[i]; x := pt.x; y := pt.y; z := 0; Dengine.DeConvertPoint(x,y,z); dp := DoublePOint(x,y); typ := TypeArr[i]; Case typ of PT_LINETO or PT_CLOSEFIGURE: begin fClosed := True; kCnt := kCnt+1; SetLength(pArr,kCnt); pArr[kCnt-1] := dp; plSegment := TPlSegment.Create(0,sLine,dp,dp); Segments.Add(plSegment); end; PT_BEZIERTO or PT_CLOSEFIGURE: begin fClosed := True; bezIndex := 0; kCnt := kCnt+1; SetLength(pArr,kCnt); pArr[kCnt-1] := dp; end; PT_LINETO: begin kCnt := kCnt+1; SetLength(pArr,kCnt); pArr[kCnt-1] := dp; plSegment := TPlSegment.Create(0,sLine,dp,dp); Segments.Add(plSegment); end; PT_BEZIERTO: begin bezIndex := BezIndex+1; if bezIndex = 1 then begin plSegment := TPlSegment.Create(0,sCurve,dp,dp); Segments.Add(plSegment); end else if bezIndex = 2 then begin plSegment.Cpoint2 := dp; end else if BezIndex = 3 then begin bezIndex := 0; kCnt := kCnt+1; SetLength(pArr,kCnt); pArr[kCnt-1] := dp; end; end; PT_MOVETO: begin fcnt := fcnt+1; if fcnt > 1 then begin pl := TPolyline.create(parr,width,ord(psSolid),color,ord(bsClear),color, 0,fClosed,LayerHandle,mydsNormal,owner); grp.AddFigure(pl); try for k := 0 to Segments.Count-1 do begin plSegment := TPLSegment(Segments[k]); if plSegment.SType = sCurve then begin dSegment := TPLSegment(pl.Segments[k]); dSegment.SType := sCurve; dSegment.CPoint1 := plSegment.CPoint1; dSegment.CPoint2 := plSegment.CPoint2; end; plSegment.free; end; Segments.Clear; except // on E: Exception do AddExceptionToLog(CPowerCadMessage + 'TFigure.DuplicateAsBezier' + E.Message); end; end; fClosed := false; kCnt := 0; kCnt := kCnt+1; SetLength(pArr,kCnt); pArr[kCnt-1] := dp; end; end; end; if kcnt > 0 then begin pl := TPolyline.create(parr,width,ord(psSolid),color,ord(bsClear),color, 0,fClosed,LayerHandle,mydsNormal,owner); grp.AddFigure(pl); try for k := 0 to Segments.Count-1 do begin plSegment := TPLSegment(Segments[k]); if plSegment.SType = sCurve then begin dSegment := TPLSegment(pl.Segments[k]); dSegment.SType := sCurve; dSegment.CPoint1 := plSegment.CPoint1; dSegment.CPoint2 := plSegment.CPoint2; end; plSegment.free; end; Segments.Clear; except // on E: Exception do AddExceptionToLog(CPowerCadMessage + 'TFigure.DuplicateAsBezier' + E.Message); end; end; Segments.Free; if assigned(pl) then result := grp else begin grp.DestroyInFigures; grp.Destroy; end; end; { THellical } function THellical.BreakByPoint(p: TdoublePoint; var Figures: TList): boolean; begin end; constructor THellical.create(aX1, aY1, aX2, aY2: Double; w, s, c, row, LHandle: Integer; aDrawStyle: TDrawStyle; aOwner: TComponent); begin inherited create(LHandle,aDrawStyle,aOwner); initialize; RowStyle := row; originalpoints[1] := DoublePoint(ax1,ay1); originalpoints[2] := DoublePoint(ax2,ay2); actualpoints[1] := DoublePoint(ax1,ay1); actualpoints[2] := DoublePoint(ax2,ay2); width := w; color := c; style := s; end; class function THellical.CreateFromShadow(aOwner: TComponent; LHandle: Integer; Shadow: TFigure): TFigure; var cad: TPCDrawing; begin cad := TPCDrawing(aOwner); Result := THEllical.create( Shadow.ActualPoints[1].x, Shadow.ActualPoints[1].y, Shadow.ActualPoints[2].x, Shadow.ActualPoints[2].y, cad.DefaultPenWidth, ord(cad.DefaultPenStyle), cad.DefaultPenColor, ord(cad.DefaultRowStyle), LHandle,mydsNormal,cad); end; procedure THellical.draw(DEngine: TPCDrawEngine; isGrayed: Boolean); var acolor : Tcolor; rad,l: Double; cp1,cp2,p1,p2 : TDoublePoint; i: Integer; rgn: HRGN; begin aColor := Color; if (aColor = -255) and (LayerHandle <> 0) then begin aColor := TLayer(LayerHandle).PenColor; end; if isGrayed then acolor := TPCDrawing(Owner).FGrayedColor; //06.08.2012 GrayedColor; if DrawStyle = dsTrace then DEngine.Canvas.pen.mode := pmXor else DEngine.canvas.pen.mode := pmCopy; l := GetLineLenght(ap1,ap2); cp1 := DoublePoint(ap1.x+(l/2),ap1.y); cp2 := ap1; rgn := 1; for i := 1 to step do begin rad := (l+((i-1)*2)*l)/2; Dengine.drawbezarc(cp1.x,cp1.y,rad,pi,2*pi,color,width,style,0,ord(bsClear),0,rgn,p1,p2,false,0); end; for i := 1 to step-1 do begin rad := (i*2*l)/2; Dengine.drawbezarc(cp2.x,cp2.y,rad,0,pi,color,width,style,0,ord(bsClear),0,rgn,p1,p2,false,0); end; end; procedure THellical.DrawFigureGuides(DEngine: TPCDrawEngine); begin inherited; end; function THellical.duplicate: TFigure; begin end; function THellical.DuplicateAsBezier: TFigure; begin end; function THellical.EndModification(CadControl: Pointer; mp: TModPoint; TraceFigure: TFigure; x, y: double; Shift: TShiftState): boolean; var ap: TDoublepoint; begin ap := actualpoints[mp.SeqNbr]; ActualPoints[mp.SeqNbr] := DoublePoint(ActualPoints[mp.SeqNbr].x + (x-ap.x), ActualPoints[mp.SeqNbr].y + (y-ap.y)); ResetRegion; Modified := True; end; procedure THellical.getbounds(var figMaxX, figMaxY, figMinX, figMinY: double); begin inherited; end; function THellical.GetClassName: String; begin result := 'Hellical'; end; function THellical.GetLinearInterSections(p1, p2: TDoublePoint; var pArr: TDoublePointArr): Boolean; begin end; procedure THellical.getModPoints(ModList: TMyList); begin inherited; end; procedure THellical.Initialize; begin inherited; pointcount := 2; Step := 4; end; function THellical.isPointIn(x, y: double): boolean; begin end; procedure THellical.Move(deltax, deltay: Double); begin inherited; end; function THellical.Offset(Thick: Double): TFigure; begin end; procedure THellical.SetPropertyFromStream(xCode: Byte; data: pointer; size: integer); begin inherited; end; function THellical.ShadowClick(ClickIndex: Integer; x, y: Double): Boolean; begin result := false; if clickIndex = 2 then begin ActualPoints[2] := DoublePoint(x,y); Result := True; end; end; function THellical.ShadowTrace(ClickIndex: Integer; x, y: Double): Boolean; begin if clickIndex = 1 then begin ActualPoints[2] := DoublePoint(x,y); Result := True; end; end; class function THellical.ShadowType: TShadowType; begin Result := stLine; end; function THellical.TraceModification(CadControl: Pointer; mp: TModPoint; TraceFigure: TFigure; x, y: double; Shift: TShiftState): boolean; begin TraceFigure.ActualPoints[MP.SeqNbr] := DoublePoint(x,y); end; procedure THellical.WriteToStream(Stream: TStream); begin inherited; end; procedure TFigure.SelectPoint(ModPOint:TModPoint); begin end; procedure TPolyline.SelectPoint(ModPoint: TModpoint); begin if ModPoint.PType = ptPolyPoint then begin ModPoint.Color := clRed; SelectedPoint:= ModPOint.SeqNbr; end; end; function TFigure.SnapPoints(var x, y: Double;DotsPerMil:Double): Boolean; var dx,dy: Double; a: Integer; xMod: TModPOint; begin result := false; for a := 1 to PointCount do begin dx := abs(FigurePoints[a].x-x); dy := abs(FigurePoints[a].y-y); dx := dx*DotsPerMil; dy := dy*dotsPerMil; if (dx <= 12) and (dy <= 12) and not result then begin x := FigurePoints[a].x; y := FigurePoints[a].y; result := true; end; end; if Selected and not result then begin SelPoints.Pack; // Tolik 24/12/2019 -- for a := 1 to SelPoints.Count - 1 do begin xMod := TModPoint(SelPoints[a]); dx := abs(xMod.CoordX-x); dy := abs(xMod.CoordY-y); dx := dx*DotsPerMil; dy := dy*dotsPerMil; if (dx <= 12) and (dy <= 12) and not result then begin x := xMod.CoordX; y := xMod.CoordY; result := true; end; end; end; end; function TLine.GetClassName: String; begin result := 'Line'; end; function TVertex.GetClassName: String; begin result := 'Vertex'; end; function TPolyline.GetClassName: String; begin result := 'Polyline'; end; function TEllipse.GetClassName: String; begin result := 'Ellipse'; end; function TCircle.GetClassName: String; begin result := 'Circle'; end; function TArc.GetClassName: String; begin result := 'Arc'; end; function TRectangle.GetClassName: String; begin result := 'Rectangle'; end; function TBMPObject.GetClassName: String; begin result := 'BMPObject'; end; function TText.GetClassName: String; begin result:= 'Text'; end; function TFigure.isVisible: Boolean; begin result := true; if LayerHandle > 0 then result := (TLayer(LayerHandle).visible <> lost); end; Procedure TFigure.ShowProperties; begin end; procedure TFigure.PropUpdate(PropName, PropVal: String); begin end; procedure TFigure.DrawDetail(DEngine: TPCDrawEngine;DetailStyle:TDetailStyle); begin Draw(Dengine,False); end; function TFigure.GetZAvg(dRect: TDoubleRect; var fAvg: Double): Boolean; var fRect:TDoubleRect; begin result := false; fRect := GetBoundRect; if RectOverlaps(dRect,fRect) then begin fAvg :=0; result := True; end; end; function TModPoint.IsPointInDetInt(x, y, pdim: Integer): Boolean; begin result := false; If ((x <= PixDetX+pdim) and (x >= PixDetX-pdim)) and ((y <= PixDetY+pdim) and (y >= PixDetY-pdim)) then begin result := true; end; end; function TModPoint.IsPointInInt(x, y, pdim: Integer): Boolean; begin result := false; if onlyiso then exit; If ((x <= PixX+pdim) and (x >= PixX-pdim)) and ((y <= PixY+pdim) and (y >= PixY-pdim)) then begin result := true; end; end; function TFigure.IsPointInInt(x, y: Integer): Boolean; begin result := false; end; procedure TFigure.GetIsometricBounds(var figMaxX, figMaxY, figMinX, figMinY: Double); begin end; procedure TFigure.DeSelectPoint(Modpoint: TModPOint); begin end; procedure TPolyline.DeSelectPoint(ModPoint: TModpoint); begin if ModPoint.PType = ptPolyPoint then ModPoint.Color := clBlue; end; class function TPolyline.InsideSelection: Boolean; begin result := true; end; function TCircle.Edit: Boolean; var r: Double; ValS: String; begin result := false; // Val := FloatToStr(Self.Radius); // Val := InputBox(capCircleRadius,mesEnterAsMM,Val); r := Radius * GCadForm.PCad.MapScale / 1000; r := MetreToUOM(r); ValS := FormatFloat(ffMask, r); ValS := InputBox(cDrawObjects_Mes1, cDrawObjects_Mes2, ValS); try r := StrToFloat_My(ValS); except ShowMessage(cDrawObjects_Mes3); Exit; end; if r < 0 then r := 0; r := r * 1000 / GCadForm.PCad.MapScale; r := UOMToMetre(r); Self.Radius := r; result := true; // set this true so Powercad will make a refresh. end; procedure TFigure.UpdateBounds(var figMaxX, figMaxY, figMinX, figMinY: Double); var xmin,xmax,ymin,ymax: Double; begin GetBounds(xmax,ymax,xmin,ymin); figMaxX := Max(figMaxX,xMax); figMaxY := Max(figMaxY,ymax); figMinX := Min(figMinX,xmin); figMinY := Min(figMinY,ymin); end; class function TPolyline.createP4(p1, p2, p3, p4: TDoublePoint; w, s, c, abrs, abrc, row: integer; aClosed: Boolean; LHandle: Integer; aDrawStyle: TDrawStyle; aOwner: TComponent): TPolyline; var p: TDoublePOintArr; begin setLength(p,4); p[0] := p1; p[1] := p2; p[2] := p3; p[3] := p4; result := create(p,w, s, c,abrs, abrc, row,aClosed,LHandle,aDrawStyle,aOwner); end; procedure TFigure.DrawFigureGuidesInDetail(DEngine: TPCDrawEngine;DetailStyle:TDetailStyle); begin DrawFigureGuides(DEngine); end; procedure TPolyline.InsertKnot(SegNbr: Integer; MP: TDoublePoint); var Seg : TPLSegment; NewSeg: TPLSegment; i: Integer; begin if SegNbr = 0 then exit; Seg := Segments[SegNbr-1]; if assigned(seg) then begin PointCount := PointCount+1; ActualPoints[PointCount] := ActualPoints[PointCount-1]; OriginalPoints[PointCount] := OriginalPoints[PointCount-1]; for i := PointCount downto SegNbr + 1 do begin ActualPoints[i] := ActualPoints[i-1]; OriginalPoints[i] := OriginalPoints[i-1]; end; ActualPoints[SegNbr+1] := MP; OriginalPoints[Segnbr+1] := MP; SegMents.Move(PointCount-1,SegNbr); Seg := Segments[SegNbr-1]; ArrangeSegment(SegNbr, Seg.SType); ArrangeSegment(SegNbr+1, Seg.SType); NeedBounds := True; //Tolik 02/08/2021 -- end; end; procedure TPolyline.DivideSegment(SegNbr, Cnt: Integer); var p1,p2,mp: TDoublePoint; len,d: Double; i:INteger; begin if SegNbr = PointCount then begin p1 := ActualPoints[SegNbr]; p2 := ActualPoints[1]; end else begin p1 := ActualPoints[SegNbr]; p2 := ActualPoints[SegNbr+1]; end; len := GetLineLenght(p1,p2); d := len / Cnt; for i := 1 to Cnt-1 do begin mp := MPoint(p2,p1,i*d); InsertKnot(SegNbr,mp); end; NeedBounds := True; //Tolik 02/08/2021 -- end; procedure TFigure.DrawSelPoint(DEngine: TPCDrawEngine; isGrayed: Boolean; mp: TModPoint); var acolor:TColor; begin if not mp.isDraw then exit; if isGrayed then acolor := clGray else acolor := mp.Color; DEngine.drawselectionpoint(mp.CoordX,mp.CoordY,mp.CoordZ,mp.DType,mp.Dim,acolor); end; { TCircleVertex } class function TCircleVertex.CreateFromShadow(aOwner: TComponent; LHandle: Integer; Shadow: TFigure): TFigure; begin result := TCircleVertex.create(shadow.ap1.x,shadow.ap1.y,LHandle,mydsNormal,aOwner); end; function TCircleVertex.CreateModification: TFigure; begin Result := TCircleVertex.create(ap1.x,ap1.y,0,dsTrace,nil); DragDeltaX := DragStartX-ap1.x; DragDeltaY := DragStartY-ap1.y; Result.ActualPoints[1] := DoublePoint(DragStartX,DragStartY); Result.Color := clLime; end; procedure TCircleVertex.Draw(DEngine: TPCDrawEngine; isGrayed: Boolean); var acolor,bcolor : Tcolor; begin acolor := color; if (aColor = -255) and (LayerHandle <> 0) then begin aColor := TLayer(LayerHandle).PenColor; end; if (isGrayed) then begin acolor := TPCDrawing(Owner).FGrayedColor; //06.08.2012 GrayedColor; end; if DrawStyle = dsTrace then DEngine.canvas.pen.mode := pmXor else DEngine.canvas.pen.mode := pmCopy; DEngine.drawcircle(ap1.x,ap1.y,radius,acolor,width,style,0,ord(bsClear),RegHandle,InCombined); Dengine.drawline(ap1.x-1,ap1.y,ap1.x-radius-1,ap1.y,aColor,1,ord(psSOlid),0); Dengine.drawline(ap1.x+1,ap1.y,ap1.x+radius+1,ap1.y,aColor,1,ord(psSOlid),0); Dengine.drawline(ap1.x,ap1.y-1,ap1.x,ap1.y-radius-1,aColor,1,ord(psSOlid),0); Dengine.drawline(ap1.x,ap1.y+1,ap1.x,ap1.y+radius+1,aColor,1,ord(psSOlid),0); end; function TCircleVertex.duplicate: TFigure; begin result := TCircleVertex.create(originalpoints[1].x, originalpoints[1].y, LayerHandle, DrawStyle,Owner); result.actualpoints[1] := actualpoints[1]; result.AngleToPoint := AngleToPoint; result.Radius := Radius; end; procedure TCircleVertex.getbounds(var figMaxX, figMaxY, figMinX, figMinY: double); begin figMaxX := ap1.x + radius +1; figMaxY := ap1.y + radius +1; figMinX := ap1.x - radius -1; figMinY := ap1.y - radius -1; end; function TCircleVertex.GetClassName: String; begin result := 'CircleVertex'; end; procedure TCircleVertex.getModPoints(ModList: TMyList); var cControl:TPCDrawing; begin CControl := TPCDrawing(Owner); ModList.Add(CControl.RegisterModPoint(self,ptUndefined,ptRect,clBlue, pointDim,ap1.x,ap1.y,0)); end; procedure TCircleVertex.Initialize; begin inherited; Radius := 4; FullHitTest := True; Color := clred; end; function TCircleVertex.isPointIn(x, y: double): boolean; begin result := false; result := inherited isPointIn(x,y); end; function TVertex.EndModification(CadControl: Pointer; mp: TModPoint; TraceFigure: TFigure; x, y: double; Shift: TShiftState): boolean; begin ActualPoints[1] := DoublePoint(x,y); end; function TVertex.TraceModification(CadControl: Pointer; mp: TModPoint; TraceFigure: TFigure; x, y: double; Shift: TShiftState): boolean; begin TraceFigure.ActualPoints[1] := DoublePoint(x,y); end; function TLine.SnapPoints(var x, y: Double; DotsPerMil: Double): Boolean; var pd:TDoublePoint; onLine: Boolean; d:double; begin result := inherited SnapPoints(x,y,DotsPerMil); if not result then begin pd := DoublePoint(x,y); PointToLine(ap1,ap2,pd.x,pd.y); onLine := isPointInLine(ap1,ap2,pd,1,0.1); d := GetLineLenght(pd,DoublePoint(x,y)); if (d*dotsPermil < 18) and onLine then begin x := pd.x; y := pd.y; result := true; end; end; end; procedure TFigure.CreateDimLines; begin ClearDimLines; end; procedure TFigure.ClearDimLines; var i:Integer; begin try for i := 0 to DimLines.Count-1 do begin TFigure(DimLines[i]).Free; end; Dimlines.Clear; except // on E: Exception do AddExceptionToLog(CPowerCadMessage + 'TFigure.ClearDimLines' + E.Message); end; end; procedure TRectangle.CreateDimLines; var dim1,dim2,dim3,dim4:TADimLine; begin inherited; if DimTop then begin Dim1 := CreateAlignedDimLine(ap1,ap2,ap4,ap3,Owner); DimLines.Add(dim1); end; if DimBottom then begin Dim2 := CreateAlignedDimLine(ap3,ap4,ap1,ap2,Owner); DimLines.Add(dim2); end; if DimLeft then begin Dim3 := CreateAlignedDimLine(ap1,ap4,ap2,ap3,Owner); DimLines.Add(dim3); end; if DimRight then begin Dim4 := CreateAlignedDimLine(ap3,ap2,ap1,ap4,Owner); DimLines.Add(dim4); end; end; procedure TFigure.DrawDimLines(DEngine: TPCDrawEngine; isGrayed: Boolean); var i: Integer; begin for i := 0 to DimLines.Count-1 do Tfigure(Dimlines[i]).Draw(Dengine,isGrayed); end; Function CreateAlignedDimLine(p1,p2,offp1,offp2:TDoublePoint;Owner:TComponent):TADimLine; var mp1,mp2:TDoublePoint; begin result := TADimLine.Create(0,mydsNormal,Owner); result.ActualPoints[1] := p1; result.ActualPoints[2] := p2; mp1 := MPoint(p1,p2); mp2 := MPoint(offp1,offp2); result.ActualPoints[3] := MPoint(mp1,mp2,-6.0); end; Function CreateVerticalDimLine(p1,p2,offp1,offp2:TDoublePoint;Owner:TComponent):TVDimLine; var mp1,mp2:TDoublePoint; begin result := TVDimLine.Create(0,mydsNormal,Owner); result.ActualPoints[1] := p1; result.ActualPoints[2] := p2; mp1 := MPoint(p1,p2); mp2 := MPoint(offp1,offp2); result.ActualPoints[3] := MPoint(mp1,mp2,-6.0); end; procedure TLine.CreateDimLines; var dim1: TADimLine; p1,p2:TDoublePoint; begin inherited; GetParallelPoints(ap1,ap2,p1,p2,5); Dim1 := CreateAlignedDimLine(ap1,ap2,p1,p2,Owner); Dimlines.Add(dim1); end; procedure TPolyline.CreateDimLines; var i: Integer; seg:TPLSegment; p1,p2,op1,op2:TDoublePoint; begin ClearDimlines; for i := 0 to Segments.Count-1 do begin seg := TPlSegment(Segments[i]); if seg.ShowDim then begin p1 := ActualPoints[i+1]; if i+2 > PointCount then p2 := ActualPoints[1] else p2 := ActualPoints[i+2]; GetParallelPoints(p1,p2,op1,op2,5); DimLines.Add(CreateAlignedDimLine(p1,p2,op1,op2,Owner)); end; end; end; procedure TPolyline.ClearDimLines; var i:Integer; begin inherited; end; function TPolyline.GetSegmentDimension(SegNbr: Integer): Boolean; begin result := TPlSegment(Segments[SegNbr]).ShowDim; end; procedure TPolyline.SetSegmentDimension(SegNbr: Integer; Vis: Boolean); begin TPlSegment(Segments[SegNbr]).ShowDim := vis; CreateDimLines; end; procedure TPolyline.ToggleSegmentDimension(SegNbr: Integer); begin TPlSegment(Segments[SegNbr]).ShowDim := not TPlSegment(Segments[SegNbr]).ShowDim; CreateDimLines; end; procedure TCircle.CreateDimLines; var dim1: TCDimline; begin inherited; Dim1 := TCDimLine.Create(LayerHandle,mydsNormal,Owner); Dim1.ActualPoints[1] := MHPoint(ap1,-radius); Dim1.ActualPoints[2] := MHPoint(ap1,+radius); Dim1.Rotate(-pi/4,ap1); Dim1.HorzText := False; Dimlines.Add(Dim1); end; procedure TArc.CreateDimLines; var dim1:TArcDimLine; begin inherited; dim1 := TArcDimline.create(ap1.x,ap1.y,radius+6,SAngle,FAngle,0,mydsNormal,owner); dim1.GuideLen := 5.5; Dimlines.Add(Dim1); end; class function TText.CreateCentered(aX1, aY1, h, w: double; atext, FontName: String; FontCharset: Byte; aColor, LHandle: Integer; aDrawStyle: TDrawStyle; aOwner: TComponent): TText; var p1 : TDoublePoint; TM : TTextMetric; FCanvas: TCanvas; FontRecord : TLogFont; xHeight,xWidth: Double; vl,hl:DOuble; xlen: Double; r: real; mCanvas: TMetafileCanvas; ww,hh: Double; fc:TFigureClass; begin fc := TText; result := TText(fc.Create(LHandle,aDrawStyle,aOwner)); result.initialize; result.Color := aColor; result.Text := aText; result.Font.Charset := FontCharset; result.Font.Name := FontName; result.Font.Color := aColor; result.Height := h; result.CWidth := w; result.Modified := true; result.originalpoints[1] := DoublePoint(ax1,ay1); result.actualpoints[1]:= DoublePoint(ax1,ay1); if result.owner <> nil then begin TPCDrawing(Result.Owner).DEngine.GetTextLens(Result.TextLength,Result.TextHeight, Result.Text,Result.Font,Result.Height,Result.CWidth,Result.CSpace); (* Fcanvas := TPCDrawing(result.Owner).DEngine.canvas; xHeight := result.Height*4; FCanvas.Font.Height := Round(xHeight); if result.CWidth <> 0 then begin xWidth := result.CWidth*4; GetObject(FCanvas.Font.Handle,sizeof(FontRecord),Addr(FontRecord)); FontRecord.lfWidth := Round(xWidth); FCanvas.Font.handle := CreateFontIndirect(FontRecord); end; result.TextLength := Fcanvas.TextWidth(result.text); result.TextHeight := Fcanvas.TextHeight(result.text); result.TextLength := (result.TextLength/4); result.TextHeight := (result.TextHeight/4); *) if result.HorzZero = 1 then hl := -1 else hl := 1; if result.VertZero = 1 then vl := -1 else vl := 1; end; result.originalpoints[1] := DoublePoint(ax1-hl*result.TextLength/2,ay1+vl*result.TextHeight/2); result.actualpoints[1]:= result.originalpoints[1]; result.originalpoints[2] := Doublepoint( result.originalpoints[1].x + hl*result.TextLength, result.originalpoints[1].y); result.actualpoints[2] := Doublepoint( result.originalpoints[1].x + hl*result.TextLength, result.originalpoints[1].y); result.originalpoints[3] := Doublepoint( result.originalpoints[1].x + hl*result.TextLength , result.originalpoints[1].y - vl*result.TextHeight); result.actualpoints[3] := Doublepoint( result.originalpoints[1].x + hl*result.TextLength , result.originalpoints[1].y - vl*result.TextHeight); result.originalpoints[4] := Doublepoint( result.originalpoints[1].x , result.originalpoints[1].y - vl*result.TextHeight); result.actualpoints[4] := Doublepoint( result.originalpoints[1].x , result.originalpoints[1].y - vl*result.TextHeight); //result.SetRegionPoints; end; procedure TFigure.Rotate(aAngle: Double); begin Rotate(aAngle,CenterPoint); end; procedure TPolyline.CollectPolyLinePoints(var pdPoints: TDoublePointArr); var i: Integer; begin SetLength(pdPoints,PointCount); for i := 1 to PointCount do pdPoints[i-1] := ActualPoints[i]; end; procedure TFigure.GetSelBounds(var figMaxX, figMaxY, figMinX, figMinY: Double); var i: Integer; begin GetBounds(figMaxX,figMaxY,figMinX,figMinY); if Dimlines.Count > 0 then begin for i := 0 to Dimlines.Count-1 do begin TFigure(Dimlines[i]).UpdateBounds(figMaxX, figMaxY, figMinX,figMinY); end; end; end; procedure TFigure.CreateDimLinesFromStream(xStream: TStream; LHandle: Integer; Owner: TComponent); var fSize,i,dcnt: Integer; fStream: TMemoryStream; xFig:Tfigure; begin ClearDimlines; xStream.Read(dcnt,4); for i := 1 to dcnt do begin xStream.Read(fSize,4); fStream := TMemoryStream.Create; StreamToStream(xStream,fStream,fSize); fStream.Position := 0; xFig := Tfigure.CreateFromStream(fStream,LHandle,mydsNormal,Owner); if assigned(xFig) then DimLines.Add(xFig); fStream.Free; end; end; (* function TRectangle.Edit: Boolean; var dial: TfrmRectangle; p1,p2: TdoublePoint; w,h: Double; begin Result := False; dial := TfrmRectangle.Create(nil); p1 := ap1; p2 := ap3; if dial.SetValues(p1,p2) then begin w := abs(p1.x-p2.x); h := abs(p1.y-p2.y); actualpoints[1] := p1; actualpoints[2] := DoublePoint(p1.x+w,p1.y); actualpoints[3] := p2; actualpoints[4] := DoublePoint(p1.x,p1.y+h); Modified := True; Result := True; end; end; *) { TTextPanel } constructor TTextPanel.create(xp1, xp2: TDoublePoint; LHandle: Integer; aDrawStyle: TDrawStyle; aOwner: TComponent); begin inherited Create(xp1.x,xp1.y,xp2.x,xp2.y,1,ord(psClear), clBlack,ord(bsClear),clWhite,LHandle,mydsNormal,aOwner); //initialize; // Tolik 29/07/2021 -- end; class function TTextPanel.CreateFromShadow(aOwner: TComponent; LHandle: Integer; Shadow: TFigure): TFigure; begin result := TTextPanel.create(Shadow.ap1,shadow.ap3,LHandle,mydsNormal,aOwner); end; destructor TTextPanel.Destroy; begin Font.Free; inherited; end; procedure TTextPanel.draw(DEngine: TPCDrawEngine; isGrayed: Boolean); var nh,nl: Integer; oFont:TFont; VAlign: TTextVAlign; HAlign: TTextHAlign; begin brs := ord(bsClear); style := ord(psClear); if RegHandle = 0 then begin RegHandle := DEngine.PolygonRegion(ap1,ap2,ap3,ap4); end; Case Alignment of taTopLeft : VAlign := vtTop; taTopCenter : VAlign := vtTop; taTopRight : VAlign := vtTop; taMiddleLeft : VAlign := vtCenter; taMiddleCenter : VAlign := vtCenter; taMiddleRight : VAlign := vtCenter; taBottomLeft : VAlign := vtBottom; taBottomCenter : VAlign := vtBottom; taBottomRight : VAlign := vtBottom; end; Case Alignment of taTopLeft : HAlign := htLeft; taTopCenter : HAlign := htCenter; taTopRight : HAlign := htRight; taMiddleLeft : HAlign := htLeft; taMiddleCenter : HAlign := htCenter; taMiddleRight : HAlign := htRight; taBottomLeft : HAlign := htLeft; taBottomCenter : HAlign := htCenter; taBottomRight : HAlign := htRight; end; oFont := DEngine.SetCanvasFont(Font.Name,Height,0,CSpace,0,Font.Style,Font.Charset,Font.Color); Dengine.GDIDrawText(ap1,ap2,ap3,ap4,Text,VAlign,HAlign); Dengine.ResetCanvasFont(oFont); end; procedure TTextPanel.DrawFigureGuides(DEngine: TPCDrawEngine); begin inherited; end; function TTextPanel.duplicate: TFigure; begin result := TTextPanel.create(ap1,ap3,LAyerHandle,mydsNormal,Owner); TTextPanel(result).Text := Text; TTextPanel(result).Alignment := Alignment; TTextPanel(result).Height := Height; TTextPanel(result).CSpace := CSpace; TTextPanel(result).Font.Assign(Font); end; function TTextPanel.Edit: Boolean; var xText: String; begin xText := Text; // result := InputMemo(capTextPanel,prmTextPanel,xText); Result := InputMemo(cDrawObjects_Mes11, cDrawObjects_Mes12, xText); if result then begin Text := xText; end; end; function TTextPanel.GetClassName: String; begin result := 'TTextPanel'; end; procedure TTextPanel.Initialize; begin inherited; Text := 'TextPanel'+inttostr(Handle); if textPanelDefault <> '' then Text := textPanelDefault; Font := TFont.Create; Font.Style := []; if assigned(owner) then begin Font.Name := TPCDrawing(owner).Font.Name; Height := TPCDrawing(owner).DefaultTextHeight; Alignment:= taMiddleCenter; Font.Charset := TPCDrawing(owner).Font.Charset; CSpace := 0; Font.Style := TPCDrawing(owner).Font.Style; Font.Color := TPCDrawing(owner).Font.Color; end; end; function TTextPanel.isPointIn(x, y: Double): boolean; begin result := isPointInRegion(x,y); //Tolik Result := IsPointInRegionByRegObj(x,y); // end; procedure TTextPanel.MenuClicked(CommandId: integer); var idx: Integer; begin idx := commandID-menuIndex; case idx of 1..9: Alignment := TTextAlign(idx-1); 10: Height := 8; 11: Height := 4; 12: Height := 2; end; end; function TTextPanel.ModifyTextAndFont(mm: TModifyMode; valueI: Double; valueS: string; valueSt: TFontStyles; ValueB: Boolean): Boolean; begin result := true; if mm = mmText then begin Text := valueS; modified := true; end else if mm = mmFontName then begin Font.Name := valueS; modified := true; end else if mm = mmFontCs then begin Font.Charset := Round(valueI); modified := true; end else if mm = mmFontSize then begin Height := valueI; modified := true; end else if mm = mmFontColor then begin Font.Color := Round(valueI); Color := Round(valueI); end else if mm = mmFontStyle then begin Font.Style := valueSt; modified := true; end else if mm = mmFontBold then begin if ValueB then Font.Style := Font.Style + [fsBold] else Font.Style := Font.Style - [fsBold]; modified := true; end else if mm = mmFontItalic then begin if ValueB then Font.Style := Font.Style + [fsItalic] else Font.Style := Font.Style - [fsItalic]; modified := true; end else if mm = mmFontUnderline then begin if ValueB then Font.Style := Font.Style + [fsUnderline] else Font.Style := Font.Style - [fsUnderline]; modified := true; end else if mm = mmFontStrike then begin if ValueB then Font.Style := Font.Style + [fsStrikeOut] else Font.Style := Font.Style - [fsStrikeOut]; modified := true; end; end; procedure TTextPanel.scale(percentx, percenty: Double; rPoint: TDoublepoint); begin inherited; end; procedure TTextPanel.SetField(FName, FValue: String); begin if Pos(FName,Text)>0 then Text := StringReplace(Text,fname,fvalue,[rfIgnoreCase]); end; procedure TTextPanel.SetPropertyFromStream(xCode: Byte; data: pointer; size: integer); begin inherited; Case xcode of 21: Color := pInt(data)^; 100: font.Style := font.Style + [fsBold]; 101: font.Style := font.Style + [fsItalic]; 102: font.Style := font.Style + [fsStrikeout]; 103: font.Style := font.Style + [fsUnderLine]; 104: Alignment := TTextAlign(pByte(data)^); //Tolik 26/03/2019 -- // 180: Text := string(pAnsiChar(data)); // 181: font.name := string(pAnsiChar(data)); 180: Text := string(pchar(data)); 181: font.name := string(pchar(data)); // 221: Height := pDouble(data)^; 222: CSpace := pDouble(data)^; end; end; class function TTextPanel.ShadowType: TShadowType; begin result := stRectangle; end; const taStr: array [0..8] of String = (fmtaTopLeft,fmtaTopCenter,fmtaTopRight, fmtaMiddleLeft,fmtaMiddleCenter,fmtaMiddleRight,fmtaBottomLeft, fmtaBottomCenter,fmtaBottomRight); procedure TTextPanel.UpdateMenu(var popMenu: TPopUpMenu; var sIndex: Integer); var mnItem,mnSub: TMenuItem; i:Integer; begin menuIndex:= sIndex; mnItem := TMenuItem.Create(PopMenu); mnItem.Tag := sIndex; mnItem.Caption := fmTextAlignment; PopMenu.Items.Add(mnItem); for i := 0 to 8 do begin mnSub := TMenuItem.Create(PopMenu); mnSub.Tag := sIndex+1+i; mnSub.Caption := taStr[i]; mnItem.Add(mnSub); if ord(alignment) = i then mnSub.Checked := True; end; mnItem := TMenuItem.Create(PopMenu); mnItem.Tag := 0; mnItem.Caption := '-'; PopMenu.Items.Add(mnItem); mnItem := TMenuItem.Create(PopMenu); mnItem.Tag := sIndex+10; mnItem.Caption := fmTextBig; PopMenu.Items.Add(mnItem); mnItem := TMenuItem.Create(PopMenu); mnItem.Tag := sIndex+11; mnItem.Caption := fmTextMedium; PopMenu.Items.Add(mnItem); mnItem := TMenuItem.Create(PopMenu); mnItem.Tag := sIndex+12; mnItem.Caption := fmTextSmall; PopMenu.Items.Add(mnItem); sIndex := sIndex+13; end; procedure TTextPanel.WriteToStream(Stream: TStream); var xByte: Byte; xInt: Integer; xStr: String; xDbl: Double; begin inherited; xStr := Text;WriteStrField(180,Stream,xStr); xStr := Font.Name;WriteStrField(181,Stream,xStr); xInt := Color; WriteField(21,Stream,xInt,4); xDbl := Height; WriteField(221,Stream,xDbl,8); xDbl := CSpace; WriteField(222,Stream,xDbl,8); xByte := 1; if fsBold in Font.Style then WriteField(100,Stream,xByte,1); if fsItalic in Font.Style then WriteField(101,Stream,xByte,1); if fsStrikeout in Font.Style then WriteField(102,Stream,xByte,1); if fsUnderLine in Font.Style then WriteField(103,Stream,xByte,1); xByte := ord(Alignment);WriteField(104,Stream,xByte,1); end; procedure TText.SetField(FName, FValue: String); begin if Pos(FName,Text)>0 then Text := StringReplace(Text,fname,fvalue,[rfIgnoreCase]); end; procedure TBMPObject.CreateMWPath(x, y, Tol: Double; var DPoints: TDoublePointArr;var closed:Boolean); var Dengine:TPCDrawEngine; p1,p2,p3,p4,p,tp: TDoublePoint; z: DOuble; px,py: Integer; dx,dy: Double; bit: TBitmap; mask,maskx:tbool2darray; points: TPointArray; i,j: Integer; vert:Tvertex; begin DEngine := TPowercad(Owner).Dengine; z := 0; p1 := ap1; p2 := ap2; p3 := ap3; p4 := ap4; DEngine.ConvertCoord(p1.x,p1.y,z); DEngine.ConvertCoord(p2.x,p2.y,z); DEngine.ConvertCoord(p3.x,p3.y,z); DEngine.ConvertCoord(p4.x,p4.y,z); DEngine.ConvertCoord(x,y,z); 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; px := round(x)-round(p1.x); py := round(y)-round(p1.y); bit:=tbitmap.create; bit.Width := Round(p2.x)-round(p1.x); bit.Height := Round(p3.y)-round(p1.y); bit.Canvas.StretchDraw(Rect(0,0,bit.Width,bit.Height),picture); bit.pixelformat:=pf24bit; Setlength(mask,bit.width+5,bit.height+5); MagicWand(bit,px,py,bit.canvas.pixels[px,py],tol,mask); bit.Free; MakePath(mask,points,Closed); SetLength(DPoints,Length(Points)); for i := 0 to Length(points)-1 do begin px := Points[i].X; py := Points[i].Y; px := px+round(p1.x); py := py+round(p1.y); dx := px; dy := py; Dengine.DeConvertCoord(dx,dy,z); Dpoints[i] := DoublePOint(dx,dy,0); end; //Tolik if Length(Points) > 0 then SetLength(Points,0); // end; function TPolyline.SelfIntersecting: Boolean; var lCnt,i,k:Integer; xp1,xp2,xp3,xp4,p: TDoublePoint; begin result := false; if closed then lCnt := PointCount else lCnt := PointCount-1; for i := 1 to lcnt do begin xp1 := ActualPoints[i]; xp2 := ActualPoints[i+1]; for k := i+1 to lCnt do begin xp3 := ActualPoints[k]; xp4 := ActualPoints[k+1]; if GetIntersectionPoint(xp1,xp2,xp3,xp4,p,false,false) then begin result := true; break; end; if result then break; end; end; end; constructor TBMPObject.createExRes(x, y: Double; BmpRes: Integer; aBitmap: TBitmap; LHandle: Integer; aDrawStyle: TDrawStyle; aOwner: TComponent); var picW,picH : Double; begin inherited create(LHandle, aDrawStyle,aOwner); originalpoints[1] := DoublePoint(x,y); originalpoints[1] := DoublePoint(x,y); originalpoints[2] := DoublePoint(x,y); originalpoints[3] := DoublePoint(x,y); originalpoints[4] := DoublePoint(x,y); actualpoints[1] := originalpoints[1]; actualpoints[2] := originalpoints[2]; actualpoints[3] := originalpoints[3]; actualpoints[4] := originalpoints[4]; SelMode := 2; pointcount := 4; if DrawStyle = mydsNormal then begin PictureName := ''; Picture := TBitmap.create; Picture.Assign(aBitmap); Picture.PixelFormat := pf24bit; PicW := (Picture.width / bmpres) * 25.4 ; if horzZero = 1 then PicW := -1* PicW; PicH := (Picture.Height / bmpres) * 25.4 ; if vertZero = 1 then PicH := -1* PicH; originalpoints[2] := DoublePoint(x+PicW,y); originalpoints[3] := DoublePoint(x+PicW,y-PicH); originalpoints[4] := DoublePoint(x,y-PicH); actualpoints[2] := originalpoints[2]; actualpoints[3] := originalpoints[3]; actualpoints[4] := originalpoints[4]; width := 1; color := clBlack; VertFlipped := false; HorzFlipped := false; Image := TBitmap.Create; Modified := True; ImageEdited := True; // Tolik 20/04/2018 -- end; end; function TFigure.GetArea: Double; begin result := 0; end; function TFigure.GetLength: Double; begin result := 0; end; function TFigure.GetModPointBySeqNbr(ANbr: Integer; x, y: Double): TModPoint; var i: Integer; pdim : Double; begin Result := nil; pdim := pointdim; TPCDrawing(Owner).DeConvertDim(pdim); // Tolik 24/12/2019 -- //for i := 0 to SelPoints.count - 1 do for i := SelPoints.count - 1 downto 0 do begin if SelPoints[i] = nil then SelPoints.delete(i) else // begin if (TModPoint(SelPoints[i]).SeqNbr = ANbr) and TModPoint(SelPoints[i]).IsPointIn(x,y,pdim) then begin Result := TModPoint(SelPoints[i]); Break; //// BREAK //// end; end; end; end; function TLine.GetLength: Double; begin result := GetLineLength(ap1,ap2); end; // Tolik -- 23/05/2017 -- PIE FIGURE -- Constructor TPie.Create( cx,cy,rad,a1,a2:Double;w,s,c,abrs,abrc: Integer; LHandle:LongInt; aDrawStyle: TDrawStyle; aOwner: TComponent; aCutStyle: TPieCutStyle; aCutRadius: Double = 0); var p1,p2:TDoublePoint; cp: TDoublePOint; MiddleAngle: Double; begin inherited create(LHandle,aDrawStyle,aOwner); Initialize; originalpoints[1] := DoublePoint(cx,cy); // Center Point actualpoints[1] := DoublePoint(cx,cy); // Center Point SAngle:= a1; FAngle:= a2; radius := rad; width := w; color := c; style := s; brs := abrs; brc := abrc; brs := Ord(bsSolid); //brc := clSkyBlue; CutStyle := aCutStyle; // cut style // CutRadius := aCutRadius; {if aCutRadius <> -1 then begin if (FAngle < SAngle) then begin MiddleAngle := SAngle+((2*pi)-SAngle+FAngle)/2; end else begin MiddleAngle := (SAngle+FAngle)/2; end; p1 := DoublePoint(cp.x + aCutRadius, cp.y); p1 := RotatePoint(cp, p1, MiddleAngle); originalpoints[4] := DoublePoint(p1.x,p1.y); actualpoints[4] := DoublePoint(p1.x,p1.y); end else begin originalpoints[4] := DoublePoint(cx,cy); actualpoints[4] := DoublePoint(cx,cy); end; } end; Destructor TPie.Destroy; begin inherited; end; Procedure TPie.Initialize; begin inherited; pointcount := 1; FillColor := clSkyBlue; GuideLen := 10; DrawGuides:= True; Autotext := True; Dlabel := ''; Prefix := ''; Suffix := '°'; TextFont := 'Courier New'; TextHeight:= 4; TextBold:= False; TextItalic:= False; Dlabel := 'Label'; LStyle := rlsInner; TextColor := clBlack; Visible := True; end; procedure TPie.getModPoints(ModList: TMyList); var mp1, mp2, mp3,mp4: TDoublePoint; MAngle: Double; CControl: TPCDrawing; procedure CorrectCutModPoint; var p1, p2: TDoublePoint; GradAngleVal, Angle1, Angle2: Integer; begin if CutRadius = 0 then exit; if Comparevalue(Fangle, Sangle) = 0 then exit; if cutStyle = PieArcCut then exit; GradAngleVal := 0; // angles Angle1 := Round((180/pi)*Sangle); Angle2 := Round((180/pi)*Fangle); if Angle1 = 360 then Angle1 := 0; if Angle2 = 360 then Angle2 := 0; while Angle1 <> Angle2 do begin angle1 := angle1 + 1; if angle1 = 360 then angle1 := 0; inc(GradAngleVal); if GradAngleVal > 160 then break; end; if GradAngleVal <= 160 then begin p1.x := ap1.x + CutRadius; p1.y := ap1.y; p2.x := ap1.x + CutRadius; p2.y := ap1.y; p1 := RotatePoint(ap1, p1, FAngle); p2 := RotatePoint(ap1, p2, SAngle); mp1.x := (p1.x + p2.x)/2; mp1.y := (p1.y + p2.y)/2; end; end; begin begin CControl := TPCDrawing(Owner); end; mp1 := ap1; // 1 = mp -- modificate cut Radius mp2 := DoublePoint(ap1.x + Radius, ap1.y); mp3 := DoublePoint(ap1.x + Radius, ap1.y); mp4 := DoublePoint(ap1.x + Radius, ap1.y); // Pie Radius Modificate mp2 := RotatePoint(AP1, mp2, SAngle); mp3 := RotatePoint(AP1, mp3, FAngle); if FAngle = SAngle then begin mp4 := RotatePoint(AP1, mp4, FAngle); // not means (Fangle = Sangle) end else begin if (FAngle < SAngle) then MAngle := SAngle+((2*pi)-SAngle+FAngle)/2 else MAngle := (SAngle+FAngle)/2; mp4 := RotatePoint(AP1, mp4, MAngle); if CutRadius <> 0 then begin mp1.x := mp1.x + cutRadius; mp1 := RotatePoint(ap1, mp1,Mangle); if cutStyle = PieLinearCut then CorrectCutModPoint; end; end; if Radius = 0 then begin ModList.Add(CControl.RegisterModPoint(self,ptArcEnd,ptCircle,clRed,2,mp4.x,mp4.y,4)); end else begin ModList.Add(CControl.RegisterModPoint(self,ptArcEnd,ptRect,clRed,2,mp1.x,mp1.y,1)); // pie Cut Point ModList.Add(CControl.RegisterModPoint(self,ptArcEnd,ptRect,clBlue,pointdim,mp2.x,mp2.y,2)); // one borderPoint ModList.Add(CControl.RegisterModPoint(self,ptArcEnd,ptRect,clBlue,pointdim,mp3.x,mp3.y,3)); // another borderPoint ModList.Add(CControl.RegisterModPoint(self,ptArcEnd,ptCircle,clRed,2,mp4.x,mp4.y,4)); // Pie ARC border modPoint end; end; function TPie.GetCutStyle: TPieCutStyle; var angle1, angle2: Integer; i: Integer; begin Result := PieLinearCut; Angle1 := Round((180/pi)*Sangle); Angle2 := Round((180/pi)*Fangle); if Angle1 = 360 then Angle1 := 0; if Angle2 = 360 then Angle2 := 0; while angle1 <> angle2 do begin inc(angle1); inc(i); if angle1 = 360 then angle1 := 0; end; if i >= 160 then Result := PieArcCut; end; Procedure TPie.Rotate(aAngle: Double; cPoint: TDoublePoint); var RotatedCP: TDoublePoint; begin { Fangle := FAngle + aAngle; SAngle := SAngle + aAngle; } // Tolik 01/11/2019 -- это чтобы круг не поворачивать (ибо нех) if RadToDeg(Sangle) = 0 then if RadToDeg(Fangle) = 360 then exit; // Fangle := ABS(FAngle + aAngle); SAngle := ABS(SAngle + aAngle); While FAngle > 2*PI do FAngle := FAngle - 2*PI; While SAngle > 2*PI do SAngle := SAngle - 2*PI; if ((CompareValue(ap1.x, cPoint.x) <> 0) or (CompareValue(ap1.y, cPoint.y) <> 0)) then begin RotatedCP := RotatePoint(cPoint, ap1, aAngle); originalpoints[1] := RotatedCP; ActualPoints[1] := RotatedCP; end; end; Procedure TPie.Mirror(Point1,Point2: TDoublePoint); var i: Double; begin i := PI; Rotate(I, Point1); ResetRegion; end; procedure TPie.getbounds(var figMaxX,figMaxY,figMinX,figMinY: double); var points: array of TDoublePoint; angle1, angle2: integer; ArrayLength: Integer; PointToRotate: TDoublePoint; {Procedure GetPiePoints; var a: Integer; z: Double; begin Angle1 := Round((180/pi)*Sangle); Angle2 := Round((180/pi)*Fangle); ArrayLength := 1; SetLength(Points, 1); points[0] := ap1; // centerPoint z := 0; while Angle1 <> Angle2 do begin PointToRotate := DoublePoint(ap1.x + Radius, ap1.y, 0); PointToRotate := RotatePoint(ap1,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; end; } Procedure GetPiePoints; var i, cutArrayLength: Integer; cutRadius: double; cutArray: Array of TDoublePoint; p1: TDoublePoint; 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; // 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 Self.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 ord(CutStyle) = 0 then // Linear Cutting begin p1.x := ap1.x + Self.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 + Self.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 ord(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 + Self.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 + Self.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; {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 figMinX := points[0].x; figMinY := points[0].y; figMaxX := points[0].x; figMaxY := points[0].y; if ArrayLength = 1 then begin SetLength(points, 0); exit; end; for i := 1 to ArrayLength - 1 do begin if Comparevalue(figMinX, points[i].x) = 1 then figMinX := points[i].x; if Comparevalue(figMinY, points[i].y) = 1 then figMinY := points[i].y; if Comparevalue(figMaxX, points[i].x) = -1 then figMaxX := points[i].x; if Comparevalue(figMaxY, points[i].y) = -1 then figMaxY := points[i].y; end; end; SetLength(points, 0); end; begin //z := 0; // 01/11/2019 -- Angle1 := Round((180/pi)*Sangle); Angle2 := Round((180/pi)*Fangle); if Angle1 = 0 then if Angle2 = 360 then begin figMinX := ActualPoints[1].x - radius; figMinY := ActualPoints[1].y - radius; figMaxX := ActualPoints[1].x + radius; figMaxY := ActualPoints[1].y + radius; exit; end; // GetPiePoints; // точки GetPieBounds; // границы SetLength(Points, 0); end; class function TPie.CreateFromShadow(aOwner: TComponent; LHandle: Integer; Shadow: TFigure): TFigure; var cad: TPCDrawing; begin Result := Nil; if ((CompareValue(TPie(Shadow).Fangle, TPie(Shadow).Sangle) = 0) or (TPie(Shadow).radius = 0)) then exit; cad := TPCDrawing(aOwner); Result := TPie.Create( shadow.ap1.x, shadow.ap1.y, TPie(shadow).radius, TPie(Shadow).SAngle, TPie(Shadow).FAngle, cad.DefaultPenWidth, ord(cad.DefaultPenStyle), cad.DefaultPenColor, //ord(cad.DefaultBrushStyle), 1, cad.DefaultBrushColor, LHandle,mydsNormal,aOwner, TPie(Shadow).CutStyle, TPie(Shadow).CutRadius); end; class function TPie.CreateShadow(x, y: Double): TFigure; var cutRad: double; begin Result := TPie.Create(x,y,0,0,0,0,0,0,Ord(bsNone),clLime, 0, dsTrace, Nil, PieLinearCut); result.color := clLime; end; Function TPie.GetClassName:String; begin Result := 'Pie'; end; Function TPie.Edit:Boolean; var enterstr: string; begin (* Result := False; EnterStr := FloatToStr(Round2(GetAngle)); //06.10.2011 DLabel; // if InputQuery(capDimensionLabel, msEnterNewLabelText, EnterStr) then //06.10.2011 if InputQuery(cDrawObjects_Mes4, cDrawObjects_Mes5, EnterStr) then if InputQuery(cDrawObjects_Mes4, cDrawObjects_Mes5, EnterStr) then begin //DLabel := EnterStr; //AutoText := False; //Modified := True; //result := true; result := SetAngle(StrToFloat_My(EnterStr)); end; *) end; procedure TPie.Draw(DEngine: TPCDrawEngine; isGrayed: Boolean); var acolor, bcolor : Tcolor; dx,dy: real; Angle,rad,MAngle: Double; p4,p1,p2: TDOublePoint; st: TFontstyles; text: String; gLen: Double; Rect: TRect; aRect: TDoubleRect; maxx, minx, maxy, miny: Double; Function GetCutStyleForDraw: Integer; var GradAngleVal, Angle1, Angle2: Integer; begin Result := 0; if CutRadius = 0 then exit; if Comparevalue(Fangle, Sangle) = 0 then exit; if cutStyle = PieArcCut then begin Result := 1; exit; end; GradAngleVal := 0; // angles Angle1 := Round((180/pi)*Sangle); Angle2 := Round((180/pi)*Fangle); if Angle1 = 360 then Angle1 := 0; if Angle2 = 360 then Angle2 := 0; while Angle1 <> Angle2 do begin angle1 := angle1 + 1; if angle1 = 360 then angle1 := 0; inc(GradAngleVal); if GradAngleVal > 160 then break; end; if GradAngleVal > 160 then Result := 1; end; begin //07.10.2011 - сброс углов для пересчета, если вышли за пределы 2*pi if (DrawStyle = mydsNormal) and ((FAngle > 2*pi) or (SAngle > 2*pi)) then begin SAngle := 0; FAngle := 0; end; acolor := color; if (aColor = -255) and (LayerHandle <> 0) then begin aColor := TLayer(LayerHandle).PenColor; end; if (isGrayed) then begin acolor := TPCDrawing(Owner).FGrayedColor; //06.08.2012 GrayedColor; end; if DrawStyle = dsTrace then DEngine.Canvas.Pen.Mode := pmXor else DEngine.Canvas.Pen.Mode := pmCopy; st := []; if TextBold then st := st + [fsBold]; if TextItalic then st := st + [fsItalic]; text := ''; if DrawStyle = mydsNormal then begin if autotext then begin if FAngle = SAngle then begin MAngle := 2*PI; end else begin if (FAngle < SAngle) then begin MAngle := 2*Pi - SAngle+ FAngle; end else begin MAngle := FAngle-SAngle; end; end; text := FloatToStr(Round2((MAngle/PI)*180)); //07.10.2011 inttostr(round((MAngle/PI)*180)); text := Prefix+text+Suffix; end else text := DLabel; end; if DrawGuides then gLen := GuideLen else gLen := 0; if DrawStyle = mydsNormal then begin //Dengine.DrawPie(Rect.Left, Rect.Top, Rect.Right, Rect.Bottom, brc, brs, ord(cutStyle), RegHandle, AP1, FAngle, SAngle, Radius, CutRadius); //Dengine.DrawPie(Rect.Left, Rect.Top, Rect.Right, Rect.Bottom, brc, brs, GetCutStyleForDraw, RegHandle, AP1, FAngle, SAngle, Radius, CutRadius); if (isAutoCreatedFigure = biFalse) then Dengine.DrawPie(brc, brs, GetCutStyleForDraw, RegHandle, AP1, FAngle, SAngle, Radius, CutRadius) else Dengine.DrawPie(brc, brs, ord(CutStyle), RegHandle, AP1, FAngle, SAngle, Radius, CutRadius); DrawFill(Dengine,isGrayed); DrawClipFigures(Dengine,isGrayed); end else if DrawStyle = dsTrace then begin // DEngine.DrawPieShadow(ap1, Radius, Sangle, Fangle, cutRadius, ord(cutStyle)); DEngine.DrawPieShadow(ap1, Radius, Sangle, Fangle, cutRadius, GetCutStyleForDraw); end; // Tolik if RegHandle > 1 then begin GetRegObject; if TBrushStyle(brs) <> bsClear then RegObject.CheckPointByRects := True; deleteObject(RegHandle); RegHandle := 0; end; // end; function TPie.IsPointIn(x, y: Double): boolean; begin result := inherited isPointIn(x,y); if not result then begin result := isPointInRegion(x,y); // Tolik result := IsPointInRegionByRegObj(x,y); // end; end; procedure TPie.MenuClicked(CommandId: integer); var mnIdx: integer; begin { mnIdx := CommandId-MenuIndex; case mnIdx of 0: DrawGuides:= not DrawGuides; 1: LStyle:= rlsInner; 2: LStyle:= rlsOuter; 3: Invert; 4: AutoText := not AutoText; end; } end; function TPie.GetAngle: Double; var Angle1, Angle2: Double; begin Result := 0; Angle2 := GetradOfLine(ap1,ap2); Angle1 := GetradOfLine(ap1,ap3); if Angle1 = Angle2 then Result := 2*PI else begin if (Angle1 < Angle2) then Result := 2*Pi - Angle2+ Angle1 else Result := Angle1-Angle2; end; Result := Result *(180/pi); end; procedure TPie.Scale(percentx, percenty: Double; rPoint: TDoublePoint); var p1,p2:TDoublePoint; cp: TDoublePOint; division: Double; Begin division := $FFFF; if GuideLen > 0 then division := Radius / GuideLen; Inherited; if (division <> $FFFF) and (division <> 0) then GuideLen := Radius / division; end; function TPie.SetAngle(AValue: Double): Boolean; var NewAngle, AngleDelta: Double; begin Result := false; if (FAngle = 0) and (SAngle = 0) then begin SAngle := GetradOfLine(ap1,ap2); FAngle := GetradOfLine(ap1,ap3); end; if (AValue >= 0) and (AValue <= 360) then begin NewAngle := (AValue/180)*pi; begin AngleDelta := 0; if (FAngle < SAngle) then begin AngleDelta := NewAngle - (2*Pi - SAngle + FAngle); SAngle := SAngle - AngleDelta; if SAngle > 2*pi then SAngle := SAngle - (2*pi); end else begin AngleDelta := NewAngle - (FAngle-SAngle); FAngle := FAngle + AngleDelta; if FAngle > 2*pi then FAngle := FAngle - (2*pi); end; // Если углы почти одинаковы if Abs(FAngle - SAngle) < 0.01 then SAngle := FAngle; Result := true; ResetRegion; Modified := True; end; end; end; procedure TPie.WriteToStream(Stream: TStream); var xByte: Byte; xInt: Integer; xStr: String; xDbl: Double; begin inherited WriteToStream(Stream); //xByte := brs; if brs = -1 then xByte := 255 else xByte := LoByte(LoWord(brs)); WriteField(90,Stream,xByte,1); xByte := ord(CutStyle); WriteField(91,Stream,xByte,1); xInt := brc; WriteField(20,Stream,xInt,4); xDbl := Radius; WriteField(222,Stream,xDbl,8); xDbl := SAngle; WriteField(220,Stream,xDbl,8); xDbl := FAngle; WriteField(221,Stream,xDbl,8); xStr := DLabel; WriteStrField(180,Stream,xStr); xStr := Prefix; WriteStrField(181,Stream,xStr); xStr := Suffix; WriteStrField(182,Stream,xStr); xStr := TextFont; WriteStrField(183,Stream,xStr); xDbl := TextHeight; WriteField(230,Stream,xDbl,8); xDbl := GuideLen; WriteField(231,Stream,xDbl,8); xDbl := CutRadius; WriteField(232,Stream,xDbl,8); // cutRadius if TextBold then xByte := 1 else xByte := 0; WriteField(100,Stream,xByte,1); if TextItalic then xByte := 1 else xByte := 0; WriteField(101,Stream,xByte,1); if AutoText then xByte := 1 else xByte := 0; WriteField(102,Stream,xByte,1); if DrawGuides then xByte := 1 else xByte := 0; WriteField(103,Stream,xByte,1); xByte := ord(LStyle);WriteField(104,Stream,xByte,1); end; procedure TPie.SetPropertyFromStream(xCode: Byte; data: pointer; size: integer); begin inherited; Case xcode of 20: brc := pInt(data)^; 21: Radius := pInt(data)^/10; 90: begin if pByte(data)^ = 255 then brs := -1 else brs := pByte(data)^; end; 91: CutStyle := TPieCutStyle(pByte(data)^); 220: SAngle := pDouble(data)^; 221: FAngle := pDouble(data)^; 222: Radius := pDouble(data)^; 100 : TextBold := ((pByte(data)^) = 1); 101 : TextItalic := ((pByte(data)^) = 1); 102 : AutoText := ((pByte(data)^) = 1); 103 : DrawGuides := ((pByte(data)^) = 1); 104 : LStyle := TArcDimLabelStyle(pByte(data)^); 180: DLabel := string(pchar(data)); 181: Prefix := string(pchar(data)); 182: Suffix := string(pchar(data)); 183: TextFont := string(pchar(data)); 230: TextHeight := pDouble(data)^; 231: GuideLen := pDouble(data)^; 232: CutRadius := pDouble(data)^; // cut Radius (from center Point) 253: isAutocreatedFigure := pByte(data)^; 254: Transparency := PInteger(data)^; end; end; function TPie.ShadowClick(ClickIndex: Integer; x, y: Double): Boolean; var cp,p1: TDoublePoint; begin result := false; if clickIndex = 2 then begin radius := sqrt(sqr(x - ap1.x) + sqr(y - ap1.y)); cp := ap1; p1 := DoublePoint(x,y); SAngle := GetradOfLine(cp,p1); FAngle := SAngle; result := false; end else if clickindex = 3 then begin cp := ap1; p1 := DoublePoint(x,y); FAngle := GetradOfLine(cp,p1); result := true; end; end; function TPie.ShadowTrace(ClickIndex: Integer; x, y: Double): Boolean; var cp,p1,p2: TDoublepoint; Degree: Double; StrRadius: string; begin strradius := ''; If ClickIndex = 1 then begin Radius := sqrt(sqr(x - ap1.x)+ sqr(y - ap1.y)); cp := ap1; p1 := DoublePoint(x,y); SAngle := GetradOfLine(cp,p1); FAngle := SAngle; end else if ClickIndex = 2 then begin cp := ap1; p1 := DoublePoint(x,y); FAngle := GetradOfLine(cp,p1); end; end; function TPie.CreateModification: TFigure; begin Result := TPie.Create(ap1.x,ap1.y,Radius,SAngle,Fangle,0,0,0,Ord(bsNone),clLime, 0, dsTrace, nil, cutStyle, cutRadius); Result.Color := clLime; end; Function TPie.GetMiddleAngle: Double; var i, angle1, angle2 : Integer; pp1: TDoublepoint; begin Result := 0; // angles Angle1 := Round((180/pi)*Fangle); Angle2 := Round((180/pi)*Sangle); if Angle1 = 360 then Angle1 := 0; if Angle2 = 360 then Angle2 := 0; i := 0; while Angle1 <> Angle2 do begin inc(Angle1); inc(i); if Angle1 = 360 then begin Angle1 := 0; i := 0; end; end; if i <> 0 then Result := (i/2)/180*PI; end; function TPie.TraceModification(CadControl: Pointer; mp: TModPoint; TraceFigure: TFigure; x, y: double; Shift: TShiftState): boolean; var Angle, MiddleAngle: Double; cp,p1, p2: TDoublepoint; Minx, Miny, MaxX, MaxY: Double; cutRadius: Double; begin cp := ap1; p1 := DoublePoint(x,y); Angle := GetRadOfLine(cp,p1); if mp.SeqNbr = 2 then begin TPie(TraceFigure).SAngle := Angle; //TPie(TraceFigure).FAngle := Angle; end else if mp.SeqNbr = 3 then begin TPie(TraceFigure).FAngle := Angle; end else if (mp.SeqNbr = 4) then //or (mp.SeqNbr = 5) then begin TPie(TraceFigure).Radius := sqrt( sqr(x - cp.x)+sqr(y - cp.y)); //TPie(TraceFigure).Fangle := TPie(TraceFigure).Sangle; end else if (mp.SeqNbr = 1) then // CUT PIE MODPOINT !!! begin TPie(TraceFigure).cutRadius := sqrt(sqr(x - ap1.x) + sqr(y - ap1.y)); {if (FAngle < SAngle) then begin MiddleAngle := SAngle+((2*pi)-SAngle+FAngle)/2; end else begin MiddleAngle := (SAngle+FAngle)/2; end; } end; end; function TPie.EndModification(CadControl: Pointer; mp: TModPoint; TraceFigure: TFigure; x, y: double; Shift: TShiftState): boolean; var Angle, MAngle: Double; cp, p1, p2: TDoublepoint; r: Double; bool:Boolean; begin bool := (radius = GuideLen); //result := Inherited EndModification(CadControl,mp,TraceFigure,x,y,shift); cp := ap1; p1 := DoublePoint(x,y); Angle := GetradOfLine(cp,p1); if mp.SeqNbr = 2 then SAngle := Angle else if mp.SeqNbr = 3 then FAngle := Angle else if mp.SeqNbr = 4 then Radius := sqrt( sqr(x - cp.x)+sqr(y - cp.y) ); ResetRegion; Modified := True; if mp.SeqNbr = 4 then begin if bool then GuideLen := Radius; if GuideLen > Radius then GuideLen := Radius; end else if mp.SeqNbr = 1 then begin CutRadius := sqrt( sqr(x - cp.x)+sqr(y - cp.y)); GuideLen := Radius - CutRadius; end; end; procedure TPie.UpdateMenu(var popMenu: TPopUpMenu; var sIndex: Integer); var mnItem,subItem:TMenuItem; begin menuIndex := sIndex; mnItem := TMenuItem.Create(PopMenu); mnItem.Caption := fmDrawGuides; mnItem.Tag := sIndex; if DrawGuides then mnItem.Checked := true; PopMenu.Items.Add(mnItem); mnItem := TMenuItem.Create(PopMenu); mnItem.Caption := fmDimPosition; mnItem.Tag := 0; PopMenu.Items.Add(mnItem); subItem := TMenuItem.Create(PopMenu); subItem.Caption := fmInsideArc; subItem.Tag := sIndex+1; if LStyle = rlsInner then subItem.Checked := true; mnItem.Add(subItem); subItem := TMenuItem.Create(PopMenu); subItem.Caption := fmOutsideArc; subItem.Tag := sIndex+2; if LStyle = rlsOuter then subItem.Checked := true; mnItem.Add(subItem); mnItem := TMenuItem.Create(PopMenu); mnItem.Caption := fmInvertArc; mnItem.Tag := sIndex+3; PopMenu.Items.Add(mnItem); mnItem := TMenuItem.Create(PopMenu); mnItem.Caption := fmAutoLabel; mnItem.Tag := sIndex+4; if AutoText then mnItem.Checked := true; PopMenu.Items.Add(mnItem); sIndex := sIndex+5; end; // ------------- End Pie ----------------------// function TPolyline.GetArea: Double; begin result := 0; if closed then begin result := GetAreaOfPGon(Actuals); end; end; function TPolyline.GetLength: Double; var i: Integer; begin result := 0; for i := 1 to PointCount-1 do begin result:= result+GetLineLength(FigurePoints[i],FigurePoints[i+1]); end; if closed then begin result:= result+GetLineLength(FigurePoints[PointCount],FigurePoints[1]); end; end; function TEllipse.GetArea: Double; begin result := pi*alen*bLen; end; function TEllipse.GetLength: Double; var a2pb2:Double; amb2d2:double; begin a2pb2 := alen*alen+blen*blen; amb2d2 := ((alen-bLen)*(alen-bLen))/2; result := sqrt(2*a2pb2-amb2d2)*pi; end; function TCircle.GetArea: Double; begin result := GetareaOfCircle(Radius); end; function TCircle.GetLength: Double; begin result := GetPerimeterOfCircle(Radius); end; function TRectangle.GetArea: Double; begin result := GetLineLength(ap1,ap2)* GetLineLength(ap2,ap3); end; Destructor TRectangle.Destroy; begin FreeMem(FDrawPoints, 5*8); Inherited; end; function TRectangle.GetLength: Double; begin result := GetLineLength(ap1,ap2)+ GetLineLength(ap2,ap3); result := 2*result; end; procedure Tlayer.SetLayerPropertyStream(xCode: Byte; Stream: TStream; CadControl: TObject); var Cad:TPCDrawing; begin if xCode = 151 then begin Cad := TPCDrawing(CadCOntrol); if assigned(Stream) and assigned(Cad) and assigned(Cad.OnLayerLoadData) then begin Cad.OnLayerLoadData(Cad,Self,Stream); end; end; end; procedure TPolyline.SimplfyPoints; var i: Integer; p1,p2,p3: TDoublePoint; p: Array of Integer; cnt: Integer; d: Double; begin cnt := 0; SetLength(p,cnt); for i := 2 to PointCount -1 do begin if (i mod 2) = 0 then begin p1 := ActualPoints[i-1]; p2 := ActualPoints[i]; p3 := ActualPoints[i+1]; d := GetDistToLine(p1,p3,p2); if d <= 1 then begin cnt := cnt+1; SetLength(p,cnt); p[cnt-1] := i; end; end; end; for i:= cnt-1 downto 0 do begin DeleteKnot(p[i]); end; NeedBounds := True; //Tolik 02/08/2021 -- end; { TPointSet } class function TPointSet.CreateFromShadow(aOwner: TComponent; LHandle: Integer; Shadow: TFigure): TFigure; var cad: TPCDrawing; points: TDoublePointArr; a: integer; begin result := nil; cad := TPCDrawing(aOwner); if Shadow.PointCount < 3 then exit; SetLength(points,Shadow.PointCount-2); for a := 1 to Shadow.PointCount-2 do begin points[a-1] := Shadow.ActualPoints[a]; end; result := TPointSet.create(points, cad.DefaultPenWidth, ord(cad.DefaultPenStyle), cad.DefaultPenColor, ord(cad.DefaultBrushStyle), cad.DefaultBrushColor, ord(cad.DefaultRowStyle), TPolyline(Shadow).Closed or Cad.DefaultPLineClosed, LHandle,mydsNormal,aOwner); end; function TPointSet.CreateModification: TFigure; var points: TDoublePointArr; a: integer; Res: TPolyLine; p: PPoint; begin SetLength(points,PointCount); for a := 1 to PointCount do begin points[a-1] := ActualPoints[a]; end; Res := TPointSet.create(points,1,1,clLime,0,0,0,closed,0,dsTrace,nil); res.SelectedPoint := SelectedPoint; if assigned(res) then res.RotPoint := RotPoint; CreateModification := res; end; class function TPointSet.CreateShadow(x, y: Double): TFigure; var points: TDoublePointArr; begin SetLength(points,2); points[0] := DoublePoint(x,y); points[1] := DoublePoint(x,y); CreateShadow := TPointSet.create(Points,1,1,clLime,0,0,ord(rsNone),false,0,dsTrace,nil); //CreateShadow.PointCount := 1; end; procedure TPointSet.Draw(Dengine: TPCDrawEngine; isGrayed: Boolean); var Layer: TLayer; acolor,bColor : Tcolor; Grayedd : boolean; ap: TdoublePoint; i: Integer; rgn: HRGN; begin aColor := Color; if (aColor = -255) and (LayerHandle <> 0) then begin aColor := TLayer(LayerHandle).PenColor; end; bColor := brc; if (bColor = -255) and (LayerHandle <> 0) then begin bColor := TLayer(LayerHandle).BrushColor; end; Grayedd := false; if (isGrayed) then begin acolor := TPCDrawing(Owner).FGrayedColor; //06.08.2012 GrayedColor; bColor := TPCDrawing(Owner).FGrayedColor; //06.08.2012 GrayedColor; Grayedd := true; end; if drawStyle = dsTrace then DEngine.Canvas.Pen.Mode := pmXor else DEngine.Canvas.Pen.Mode := pmCopy; for i := 1 to PointCount do begin ap := ActualPoints[i]; rgn := 1; Dengine.DrawCircle(ap,0.8,aColor,1,ord(psSolid),aColor,ord(bsSolid),rgn); //Dengine.drawselectionpoint(ap.x,ap.y,ap.z,ptCircle,4,aColor,(drawStyle = dsTrace)); end; if (drawStyle = dsTrace) and (PointCount > 2) and (ap1.x = ActualPoints[PointCount].x) and (ap1.y = ActualPoints[PointCount].y) then begin DEngine.drawselectionpoint(ap1.x,ap1.y,ap1.z,ptECircle,6,clLime,True); end; end; procedure TPointSet.DrawSelectionPoints(DEngine: TPCDrawEngine; isGrayed: Boolean); var Layer: TLayer; a : integer; pt : TModPoint; aColor : TColor; fKnot:TPoint; lColor: integer; idx: Integer; x,y,z: Double; ap: TDoublePoint; begin // Tolik 24/12/2019 -- //For a := 0 to SelPoints.Count -1 do for a := SelPoints.Count - 1 downto 0 do begin if SelPoints[a] = nil then SelPoints.delete(a) else begin // pt := TModPoint(SelPoints[a]); if isGrayed then acolor := TPCDrawing(Owner).FGrayedColor //06.08.2012 Grayedcolor else aColor := pt.Color; if isGrayed then lcolor := TPCDrawing(Owner).FGrayedColor //06.08.2012 Grayedcolor else lColor := clred; if pt.pType = ptPolyPoint then begin if selectedpoint = pt.SeqNbr then begin aColor := clRed; if SelectedPoint = PointCount then ap := ActualPoints[1] else ap := ActualPoints[selectedpoint+1]; end; DrawSelPoint(DEngine,isGrayed,pt); end; x := pt.CoordX; y := pt.CoordY; z := pt.CoordY; DEngine.ConvertPoint(x,y,z); pt.PixX := Round(x); pt.PixY := Round(y); end; end; end; function TPointSet.GetClassName: String; begin result := 'PointSet'; end; { TAngleLine } class function TAngleLine.CreateFromShadow(aOwner: TComponent; LHandle: Integer; Shadow: TFigure): TFigure; var cad: TPCDrawing; points: TDoublePointArr; a: integer; begin cad := TPCDrawing(aOwner); SetLength(points,Shadow.PointCount-1); for a := 1 to Shadow.PointCount-1 do begin points[a-1] := Shadow.ActualPoints[a]; end; result := TAngleLine.create(points, cad.DefaultPenWidth, ord(cad.DefaultPenStyle), cad.DefaultPenColor, ord(cad.DefaultBrushStyle), cad.DefaultBrushColor, ord(cad.DefaultRowStyle), TPolyline(Shadow).Closed or False, LHandle,mydsNormal,aOwner); end; function TAngleLine.CreateModification: TFigure; var points: TDoublePointArr; a: integer; Res: TPolyLine; p: PPoint; begin SetLength(points,PointCount); for a := 1 to PointCount do begin points[a-1] := ActualPoints[a]; end; Res := TAngleLine.create(points,1,1,clLime,0,0,0,closed,0,dsTrace,nil); res.SelectedPoint := SelectedPoint; if assigned(res) then res.RotPoint := RotPoint; CreateModification := res; end; class function TAngleLine.CreateShadow(x, y: Double): TFigure; var points: TDoublePointArr; begin SetLength(points,2); points[0] := DoublePoint(x,y); points[1] := DoublePoint(x,y); CreateShadow := TAngleLine.create(Points,1,1,clLime,0,0,ord(rsNone),false,0,dsTrace,nil); end; procedure TAngleLine.Draw(Dengine: TPCDrawEngine; isGrayed: Boolean); var xp1,xp2,cp: TDoublePoint; rgn: HRGN; a,a1,a2: Double; sw: Boolean; begin inherited; if drawStyle = mydsNormal then begin xp1 := ap1; xp2 := ap3; cp := ap2; a1 := GetRadOfLine(cp,xp1); a2 := GetRadOfLine(cp,xp2); sw := false; if a1 > a2 then begin a := a1-a2; if a < pi then sw := true; end else begin a := a2-a1; if a > pi then sw := true; end; if sw then begin a := a1; a1 := a2; a2 := a; end; a := GetAngle; DEngine.drawbezarc(cp.x,cp.y,10.0,a1,a2,color,1,style,brc,brs, ord(asOpen),rgn,xp1,xp2,false,ord(rsBothSolid),1.5,0.7); xp1 := Mpoint(cp,xp1,10.0); xp2 := Mpoint(cp,xp2,10.0); xp1 := MPoint(xp1,xp2); xp1 := Mpoint(cp,xp1,10.0); xp1 := MovePoint(xp1,2.5,0); Dengine.DrawCenteredText(xp1,color,floattostr(a)+'°','Tahoma',2.0); end; end; procedure TAngleLine.DrawSelectionPoints(DEngine: TPCDrawEngine; isGrayed: Boolean); var Layer: TLayer; a : integer; pt : TModPoint; aColor : TColor; fKnot:TPoint; lColor: integer; idx: Integer; x,y,z: Double; ap: TDoublePoint; begin // Tolik 24/12/2019 -- //For a := 0 to SelPoints.Count -1 do For a := SelPoints.Count - 1 downto 0 do begin pt := TModPoint(SelPoints[a]); if pt = nil then SelPoints.delete(a) else begin // if isGrayed then acolor := TPCDrawing(Owner).FGrayedColor //06.08.2012 Grayedcolor else aColor := pt.Color; if isGrayed then lcolor := TPCDrawing(Owner).FGrayedColor //06.08.2012 Grayedcolor else lColor := clred; if pt.pType = ptPolyPoint then begin if selectedpoint = pt.SeqNbr then begin aColor := clRed; if SelectedPoint = PointCount then ap := ActualPoints[1] else ap := ActualPoints[selectedpoint+1]; end; DrawSelPoint(DEngine,isGrayed,pt); end; x := pt.CoordX; y := pt.CoordY; z := pt.CoordY; DEngine.ConvertPoint(x,y,z); pt.PixX := Round(x); pt.PixY := Round(y); end; end; end; function TAngleLine.GetAngle: Double; var a: DOuble; begin a := GetRadOf2Lines(ap1,ap2,ap3); a := abs(a); if a > pi then a := 2*pi-a; a := a * (180/pi); result := Trunc(a*10)/10; end; function TAngleLine.GetClassName: String; begin Result := 'AngleLine'; end; function TAngleLine.ShadowClick(ClickIndex: Integer; x, y: Double): Boolean; begin result := inherited ShadowClick(ClickIndex,x,y); result := false; if clickIndex = 3 then result := True; end; { TCalibrate } class function TCalibrate.CreateFromShadow(aOwner: TComponent; LHandle: Integer; Shadow: TFigure): TFigure; var cad: TPCDrawing; begin cad := TPCDrawing(aOwner); cad.CalibrateLayerScale(Shadow.ap1,Shadow.ap2,CalibrateUnit); result := nil; end; class function TCalibrate.CreateShadow(x, y: Double): TFigure; begin CreateShadow := TCalibrate.create(DoublePoint(x,y),DoublePoint(x,y)); end; procedure TCalibrate.draw(DEngine: TPCDrawEngine; isGrayed: Boolean); var xp1,xp2,xp3,xp4: TDoublePoint; u: string; begin //CalibrateUnit: Byte = 0; // 0=nm 1=mm 2=cm 3=dm 4=m 5=km case calibrateUnit of 0: u := 'nm'; 1: u := 'mm'; 2: u := 'cm'; 3: u := 'dm'; 4: u := 'm'; 5: u := 'km'; end; DEngine.Canvas.pen.mode := pmXor; DEngine.drawline(ap1.x,ap1.y,ap2.x,ap2.y,clLime,1,ord(psSolid),0); GetParallelPoints(ap1,ap2,xp1,xp2,4); GetParallelPoints(ap1,ap2,xp3,xp4,-4); DEngine.drawline(xp1.x,xp1.y,xp3.x,xp3.y,clLime,1,ord(psSolid),0); DEngine.drawline(xp2.x,xp2.y,xp4.x,xp4.y,clLime,1,ord(psSolid),0); if not EQDP(ap1,ap2) then begin Dengine.TraceText(Mpoint(ap1,ap2),clLime,'1 '+u,'Tahoma',8); end; end; procedure TBMPObject.RelocatePoints; var xp:TDoublePOint; begin if (ap1.x > ap2.x) then begin xp := ap1; actualpoints[1] := ap2; actualpoints[2] := xp; xp := ap3; actualpoints[3] := ap4; actualpoints[4] := xp; ImageEdited := True; // Tolik 20/04/2018 -- end; if (ap1.y > ap4.y) then begin xp := ap1; actualpoints[1] := ap4; actualpoints[4] := xp; xp := ap2; actualpoints[2] := ap3; actualpoints[3] := xp; ImageEdited := True; // Tolik 20/04/2018 -- end; end; procedure TPolyline.RoundCornerByArc(SeqNbr: Integer; Rad: Double); var xp1,xp2: TDoublePoint; np1,np2: TDoublePoint; begin if (rad > 0) and (PointCOunt > 2) then begin xp1 := ActualPoints[SeqNbr]; if SeqNbr = PointCount then xp2 := ActualPoints[1] else xp2 := ActualPoints[SeqNbr+1]; np1 := MPoint(xp1,xp2,rad); if SeqNbr = 1 then xp2 := ActualPoints[PointCount] else xp2 := ActualPoints[SeqNbr-1]; np2 := MPoint(xp1,xp2,rad); InsertKnot(SeqNbr,np1); ActualPoints[SeqNbr] := np2; ArrangeSegment(SeqNbr,sArc); end; end; function TBMPObject.DoMagicWand(x, y: Double): TFigure; var points: TDoublePointArr; pLine: TPolyline; Closed: Boolean; begin result := nil; if isPointIn(x,y) then begin CreateMWPath(x,y,0.3,points,Closed); if Length(Points) > 0 then begin pLine := TPolyline.create(points,2,ord(psSOlid),clBlack,ord(bsClear),clWhite,0,True,LayerHandle,mydsNormal,Owner); result := pLine; end; end; end; function TFigure.ShadowKeyStroke(var ClickIndex,KeyCode: Integer; Shift: TShiftState;var Fnished: Boolean): Boolean; begin result := false; Fnished := False; end; function TPolyline.ShadowKeyStroke(var ClickIndex, KeyCode: Integer; Shift: TShiftState; var Fnished: Boolean): Boolean; var lx,ly,dx,dy: Double; xp1,xp2: TDoublePoint; horz: Boolean; Procedure NewPoint; begin if not EQD(lx,ly) then begin PointCount := PointCount+1; ClickIndex := ClickIndex+1; actualPoints[PointCount] := actualPoints[PointCount-1]; end; end; begin dx := 0; dy := 0; xp1 := ActualPoints[PointCount-1]; xp2 := ActualPoints[PointCount]; lx := xp2.x-xp1.x; ly := xp2.y-xp1.y; horz := abs(lx) > abs(ly); if KeyCode = VK_LEFT then begin result := true; dx := -1; if (not horz) then begin NewPoint; end; end else if KeyCode = VK_RIGHT then begin result := true; dx := 1; if not horz then begin NewPoint; end; end else if KeyCode = VK_UP then begin result := true; dy := -1; if horz then begin NewPoint; end; end else if KeyCode = VK_DOWN then begin result := true; dy := 1; if horz then begin NewPoint; end; end else if (KeyCode = VK_RETURN) then begin NewPoint; if (ssCtrl in Shift) and (PointCount > 3) then begin ActualPoints[PointCount-1] := ap1; dx := ActualPoints[PointCount-1].x- ActualPoints[PointCount-2].x; dy := ActualPoints[PointCount-1].y- ActualPoints[PointCount-2].y; xp1 := ActualPoints[PointCount-2]; if abs(dx) > abs(dy) then begin ActualPoints[PointCount-2] := DoublePOint(xp1.x,ap1.y); end else begin ActualPoints[PointCount-2] := DoublePOint(ap1.x,xp1.y); end; end; PointCount := PointCount+1; result := true; fnished := True; exit; end; ActualPoints[PointCount] := DoublePoint(ActualPoints[PointCount].x+dx,ActualPoints[PointCount].y+dy); end; procedure TFigure.SetModified; begin Modified := True; end; procedure TPolyline.HatchBySegment(SegIdx: Integer; Distance: Double); var xp1,xp2,lp1,lp2: TDoublePoint; xRect: TDoubleRect; dist,mlen: Double; cnt : Integer; begin SetLength(HatchLines,0); if not closed then exit; HatchSeg := SegIdx; HatchDist := Distance; xRect := Self.GetBoundRect; mLen := GetLineLength(DoublePoint(xRect.left,xRect.top),DoublePoint(xRect.right,xRect.bottom)); xp1 := ActualPoints[SegIdx]; xp2 := ActualPoints[SegIdx+1]; ExtendLine(xp1,xp2,mLen); cnt := 2; SetLength(HatchLines,cnt); HatchLines[cnt-2] := xp1; HatchLines[cnt-1] := ActualPoints[SegIdx]; cnt := cnt+2; SetLength(HatchLines,cnt); HatchLines[cnt-2] := xp2; HatchLines[cnt-1] := ActualPoints[SegIdx+1]; repeat dist := dist+distance; GetParallelPoints(xp1,xp2,lp1,lp2,dist); cnt := cnt+2; SetLength(HatchLines,cnt); HatchLines[cnt-2] := lp1; HatchLines[cnt-1] := lp2; until abs(dist) > mLen; dist := 0; distance := -distance; repeat dist := dist+distance; GetParallelPoints(xp1,xp2,lp1,lp2,dist); cnt := cnt+2; SetLength(HatchLines,cnt); HatchLines[cnt-2] := lp1; HatchLines[cnt-1] := lp2; until abs(dist) > mLen; end; procedure TPolyline.RemoveHatch; begin SetLength(HatchLines,0); HatchSeg := -1; end; procedure TFigure.Scale(px, py: Double); begin Scale(px,py,CenterPoint); end; procedure TFigure.Unfilled; begin brs := ord(bsClear); end; function TFigure.DuplicateAsStroke: TFigure; var Layer: TLayer; acolor : TColor; a,i,k : integer; TestX,TestY1,TestY2,Z: Double; TopY : boolean; lMult: integer; points: TDoublePointArr; xlen: Double; nLen,nH: Integer; pt: TPoint; typ: Byte; PointArr:array of TPoint; TypeArr: array of Byte; Dengine: TPCDrawEngine; pCnt,kCnt: Integer; fCnt: Integer; fClosed: Boolean; pArr: TDoublePointArr; Segments: TList; plSegment,dSegment: TPLSegment; x,y: Double; dp: TDoublePOint; bezIndex: Integer; grp: TFigureGrp; pl: TPolyline; begin if assigned(owner) then begin Dengine := TPCDrawing(Owner).Dengine; end else exit; Segments := TList.Create; BeginPath(DEngine.Canvas.Handle); Draw(Dengine,false); EndPath(DEngine.Canvas.Handle); WidenPath(DEngine.Canvas.Handle); SetLength(PointArr,1000); SetLength(TypeArr,1000); pCnt := GetPath(DEngine.Canvas.Handle,PointArr,TypeArr,0); SetLength(PointArr,pCnt); SetLength(TypeArr,pCnt); pCnt := GetPath(DEngine.Canvas.Handle,PointArr[0],TypeArr[0],pcnt); fCnt := 0; kCnt := 0; bezIndex := 0; grp := TFigureGrp.create(LayerHandle,Owner); for i:= 0 to pcnt-1 do begin pt := PointArr[i]; x := pt.x; y := pt.y; z := 0; Dengine.DeConvertPoint(x,y,z); dp := DoublePOint(x,y); typ := TypeArr[i]; Case typ of PT_LINETO or PT_CLOSEFIGURE: begin fClosed := True; kCnt := kCnt+1; SetLength(pArr,kCnt); pArr[kCnt-1] := dp; plSegment := TPlSegment.Create(0,sLine,dp,dp); Segments.Add(plSegment); end; PT_BEZIERTO or PT_CLOSEFIGURE: begin fClosed := True; bezIndex := 0; kCnt := kCnt+1; SetLength(pArr,kCnt); pArr[kCnt-1] := dp; end; PT_LINETO: begin kCnt := kCnt+1; SetLength(pArr,kCnt); pArr[kCnt-1] := dp; plSegment := TPlSegment.Create(0,sLine,dp,dp); Segments.Add(plSegment); end; PT_BEZIERTO: begin bezIndex := BezIndex+1; if bezIndex = 1 then begin plSegment := TPlSegment.Create(0,sCurve,dp,dp); Segments.Add(plSegment); end else if bezIndex = 2 then begin plSegment.Cpoint2 := dp; end else if BezIndex = 3 then begin bezIndex := 0; kCnt := kCnt+1; SetLength(pArr,kCnt); pArr[kCnt-1] := dp; end; end; PT_MOVETO: begin fcnt := fcnt+1; if fcnt > 1 then begin pl := TPolyline.create(parr,width,ord(psSolid),color,ord(bsClear),color, 0,fClosed,LayerHandle,mydsNormal,owner); grp.AddFigure(pl); try for k := 0 to Segments.Count-1 do begin plSegment := TPLSegment(Segments[k]); if plSegment.SType = sCurve then begin dSegment := TPLSegment(pl.Segments[k]); dSegment.SType := sCurve; dSegment.CPoint1 := plSegment.CPoint1; dSegment.CPoint2 := plSegment.CPoint2; end; plSegment.free; end; Segments.Clear; except // on E: Exception do AddExceptionToLog(CPowerCadMessage + 'TFigure.DuplicateAsStroke' + E.Message); end; end; fClosed := false; kCnt := 0; kCnt := kCnt+1; SetLength(pArr,kCnt); pArr[kCnt-1] := dp; end; end; end; if kcnt > 0 then begin pl := TPolyline.create(parr,width,ord(psSolid),color,ord(bsClear),color, 0,fClosed,LayerHandle,mydsNormal,owner); grp.AddFigure(pl); try for k := 0 to Segments.Count-1 do begin plSegment := TPLSegment(Segments[k]); if plSegment.SType = sCurve then begin dSegment := TPLSegment(pl.Segments[k]); dSegment.SType := sCurve; dSegment.CPoint1 := plSegment.CPoint1; dSegment.CPoint2 := plSegment.CPoint2; end; plSegment.free; end; Segments.Clear; except // on E: Exception do AddExceptionToLog(CPowerCadMessage + 'TFigure.DuplicateAsStroke' + E.Message); end; end; Segments.Free; if assigned(pl) then result := grp else begin grp.DestroyInFigures; grp.Destroy; end; end; { TFigureFill } procedure TFigureFill.BuildGradient; var xColor: TColor; begin GradBmp := Tbitmap.Create; GradBmp.PixelFormat := pf24bit; xColor := clWhite; if BackColor <> clNone then xColor := BackColor; MakeGradBitmap(xColor,Color,GradStyle,GradBmp); end; procedure TFigureFill.BuildHatch; var rect: TDoubleRect; done: Boolean; rp1,rp2,rp3,rp4: TDoublePoint; p1,p2,p3,p4: TDoublePoint; op1,op2,op3,op4: TDoublePoint; maxVal1: Double; maxVal2: Double; maxField1: PDouble; maxField2: PDouble; Line: TFigure; FRect: TRectangle; dx1,dy1: Double; dx2,dy2: Double; xStep,bStep: Double; xp1,xp2,xp3,xp4,tp1,tp2,tp3,tp4: TDoublePoint; ccnt,i,row: Integer; Style: THatchStyle; begin Style := HatchStyle; if Style = hsNone then exit; Grp := TfigureGrp.create(Owner.LayerHandle,owner.owner); rect := Owner.GetBoundRect; done := false; rp1 := DoublePoint(rect.Left,rect.top); rp2 := DoublePoint(rect.Right,rect.top); rp3 := DoublePoint(rect.Right,rect.bottom); rp4 := DoublePoint(rect.Left,rect.bottom); rp2 := MPoint(rp2,rp1,-Step*2); rp3 := MPoint(rp3,rp4,-Step*2); rp3 := MPoint(rp3,rp2,-Step*2); rp4 := MPoint(rp4,rp1,-Step*2); xStep := Step; if Style in [hsLDiagonal,hsRDiagonal,hsDCross,hsDCheckered,hsDBricks] then begin xStep := Sqrt(2)*Step; end; case Style of hsHorizontal: begin p1 := rp1; p2 := rp2; maxVal1 := rp3.y; maxField1 := @(p1.y); dx1 := 0; dy1 := xStep; end; hsHBricks: begin p1 := MovePoint(rp1,0,-Step); p2 := MovePoint(rp2,0,-Step);; maxVal1 := rp3.y; maxField1 := @(p1.y); dx1 := 0; dy1 := xStep; end; hsVertical,hsVBricks: begin p1 := rp1; p2 := rp4; maxVal1 := rp3.x; maxField1 := @(p1.x); dx1 := xStep; dy1 := 0; end; hsCross: begin p1 := rp1; p2 := rp2; p3 := rp1; p4 := rp4; maxVal1 := rp3.y; maxField1 := @(p1.y); maxVal2 := rp3.x; maxField2 := @(p3.x); dx1 := 0; dy1 := xStep; dx2 := xStep; dy2 := 0; end; hsRDiagonal: begin p1 := rp1; p2 := MovePoint(rp4,-1*abs(rp1.y-rp4.y),0); maxVal1 := rp3.x; maxField1 := @(p2.x); dx1 := xStep; dy1 := 0; end; hsLDiagonal: begin p1 := MovePoint(rp1,-1*abs(rp1.y-rp4.y),0); p2 := rp4; maxVal1 := rp3.x; maxField1 := @(p1.x); dx1 := xStep; dy1 := 0; end; hsDCross: begin p1 := rp1; p2 := MovePoint(rp4,-1*abs(rp1.y-rp4.y),0); p3 := MovePoint(rp1,-1*abs(rp1.y-rp4.y),0); p4 := rp4; maxVal1 := rp3.x; maxField1 := @(p2.x); maxVal2 := rp3.x; maxField2 := @(p3.x); dx1 := xStep; dy1 := 0; dx2 := xStep; dy2 := 0; end; hsCheckered: begin p1 := rp1; p2 := rp4; maxVal1 := rp3.x; maxField1 := @(p1.x); dx1 := xStep; dy1 := 0; end; hsDCheckered,hsDBricks: begin p1 := rp1; p2 := MovePoint(rp4,-1*abs(rp1.y-rp4.y),0); maxVal1 := rp3.x; maxField1 := @(p2.x); dx1 := xStep; dy1 := 0; end; end; op1 := p1; op2 := p2; op3 := p3; op4 := p4; row := 0; repeat p1 := MovePoint(p1,dx1,dy1); p2 := MovePoint(p2,dx1,dy1); if Style in [hsCheckered,hsDCheckered] then begin ccnt := Trunc(GetLineLength(p1,p2) / Step) + 2; row := row+1; for i := 1 to cCnt do begin if (odd(i) and odd(row)) then begin tp1 := MPoint(p1,p2,Step*(i-1)); tp2 := MPoint(p1,p2,Step*(i)); GetParallelPoints(tp1,tp2,tp4,tp3,Step); FRect := TRectangle.create(0,0,0,0,1,ord(psClear),Color,ord(bsSolid),color,0,mydsNormal,Owner.Owner); FRect.ActualPoints[1] := tp1; FRect.ActualPoints[2] := tp2; FRect.ActualPoints[3] := tp3; FRect.ActualPoints[4] := tp4; FRect.NativeFill := True; grp.AddToGrp(FRect);//28.04.2011 grp.InFigures.Add(FRect); tp1 := tp2; tp2 := MPoint(p1,p2,Step*(i+1)); GetParallelPoints(tp1,tp2,tp1,tp2,Step); GetParallelPoints(tp1,tp2,tp4,tp3,Step); FRect := TRectangle.create(0,0,0,0,1,ord(psClear),Color,ord(bsSolid),color,0,mydsNormal,Owner.Owner); FRect.ActualPoints[1] := tp1; FRect.ActualPoints[2] := tp2; FRect.ActualPoints[3] := tp3; FRect.ActualPoints[4] := tp4; FRect.NativeFill := True; grp.AddToGrp(FRect); //28.04.2011 grp.InFigures.Add(FRect); end; end; end else if Style in [hsHBricks,hsVBricks,hsDBricks] then begin bStep := Step*1.9; ccnt := Trunc(GetLineLength(p1,p2) / bStep) + 2; row := row+1; for i := 1 to cCnt do begin if (odd(i) and odd(row)) then begin tp1 := MPoint(p1,p2,bStep*(i-1)); tp2 := MPoint(p1,p2,bStep*(i)); GetParallelPoints(tp1,tp2,tp4,tp3,Step); Line := TLine.Create(tp2.x,tp2.y,tp3.x,tp3.y,1,ord(psSolid),Color,0,0,mydsNormal,Owner.Owner); grp.AddToGrp(Line); //28.04.2011 grp.InFigures.Add(Line); Line := TLine.Create(tp4.x,tp4.y,tp1.x,tp1.y,1,ord(psSolid),Color,0,0,mydsNormal,Owner.Owner); grp.AddToGrp(Line); //28.04.2011 grp.InFigures.Add(Line); tp1 := MPoint(tp2,tp1,bStep/2); tp2 := MPoint(tp1,p2,bStep); GetParallelPoints(tp1,tp2,tp1,tp2,Step); GetParallelPoints(tp1,tp2,tp4,tp3,Step); Line := TLine.Create(tp2.x,tp2.y,tp3.x,tp3.y,1,ord(psSolid),Color,0,0,mydsNormal,Owner.Owner); grp.AddToGrp(Line); //28.04.2011 grp.InFigures.Add(Line); Line := TLine.Create(tp4.x,tp4.y,tp1.x,tp1.y,1,ord(psSolid),Color,0,0,mydsNormal,Owner.Owner); grp.AddToGrp(Line); //28.04.2011 grp.InFigures.Add(Line); end; Line := TLine.Create(p1.x,p1.y,p2.x,p2.y,1,ord(psSolid),Color,0,0,mydsNormal,Owner.Owner); grp.AddToGrp(Line); //28.04.2011 grp.InFigures.Add(Line); end; end else begin Line := TLine.Create(p1.x,p1.y,p2.x,p2.y,1,ord(psSolid),Color,0,0,mydsNormal,Owner.Owner); grp.AddToGrp(Line); //28.04.2011 grp.InFigures.Add(Line); end; done := maxfield1^ > (maxval1+(2*xStep)); if Style in [hsCross,hsDCross] then begin p3 := MovePoint(p3,dx2,dy2); p4 := MovePoint(p4,dx2,dy2); Line := TLine.Create(p3.x,p3.y,p4.x,p4.y,1,ord(psSolid),Color,0,0,mydsNormal,Owner.Owner); grp.AddToGrp(Line); //28.04.2011 grp.InFigures.Add(Line); done := done and (maxfield2^ > (maxval2+(2*xStep))); end; until done; end; procedure TFigureFill.BuildTexture; var xBmp: TBitmap; rect: TDoubleRect; w,h: Double; c,r,i,k,x,y: Integer; rt: Integer; begin xBmp := GetTextureBitmap(ord(TextureStyle)); TxtBmp := TBitmap.Create; rect := Owner.GetBoundRect; w := abs(rect.right-rect.left); h := abs(rect.bottom-rect.top); if TxtSize <= 1 then begin rt := 6; end else if TxtSize = 2 then begin rt := 4; end else if TxtSize >= 3 then begin rt := 3; end; TxtBmp.Width := Round(w*rt); TxtBmp.Height := Round(h*rt); c := (TxtBmp.Width div xBmp.Width)+1; r := (TxtBmp.Height div xBmp.Height)+1; for i := 0 to r-1 do begin for k := 0 to c-1 do begin x := k*(xbmp.Width); y := i*(xbmp.Height); TxtBmp.Canvas.Draw(x,y,xBmp); end; end; xBmp.Free; end; procedure TFigureFill.Clear; begin Empty := True; if assigned(grp) then begin grp.Free; grp := nil; end; if assigned(GradBmp) then begin GradBmp.Free; GradBmp := nil; end; if assigned(TxtBmp) then begin TxtBmp.Free; TxtBmp := nil; end; end; constructor TFigureFill.Create(AOwner:TFigure;FStep:Double;FType:TFillType;Data:Integer); begin inherited Create; Owner := AOwner; Step := FStep; TxtSize := Round(FStep); FillType := FType; Grp := nil; GradBmp := nil; //Tolik TxtBmp:= nil; // Color := AOwner.Brc; PenStyle := psSolid; PenWidth := 1; SetSubData(data); Empty := True; BackColor := clNone; end; destructor TFigureFill.Destroy; begin //Tolik if GradBmp <> nil then GradBmp.Free; if TxtBmp <> nil then TxtBmp.Free; // if GRP <> nil then Grp.Free; inherited Destroy; end; procedure TFigureFill.Draw(DEngine: TPCDrawEngine;isGrayed:Boolean); var Rect: TDoubleRect; p1,p2,p3,p4: TDoublePoint; begin if Empty then ReGenerate; if FillType = fsHatch then begin rect := Owner.GetBoundRect; if BackColor <> clNone then Dengine.FillRect(Rect,BackColor,ord(bsSolid)); if assigned(grp) then grp.draw(Dengine,isGrayed); end else if FillType = fsSolid then begin rect := Owner.GetBoundRect; // Tolik 03/09/2019 -- if GCadForm <> nil then begin if GCadForm.tbShowTransparency.Down then Dengine.FillRect(Rect,Color,ord(bsSolid), Owner.Transparency) else Dengine.FillRect(Rect,Color,ord(bsSolid), 0); end else Dengine.FillRect(Rect,Color,ord(bsSolid), 0); // Tolik 26/06/2017 {if GCadForm.tbShowTransparency.Down then Dengine.FillRect(Rect,Color,ord(bsSolid), Owner.Transparency) else Dengine.FillRect(Rect,Color,ord(bsSolid), 0);} // end else if FillType = fsGradient then begin rect := Owner.GetBoundRect; p1 := DoublePoint(rect.Left,rect.top); p2 := DoublePoint(rect.right,rect.top); p3 := DoublePoint(rect.right,rect.bottom); p4 := DoublePoint(rect.Left,rect.bottom); if assigned(GradBmp) then DEngine.DrawBitmap(p1,p2,p3,p4,clWhite,1,ord(psClear),False,GradBmp); end else if FillType = fsTexture then begin rect := Owner.GetBoundRect; p1 := DoublePoint(rect.Left,rect.top); p2 := DoublePoint(rect.right,rect.top); p3 := DoublePoint(rect.right,rect.bottom); p4 := DoublePoint(rect.Left,rect.bottom); if assigned(TxtBmp) then DEngine.DrawBitmap(p1,p2,p3,p4,clWhite,1,ord(psClear),False,TxtBmp); end; end; procedure TFigureFill.Move(dx, dy: Double); begin if assigned(grp) then begin grp.move(dx,dy); end; end; procedure TFigureFill.ReGenerate; begin if assigned(grp) then begin grp.Free; grp := nil; end; if assigned(GradBmp) then begin GradBmp.Free; GradBmp := nil; end; if assigned(TxtBmp) then begin TxtBmp.Free; TxtBmp := nil; end; Empty := True; if FillType in [fsNone,fsSolid] then begin Empty := False; exit; end; if FillType = fsHatch then begin Empty := False; BuildHatch; end else if FillType = fsGradient then begin Empty := False; BuildGradient; end else if FillType = fsTexture then begin Empty := False; BuildTexture; end; end; procedure TFigure.RefreshHatch; begin if assigned(Fill) then Fill.ReGenerate; end; procedure TFigureFill.Rotate(Angle: Double; cPoint: TDoublePoint); begin end; procedure TFigureFill.Scale(px, py: Double; rPoint: TDoublePoint); begin end; procedure TFigureFill.SetBackColor(BColor: TColor); begin if BackColor <> BColor then begin BackColor := BColor; if FillType = fsGradient then begin Clear; end; end; end; procedure TFigureFill.SetColor(FColor: TColor); begin if Color <> FColor then begin Color := FColor; if assigned(Grp) then Grp.ModifySelection(mmPenColor,Color); if assigned(Grp) then Grp.ModifySelection(mmBrushColor,Color); if FillType = fsGradient then begin Clear; end; end; end; procedure TFigureFill.SetHatchStep(FStep: Double); begin if (FillType = fsHatch) and (FStep <> Step) then Clear; Step := FStep; end; procedure TFigureFill.SetPen(pStyle: TPenStyle; pWidth: Integer); begin if (PenStyle <> pStyle) or (PenWidth <> pWidth) then begin PenStyle := PStyle; PenWidth := PWidth; if assigned(Grp) then Grp.ModifySelection(mmPenStyle,ord(PenStyle)); if assigned(Grp) then Grp.ModifySelection(mmPenWidth,ord(PenWidth)); end; end; procedure TFigureFill.SetStyle(FType: TFillType;Data:Integer); begin if FillType <> FType then begin FillType := FType; SetSubData(Data); Clear; end else if FillType = fsHatch then begin if HatchStyle <> THatchStyle(Data) then begin SetSubData(Data); Clear; end; end else if FillType = fsGradient then begin if GradStyle <> TGradStyle(Data) then begin SetSubData(Data); Clear; end; end else if FillType = fsTexture then begin if TextureStyle <> TTextureStyle(Data) then begin SetSubData(Data); Clear; end; end; end; procedure TFigure.DrawFill(DEngine: TPCDrawEngine; isGrayed: Boolean); var fType: TFillType; hStyle:THatchStyle; gStyle: TGradStyle; sData: Integer; abrc: integer; begin // if assigned(owner) and (TPCdrawing(Owner).NativeFill = false) and (NativeFill = False) and (brs <> ord(bsClear)) and (RegHandle <> 0) and (DrawStyle = mydsNormal) then begin if assigned(owner) and (TPCdrawing(Owner).NativeFill = false) and (NativeFill = False) and (brs <> ord(bsClear)) {and (RegHandle <> 0)} and (DrawStyle = mydsNormal) then begin if RegHandle = 0 then begin if RegObject <> nil then if RegObject.RegObjData <> nil then begin RegHandle := ExtCreateRegion(nil,RegObject.RegObjDataLength, RegObject.RegObjData^); end; end; if RegHandle <> 0 then begin FType := GetFillType(brs); SData := 0; if fType = fsHatch then begin if brs = bsExHatch then SData := ord(ExHatchStyle) else SData := ord(GetHatchStyle(brs)); end else if fType = fsGradient then begin if brs = bsExGrad then SData := ord(ExGradStyle) else SData := ord(GetGradStyle(brs)); end else if fType = fsTexture then begin if brs = bsExTexture then SData := ord(ExTextureStyle) else SData := ord(GetTextureStyle(brs)); end; if not assigned(Fill) then begin Fill := TFigureFill.Create(Self,ExHatchStepSize,fType,SData); end; Fill.SetStyle(fType,SData); //Tolik 02/11/2021 -- abrc := brc; if isGrayed then abrc := GCadForm.PCad.FGrayedColor; //Fill.SetColor(brc); Fill.SetColor(abrc); // Fill.SetHatchStep(ExHatchStepSize); Fill.SetTextSize(ExTextureSize); Fill.SetBackColor(ExFillBackColor); Fill.SetPen(psSolid,1); //Tolik if RegHandle = 0 then begin if RegObject <> nil then begin if RegObject.RegObjData <> nil then begin RegHandle := ExtCreateRegion(nil,RegObject.RegObjDataLength, RegObject.RegObjData^); if RegHandle <> 0 then begin if RegObject.RegObjData <> nil then begin GlobalFreePtr(RegObject.RegObjData); RegObject.RegObjData := nil; end; end; RegObject.Free; end; end; end; Dengine.ClipAnd(RegHandle); // Fill.Draw(Dengine,isGrayed); Dengine.ClipBack; GetRegObject; if RegObject <> nil then if TBrushStyle(brs) <> bsClear then RegObject.CheckPointByRects := true; DeleteObject(RegHandle); RegHandle := 0; end; end; end; function TFigure.GdiBrs: Integer; begin if (not assigned(owner)) or NativeFill or (TPCdrawing(Owner).NativeFill) then begin result := brs; end else begin result := ord(bsClear); end; end; procedure TFigure.ClearClipFigures; var a:Integer; Figure:TFigure; begin for a := 0 to ClipFigures.Count-1 do begin TFigure(ClipFigures[a]).InClip := False; end; ClipFigures.Clear; end; //!!!!!!!! // Вот тут хер его знает ... мож не сразу хендлы килять, а после отрисовки всех клипов...? пока хз... procedure TFigure.DrawClipFigures(DEngine: TPCDrawEngine; isGrayed: Boolean); var i: Integer; begin { if (ClipFigures.Count > 0) and (RegHandle <> 0) then begin For i := 0 to ClipFigures.Count - 1 do begin if TPowercad(Owner).Figures.IndexOf(ClipFigures[i]) = -1 then begin end else begin Dengine.Clip(RegHandle); if TFigure(ClipFigures[i]) is TBmpObject then begin //TBmpObject(ClipFigures[i]).ClpRgn := RegHandle; end; TFigure(ClipFigures[i]).Draw(Dengine,isGrayed); Dengine.Clip(0); end; end; end; } if (ClipFigures.Count > 0) then begin if RegHandle = 0 then begin if RegObject <> nil then if RegObject.RegObjData <> nil then begin RegHandle := ExtCreateRegion(nil, RegObject.RegObjDataLength, RegObject.RegObjData^); end; end; if RegHandle <> 0 then begin For i := 0 to ClipFigures.Count - 1 do begin if TPowercad(Owner).Figures.IndexOf(ClipFigures[i]) = -1 then begin end else begin Dengine.Clip(RegHandle); if TFigure(ClipFigures[i]) is TBmpObject then begin //TBmpObject(ClipFigures[i]).ClpRgn := RegHandle; end; TFigure(ClipFigures[i]).Draw(Dengine,isGrayed); Dengine.Clip(0); end; end; GetRegObject; if TBrushStyle(brs) <> bsClear then RegObject.CheckPointByRects := True else RegObject.CheckPointByRects := False; DeleteObject(Reghandle); RegHandle := 0; end; end; end; procedure TFigure.MoveClipFigures(deltax, deltaY: Double); var i:Integer; begin For i := 0 to ClipFigures.Count-1 do TFigure(ClipFigures[i]).Move(deltaX,deltaY); end; function TFigure.NeedRegion: Boolean; begin result := (regHandle = 0) and (DrawStyle = mydsNormal) and (NativeFill = False) and assigned(owner) and (TPCdrawing(Owner).NativeFill = false) and ((ClipFigures.Count > 0) or (brs <> ord(bsClear))); end; procedure TFigureFill.SetSubData(Data: Integer); begin if FillType = fsHatch then begin HatchStyle := THatchStyle(Data); end else if FillType = fsGradient then begin GradStyle := TGradStyle(Data); end else if FillType = fsTexture then begin TexturesTYLE := TTextureStyle(Data); end; end; procedure TFigure.SetGradient(GStyle: TGradStyle; ForeColor, BackColor: TColor); begin brs := bsExGrad; ExGradStyle := GStyle; brc := ForeColor; ExFillbackColor := BackColor; end; procedure TFigure.SetHatch(HStyle: THatchStyle; ForeColor, BackColor: TColor; StepSize: Double); begin brs := bsExHatch; ExHatchStyle := HStyle; brc := ForeColor; ExFillbackColor := BackColor; ExHatchStepSize := StepSize; end; procedure TFigure.SetTexture(TStyle: TTextureStyle; TexSize: Integer); begin brs := bsExTexture; ExTextureStyle := TStyle; ExTextureSize := TexSize; end; procedure TFigureFill.SetTextSize(TxSize: Integer); begin if (FillType = fsTexture) and (TxSize <> TxtSize) then Clear; TxtSize := TxSize; end; procedure TArc.Scale(percentx, percenty: Double; rPoint: TDoublePoint); var p1,p2:TDoublePoint; cp: TDoublePOint; Begin // cp := ap1; Inherited; // p1 := DoublePoint(cp.x+Alen,cp.y); // p2 := DoublePoint(cp.x,cp.y+Blen); // p1 := RotatePoint(cp,p1,Angle); // p2 := RotatePoint(cp,p2,Angle); // p1 := ScalePoint(rPoint,p1,percentx,percenty); // p2 := ScalePoint(rPoint,p2,percentx,percenty); // ALen := GetLineLenght(ap1,p1); // Blen := GetLineLenght(ap1,p2); end; { TPrintRect } class function TPrintRect.CreateFromShadow(aOwner: TComponent; LHandle: Integer; Shadow: TFigure): TFigure; begin Result := nil; TPCDrawing(aOwner).Settool(toSelect,'',0); {cad := TPCDrawing(aOwner); Result := TRectangle.create(Shadow.ap1.x,Shadow.ap1.y, Shadow.ap3.x,Shadow.ap3.y, cad.DefaultPenWidth, ord(cad.DefaultPenStyle), cad.DefaultPenColor, ord(cad.DefaultBrushStyle), cad.DefaultBrushColor, LHandle, mydsNormal,aOwner);} if Shadow.ap1.x < Shadow.ap3.x then begin if Shadow.ap1.y < Shadow.ap3.y then TPCDrawing(aOwner).PrintRectPreview(DoubleRect(Shadow.ap1.x, Shadow.ap1.y, Shadow.ap3.x, Shadow.ap3.y)) else TPCDrawing(aOwner).PrintRectPreview(DoubleRect(Shadow.ap1.x, Shadow.ap3.y, Shadow.ap3.x, Shadow.ap1.y)); end else begin if Shadow.ap1.y < Shadow.ap3.y then TPCDrawing(aOwner).PrintRectPreview(DoubleRect(Shadow.ap3.x, Shadow.ap1.y, Shadow.ap1.x, Shadow.ap3.y)) else TPCDrawing(aOwner).PrintRectPreview(DoubleRect(Shadow.ap3.x, Shadow.ap3.y, Shadow.ap1.x, Shadow.ap1.y)); end; end; {procedure TFigure.getboundsWithoutGrpSize(var figMaxX, figMaxY, figMinX, figMinY: Double); begin end; } initialization plps0 := ord(psCorner); plps1 := ord(psCurve); plps2 := ord(psCurveCorner); {$ifdef demo} if not delphiloaded then application.terminate; {$endif demo} ClassIndexes := TStringList.Create; ClassIndexes.Sorted := true; ClassIndexes.AddObject('TOrthoLine', TObject(01)); ClassIndexes.AddObject('TConnectorObject', TObject(02)); ClassIndexes.AddObject('TTextMod', TObject(03)); ClassIndexes.AddObject('TFigureGrpMod', TObject(04)); ClassIndexes.AddObject('TFigureGrpNotMod', TObject(05)); ClassIndexes.AddObject('TFrame', TObject(06)); ClassIndexes.AddObject('TSCSHDimLine', TObject(07)); ClassIndexes.AddObject('TSCSVDimLine', TObject(08)); ClassIndexes.AddObject('TRichTextMod', TObject(09)); ClassIndexes.AddObject('TCabinet', TObject(10)); ClassIndexes.AddObject('TCabinetExt', TObject(11)); ClassIndexes.AddObject('TCabinetNumber', TObject(12)); ClassIndexes.AddObject('TPlanObject', TObject(13)); ClassIndexes.AddObject('TPlanConnector', TObject(14)); ClassIndexes.AddObject('TPlanTrace', TObject(15)); ClassIndexes.AddObject('TCadNorms', TObject(16)); ClassIndexes.AddObject('TSCSFigureGrp', TObject(17)); ClassIndexes.AddObject('THouse', TObject(18)); ClassIndexes.AddObject('TApproach', TObject(19)); ClassIndexes.AddObject('TFigureGrp', TObject(20)); finalization ClassIndexes.Free; end.