unit PCDrawing; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, ExtCtrls, PCPanel, DrawObjects,PCTypesUtils,clipbrd,Printers, DrawEngine,PCDrawBox,FileCtrl,PrvForm,GUiStrings, Math //02.10.2013 ,psAPI, U_Common_Classes; const //prnDivIndent = 5; //28.11.2011 2; prnReservTiling = 2; //06.12.2011 type TlistMod = class(TList) public function RemoveItem(Item: Pointer): Integer; Destructor Destroy;override; end; TInsertReason = (irCreate,irPaste,irLoad); TRulerMode = (rmPage,rmWorld); TMapRescale = (rsNever,rsAlways,rsAskUser); TMoveEvent = procedure (Sender: Tobject; Figure: TFigure; dx,dy: double) of Object; TSnapEvent = Function (Sender: TObject; SnapFigure: TFigure; var x,y: double):Boolean of Object; TFigureEvent = Procedure (Sender: TObject; Figure: TFigure; DeltaX: double = -999999; DeltaY: double = -999999) of Object; TFigureDeleteEvent = Procedure (Sender:TObject; Figure:TFigure; var CanDelete:Boolean) of Object; TInsertEvent = Procedure (Sender:TObject; Reason:TInsertReason) of Object; TBeforeInsertEvent = Procedure (Sender:TObject; Figure:TFigure;var InsertState:TInsertState) of Object; TUserDrawEvent = procedure (Sender:TObject; CName:String;DC,Figure:Integer;isGrayed:Boolean; var drawed:Boolean) of Object; TUserHitEvent = procedure (Sender:TObject; CName:String;Figure:Integer; x,y: Double; var Test,Tested:Boolean) of Object; TOnCollectFaces = Procedure (Sender:TObject; var Faces:TList) of Object; TOnCollectFigureFaces = Procedure (Sender:TObject;Figure:TFigure; var Faces:TList) of Object; TOnCustomUndoEvent = Procedure (Sender:TObject; isRedo:Boolean) of Object; TBeforeMoveAllEvent = Procedure(Sender:TObject;var dx,dy:Double) of Object; TAfterMoveAllEvent = Procedure(Sender:TObject;dx,dy:Double) of Object; TLayerInitData = Procedure(Sender:TObject;Layer:TLayer) of Object; TLayerSaveData = Procedure(Sender:TObject;Layer:TLayer;Stream:TStream) of Object; TLayerLoadData = Procedure(Sender:TObject;Layer:TLayer;Stream:TStream) of Object; TCalibrateLayer = Procedure(Sender:TObject;LayerNbr:Integer;dist:Double;cUnit:Byte) of Object; TGetFigureEvent = procedure (Sender: Tobject; var Figure: TFigure; x, y: double) of Object; //#From Oleg# //04.10.2010 TGetModPointEvent = procedure (Sender: Tobject; var ModPoint: TModPoint; x, y: double) of Object; //#From Oleg# //23.08.2011 TCheckPrnWithOffsetEvent = function(Sender: Tobject): Boolean of object; TPenBrush = Record isPen: Bool; index: Cardinal; PenLog: TLOGPEN; BrushLog: TLOGBRUSH; end; TSavedDc = Record Index: Integer; Pen: Integer; Brush:Integer; End; (*vbclassexport begin*) TPCDrawing = class(TPCDrawBox) private { Private declarations } FOnSelChange: TNotifyEvent; FOnObjectInserted: TInsertEvent; FOnFigureMoved: TMoveEvent; FOnFigureDel: TFigureDeleteEvent; FOnAfterFigureDel: TNotifyEvent; FOnBeforeUndo: TNotifyEvent; FOnAfterUndo: TNotifyEvent; FSnapToFigure: TSnapEvent; SOnPaint: TNotifyEvent; FOnMapScale:TNotifyEvent; FOnUserDraw: TuserDrawEvent; FonUserHitTest:TUserHitEvent; FFigureModify: TFigureEvent; FFigureSelect:TFigureEvent; FSelection : TList; FKeyCommands: Boolean; FMapScale : Double; FRulerMode: TRulerMode; fDefPenColor : TColor; fDefBrsColor : TColor; fDefPenstyle : TPenStyle; fDefPenWidth : integer; fDefBrsStyle : TBrushStyle; fDefRowStyle : TRowStyle; fDeftextHeight: Double; fDefTextRatio: Double; fDefPLineClosed: Boolean; fDefArcStyle: TArcStyle; prDpm,bmpDpm,dcDpm,prPageHeight: Extended; prBmpRect: TDoubleRect; dcCoordx,dcCoordy: integer; TileX,TileY,prWorkHeight,MCopyDelta: Double; FAutoSelect: Boolean; FRescale: TMapRescale; CPBlockNames:TStringList; CPLists: TList; Freed: TList; FPictureFolder: String; FPenPatList: Tlist; FSavePrev: Boolean; prevForm: TFrmPrv; FRealScale: Boolean; FMetricMode:Integer; FAngularMode:Integer; FOnBeforeClear:TNotifyEvent; FOnCollectFaces:TONCollectFaces; FOnCollectFigureFaces:TOnCollectFigureFaces; FOnObjectSaved: TFigureEvent; FSelChangeLocked: Boolean; FZoomRect: Boolean; fRangeCheck: Boolean; fAutoTile: Boolean; FFigureGuides: Boolean; FOnCustomUndo: TOnCustomUndoEvent; FOnUndoRecord: TNotifyEvent; FOnBeforeModify: TFigureEvent; FOnBeforeMove: TFigureEvent; FBeforeMoveAll: TBeforeMoveAllEvent; FAfterMoveAll: TAfterMoveAllEvent; FLayerInitData: TLayerInitData; FLayerLoadData: TLayerLoadData; FLayerSaveData: TLayerSaveData; FCalibrateLayer: TCalibrateLayer; FCustomStreamUpdate: TNotifyEvent; FCustomStreamLoaded: TNotifyEvent; FWMFPrint: Boolean; FNativeFill: Boolean; DPIX: double; DPIY: double; OFFX: double; OFFY: double; OFFMMX: double; OFFMMY: double; Procedure SetAutoSelect(Value:Boolean); Function GetPenPatCount:Integer; Function GetBrushPatCount:Integer; Function GetPenPattern(Index:Integer):TPattern; Procedure SetRulerMode(Value:TRulerMode); procedure SetZoomRect(const Value: Boolean); procedure SetRangeCheck(const Value: Boolean); procedure SetFigureGuides(const Value: Boolean); function GetRecordUndo: Boolean; protected { Protected declarations } //MacroEngine: THalComp; // Tolik 24/12/2019 -- //ModPoints: TList; ModPoints: TMyList; // FUndoList: TList; FUndoIdx : Integer; FRecordUndo : Boolean; FUndoCount: Integer; FBeforeFigureInsert:TBeforeInsertEvent; FBlinkPaused: Boolean; FOnFigureEdit:TfigureEvent; FGetFigureToSelect: TGetFigureEvent; //#From Oleg# //04.10.2010 FGetModPointToSelect: TGetModPointEvent; //#From Oleg# //23.08.2011 FCheckPrnWithOffset: TCheckPrnWithOffsetEvent; //29.11.2011 FMultiDeselectCount: Integer; //02.04.2012 - Количество вызовов BeginMultiDeselect; FModPointsStartIdx: Integer; // позиция, с которой делать IndexOf в ModPoints в режиме Multideselect FUpdateCount: Integer; //06.08.2012 - Disable update Counter FUpdateCountAdd: Integer; // Счетчик количества вызовов для CADBeginUpdate. Если FUpdateCountAdd <0, то процедура // CadEndupdate не выполняться и счетчик количества пауз процессов не изменится Procedure SetActiveLayer(value: integer);override; Procedure CancelActions;virtual; Procedure SetCursor(cr:TCursor);override; Function GetLayerCount:integer;override; Function GetFigureCount:integer; Function GetSelCount:integer; Procedure SetMapScale(value: double); Procedure DoSurfacePaint(Sender: TObject);override; Procedure setPenColor(value: TColor); Procedure setBrushColor(value: TColor); Procedure setPenWidth(value: integer); Procedure setPenStyle(value: TPenStyle); Procedure setBrushStyle(value: TBrushStyle); Procedure setRowStyle(value: TRowStyle); Procedure setTextHeight(value: Double); Procedure setTextRatio(value: Double); Procedure SetPLineClosed(value:Boolean); Procedure SetArcStyle(value:TArcStyle); Procedure prDeConvertXY(var X,Y,Z: Double); Procedure prDeConvertDim(var Dim: Double); Procedure prConvertXY(var X,Y,Z: Double); Procedure prConvertDim(var Dim: Double); Procedure dcConvertXY(var X,Y,Z: Double); Procedure dcConvertXYTile(var X,Y,Z: Double); //25.11.2011 Procedure dcConvertDim(var Dim: Double); Procedure dcDeConvertDim(var Dim: Double); Procedure blkConvertXY(var X,Y,Z: Double); Procedure blkConvertDim(var Dim: Double); Procedure prTileConvertXY(var X,Y,Z: Double); Procedure bmpConvertXY(var X,Y,Z: Double); Procedure bmpConvertDim(var Dim: Double); Procedure ROChanged;override; Procedure GetDocumentProperties(Stream:TStream); Procedure SetDocumentProperties(Stream:TStream); Procedure GetLayerData(Stream:TStream); Procedure SetLayerData(Stream:TStream); Procedure GetGuidesData(Stream: TStream); Procedure SetGuidesData(Stream: TStream); Procedure GetFiguresData(Stream:TStream); Procedure SetFiguresData(Stream:TStream); Procedure GetJoinsData(Stream:TStream); Procedure SetJoinsData(Stream:TStream); Procedure SetDocumentPropertyInt(xCode:Byte; Value:Integer); Procedure SetDocumentPropertyStr(xCode:Byte; Value:String); Procedure SetDocumentPropertyDbl(xCode:Byte; Value:Double); Procedure SetDocumentPropertyBin(xCode:Byte; Value:pByte; xSize:integer); Procedure RecordInsertUndo(xFig:Tfigure; aTag:Integer=0); Procedure AddFigureToModifyUndo(xAction: TUndoAction;xFig:TFigure); Function SnapToFigures(var x,y: double):Boolean;override; //22.08.2012 Procedure ResetRegions;override; Procedure KillUndoAction(xAction:TUndoAction);virtual; Procedure PrintPage; Procedure PrintPageAsWmf; Procedure TestPrinter; Procedure ModifySelection(mm : TModifyMode; value: integer); Procedure ModifyTextandFont(mm: TModifyMode; valueI:Double; valueS: string; valueSt: TFontStyles;ValueB:Boolean); //Procedure SetInterfaceHandle;virtual; //Procedure NilInterfaceHandle;virtual; Function GetZAvg(dRect:TDoubleRect):Double;override; Procedure GetIsometricBounds(var MinX,MinY,MaxX,MaxY: Double);override; Procedure ExitClear; function PrepareBitmap(aPdfSave: Boolean = False): TBitmap; //29.02.2012 public { Public declarations } PictureFrame: Boolean; DrawSurface: Boolean; CustomStream : TStream; FAnySelected : Boolean; CurrentX,CurrentY: Double; CurrentShift: TShiftState; Layers: TList; // Tolik 13/12/2019-- //Figures: TList; Figures: TMyObjectList; // Faces: TList; BrushList: TList; TraceFigure : TFigure; ClickIndex : integer; evBrushStyle : TEventEngine; evPenStyle : TEventEngine; evPenWidth : TEventEngine; evRowStyle : TEventEngine; evPenColor : TEventEngine; evBrushColor : TEventEngine; evTextColor : TEventEngine; evTextFont : TEventEngine; evTextSize : TEventEngine; evTextCharset: TEventEngine; evTextRatio : TEventEngine; evTextBold : TEventEngine; evTextItalic : TEventEngine; evTextUnderline: TEventEngine; evTextStrike : TEventEngine; evToolIndex : TEventEngine; evPLineClosed : TEventEngine; evTransparent : TEventEngine; evClipped : TEventEngine; evArcStyle : TEventEngine; evArcSel : TEventEngine; evBmpSel : TEventEngine; evLineSel : TEventEngine; evPLineSel : TEventEngine; evGroupSel : TEventEngine; evAnySel : TEventEngine; evBounded : TEventEngine; evRulerMode : TEventEngine; SlcBitmapCnt : Integer; SlcLineCnt : Integer; SlcPlineCnt : Integer; SlcArcCnt : Integer; SlcCircleCnt : Integer; SlcEllipseCnt : Integer; SlcVertexCnt : Integer; SlcGroupCnt : Integer; SlcRectangleCnt: Integer; SlcDimCnt : Integer; FBlinkTimer : TTimer; PlotHeight : Double; PlotCopy : Integer; FIsSelectingFig: Boolean; prnDivOverlay: Double; //01.12.2011 prnDivIndentX, prnDivIndentY: Double; //29.11.2011 prnScale: Double; //05.12.2011 ResetRemoveSelection: Boolean; //Tolik -- 24/10/2017 -- FLastFigureId: integer; FLastFigureIdOnLoad: integer; FBreakedOnQuota: Boolean; // 16/11/20107 Tolik -- флажок для индикации того, что лист поднят не полностью по причине превышения квоты // (или GDI или USER Objects), т.е. практически "битый" лист -- isDrawingFigures: Boolean; // флаг, что идет отрисовка фигур када // resAutoCreate: boolean; NotExistInCatalog: byte; Procedure SyncEnv;override; property UpdateCount: Integer read FUpdateCount; Procedure InsertUndoAction(xAction:TUndoAction);virtual; // **MY** function SaveSCSFiguresToFile(FileName: string): Boolean; function SavePlanFiguresToFile(FileName: string): Boolean; function SaveElSchemeFiguresToFile(FileName: string): Boolean; // Tolik -- 12/02/2021 Procedure LoadSCSFiguresFromFile(FileName: string); Procedure SetSelectionHatch(HStyle:THatchStyle;ForeColor,BackColor:TColor;StepSize:Double);(*vb*) Procedure SetSelectionGradient(GStyle:TGradStyle;ForeColor,BackColor:TColor);(*vb*) Procedure SetSelectionTexture(TStyle:TTextureStyle;TexSize:Integer);(*vb*) Procedure DoSelChange;virtual; Function NewLayer(LayerName: string):integer;(*vb*) Function DeleteLayer(LayerName: string): boolean;(*vb*) Function DeleteLayerWithNbr(LayerNbr: integer): boolean;(*vb*) Procedure DeleteAllUserLayers;(*vb*) Procedure UnDo;(*vb*) Procedure ReDo;(*vb*) Procedure ClearUndoList;(*vb*) Procedure ShowLayer(LayerNbr:integer);(*vb*) Procedure HideLayer(LayerNbr:integer);(*vb*) Procedure HideAllLayers;(*vb*) Procedure GrayLayer(LayerNbr:integer);(*vb*) Procedure ExGrayLayer(LayerNbr:integer);(*vb*) Procedure ExHideLayer(LayerNbr:integer);(*vb*) Procedure ShowAllLayers;(*vb*) Procedure MergeAllLayers;(*vb*) Procedure MergeVisibleLayers;(*vb*) Function GetLayerInfo(LayerNbr: integer): TLayerInfo; Function GetLayer(LayerNbr: integer):TLayer; Function GetLayerName(LayerNbr: integer): String;(*vb*) Function GetLayerHandle(LayerNbr: integer): Integer;(*vb*) Function GetLayerVisible(LayerNbr: integer): Boolean;(*vb*) Function GetLayerGrayed(LayerNbr: integer): Boolean;(*vb*) Function GetSelectedHandle(index:Integer):TFigHandle;(*vb*) // all figure classes Function FigureGetHandle(FigureIndex:Integer):Integer;(*vb*) Function FigureGetName(FigureHandle:Integer):String;(*vb*) Function FigureGetClass(FigureHandle:Integer):String;(*vb*) Function FigureGetPointCount(FigureHandle:Integer):Integer;(*vb*) Function FigureGetPoint(FigureHandle,pIndex:Integer):TDoublePoint;(*vb*) Function FigureGetDCPoint(FigureHandle,pIndex:Integer):TDoublePoint;(*vb*) Function FigureGetCenter(FigureHandle:Integer):TDoublePoint;(*vb*) Function FigureGetRect(FigureHandle:Integer):TDoubleRect;(*vb*) Function FigureGetRadius(FigureHandle:Integer):Double;(*vb*) Function FigureGetFontName(FigureHandle:Integer):String;(*vb*) Function FigureGetFontBold(FigureHandle:Integer):Boolean;(*vb*) Function FigureGetFontItalic(FigureHandle:Integer):Boolean;(*vb*) Function FigureGetFontUnderline(FigureHandle:Integer):Boolean;(*vb*) Function FigureGetFontStrike(FigureHandle:Integer):Boolean;(*vb*) Function FigureGetFontSize(FigureHandle:Integer):Double;(*vb*) Function FigureGetFontCharset(FigureHandle:Integer):Integer;(*vb*) Function FigureGetFontColor(FigureHandle:Integer):TColor;(*vb*) Function FigureGetPenColor(FigureHandle:Integer):TColor;(*vb*) Function FigureGetBrushColor(FigureHandle:Integer):TColor;(*vb*) Function FigureGetPenStyle(FigureHandle:Integer):TPenStyle;(*vb*) Function FigureGetBrushStyle(FigureHandle:Integer):TBrushStyle;(*vb*) Function FigureGetRowStyle(FigureHandle:Integer):TRowStyle;(*vb*) Function FigureGetPenWidth(FigureHandle:Integer):Integer;(*vb*) Function FigureGetInfo(FigureHandle:Integer):String;(*vb*) Function FigureGetAngle(FigureHandle:Integer):Double;(*vb*) Function FigureGetLayerHandle(FigureHandle:Integer):Integer;(*vb*) Function FigureGetDiagonal(FigureHandle:Integer):Boolean;(*vb*) Function FigureGetLockMove(FigureHandle:Integer):Boolean;(*vb*) Function FigureGetLockModify(FigureHandle:Integer):Boolean;(*vb*) Function FigureGetSelected(FigureHandle:Integer):Boolean;(*vb*) Function FigureTestPoint(FigureHandle:Integer;TestPoint:TDoublePoint):Boolean;(*vb*) Function FigureTestRect(FigureHandle:Integer;TestRect:TDoubleRect):Boolean;(*vb*) Function FigureGetRgnHandle(FigureHandle:Integer):Integer;(*vb*) Procedure FigureSelect(FigureHandle:Integer);(*vb*) Procedure FigureSelectAsRotate(FigureHandle:Integer);(*vb*) Procedure FigureDeSelect(FigureHandle:Integer);(*vb*) Procedure FigureEdit(FigureHandle:Integer);(*vb*) Procedure FigureMove(FigureHandle:Integer;deltax,deltay: Double);(*vb*) Procedure FigureRotate(FigureHandle:Integer; Angle:Double);(*vb*) Procedure FigureRotateByPoint(FigureHandle:Integer; Angle:Double; cPoint:TDoublePoint);(*vb*) Procedure FigureMirror(FigureHandle:Integer; Point1,Point2: TDoublePoint);(*vb*) Procedure FigureScale(FigureHandle:Integer; px,py: Double);(*vb*) Procedure FigureScaleByPoint(FigureHandle:Integer; px,py: Double; rPoint: TDoublepoint);(*vb*) Procedure FigureSetFontName(FigureHandle:Integer;value:String);(*vb*) Procedure FigureSetFontBold(FigureHandle:Integer;value:Boolean);(*vb*) Procedure FigureSetFontItalic(FigureHandle:Integer;value:Boolean);(*vb*) Procedure FigureSetFontUnderline(FigureHandle:Integer;value:Boolean);(*vb*) Procedure FigureSetFontStrike(FigureHandle:Integer;value:Boolean);(*vb*) Procedure FigureSetFontSize(FigureHandle:Integer;value:Double);(*vb*) Procedure FigureSetFontCharset(FigureHandle:Integer;value:Integer);(*vb*) Procedure FigureSetFontColor(FigureHandle:Integer;value:TColor);(*vb*) Procedure FigureSetPenColor(FigureHandle:Integer;value:TColor);(*vb*) Procedure FigureSetBrushColor(FigureHandle:Integer;value:TColor);(*vb*) Procedure FigureSetPenStyle(FigureHandle:Integer;value:TPenStyle);(*vb*) Procedure FigureSetBrushStyle(FigureHandle:Integer;value:TBrushStyle);(*vb*) Procedure FigureSetRowStyle(FigureHandle:Integer;value:TRowStyle);(*vb*) Procedure FigureSetPenWidth(FigureHandle:Integer;value:Integer);(*vb*) Procedure FigureSetPoint(FigureHandle,pIndex:Integer;fPoint:TDoublePoint);(*vb*) Procedure FigureSetInfo(FigureHandle:Integer;value:String);(*vb*) Procedure FigureSetAngle(FigureHandle:Integer;value:Double);(*vb*) Procedure FigureSetLayerHandle(FigureHandle:Integer;value:Integer);(*vb*) Procedure FigureSetDiagonal(FigureHandle:Integer;value:Boolean);(*vb*) Procedure FigureSetLockMove(FigureHandle:Integer;value:Boolean);(*vb*) Procedure FigureSetLockModify(FigureHandle:Integer;value:Boolean);(*vb*) Procedure FigureSetRgnHandle(FigureHandle,Rgn:Integer);(*vb*) Function GetDCPoint(p:TDoublePoint):TDoublePoint;(*vb*) Function GetDCLen(l:Double):Integer;(*vb*) //block - figure grp Function FigureGrpGetFigureCount(FigureHandle:Integer):Integer;(*vb*) Function FigureGrpGetFigureHandle(FigureHandle,fIndex:Integer):Integer;(*vb*) Function FigureGrpGetCombined(FigureHandle:Integer):Boolean;(*vb*) Procedure FigureGrpSetCombined(FigureHandle:Integer;Value:Boolean);(*vb*) Procedure FigureGrpUngroup(FigureHandle:Integer);(*vb*) // block Function FigureBlockGetBlockname(FigureHandle:Integer):String;(*vb*) // line - polyline Function FigureGetJoin1(FigureHandle:Integer):Integer;(*vb*) Function FigureGetJoin2(FigureHandle:Integer):Integer;(*vb*) Procedure FigureSetJoin1(FigureHandle,JHandle:Integer);(*vb*) Procedure FigureSetJoin2(FigureHandle,JHandle:Integer);(*vb*) // polyline Function FigureGetClosed(FigureHandle:Integer):Boolean;(*vb*) Procedure FigureSetClosed(FigureHandle:Integer; Closed:Boolean);(*vb*) Function FigureGetControlPoint(FigureHandle,SegmentIndex,pIndex:Integer):TDoublePoint;(*vb*) Procedure FigureSetControlPoints(FigureHandle,SegmentIndex:Integer;cPoint1,cPoint2:TDoublePoint);(*vb*) Function FigureGetSegmentType(FigureHandle,SegmentIndex:Integer):TSegmentType;(*vb*) Procedure FigureSetSegmentType(FigureHandle,SegmentIndex:Integer;SegType:TSegmentType);(*vb*) Procedure FigureInvertArcSegment(FigureHandle,SegmentIndex:Integer);(*vb*) Procedure FigureConvertPLBezier(FigureHandle:Integer);(*vb*) Procedure FigureConvertPLPolyline(FigureHandle:Integer);(*vb*) // ellipse Function FigureGetElpALen(FigureHandle:Integer):Double;(*vb*) Function FigureGetElpBLen(FigureHandle:Integer):Double;(*vb*) //arc - elparc Function FigureGetArcStyle(FigureHandle:Integer):TArcStyle;(*vb*) Procedure FigureSetArcStyle(FigureHandle:Integer;aStyle:TArcStyle);(*vb*) Procedure FigureInvertArc(FigureHandle:Integer);(*vb*) Function FigureGetArcSAngle(FigureHandle:Integer):Double;(*vb*) Function FigureGetArcFAngle(FigureHandle:Integer):Double;(*vb*) Procedure FigureSetArcAngles(FigureHandle:Integer; SAngle,FAngle:Double);(*vb*) // rich text Function FigureGetRichText(FigureHandle:Integer):String;(*vb*) Procedure FigureSetRichText(FigureHandle:Integer; rText:String);(*vb*) // bpm wmf Function FigureGetPictureName(FigureHandle:Integer):String;(*vb*) // Bmp Object Function FigureGetTransparent(FigureHandle:Integer):Boolean;(*vb*) Procedure FigureSetTransparent(FigureHandle:Integer;Value:Boolean);(*vb*) Procedure FigureFlipHorz(FigureHandle:Integer);(*vb*) Procedure FigureFlipVert(FigureHandle:Integer);(*vb*) Procedure FigureSkewBitmap(FigureHandle:Integer);(*vb*) Procedure FigureSaveBitmapToFile(FigureHandle:Integer;Fname:String);(*vb*) Procedure FigureLoadBitmapFromFile(FigureHandle:Integer;Fname:String);(*vb*) // Text Function FigureGetText(FigureHandle:Integer):String;(*vb*) Procedure FigureSetText(FigureHandle:Integer;Value:String);(*vb*) Function DrawUserFigureEvent(Cname:String;DC,Handle:Integer;isGrayed:Boolean):Boolean;(*vb*) Function PointInUserFigureEvent(Cname:String;Handle:Integer;x,y:Double; var Test:Boolean):Boolean;(*vb*) Constructor Create(AOwner:TComponent);override; Procedure OnBlinkTimer(Sender:TObject); Procedure GotFocus(Sender:TObject);override; Destructor Destroy;override; procedure Draw;(*vb*) procedure DrawFigures(OnlyVisibles:Boolean);overload; procedure TestListFigures(aCheckOverlap: Boolean); procedure DrawFigures;overload;(*vb*) Procedure DrawSubstrateFigures(OnlyVisibles:Boolean); overload;(*vb*) Procedure DrawDetail; Procedure DrawFaces; Procedure ClearFaces; Procedure CollectFaces;override; function GetFacadeArea(AResInM: Boolean=true): Double; //07.12.2010 Вернет площадь фасадов Procedure DrawSelectedFigures;(*vb*) Procedure DrawSelectionPoints;(*vb*) Procedure DrawFigureGuides;(*vb*) procedure SelectAll(LayerNbr : integer);(*vb*) Procedure DeselectAll(LayerNbr : integer);(*vb*) Procedure InvertSelection;(*vb*) Function GroupSelection:TFigHandle;(*vb*) procedure UngroupSelection;(*vb*) procedure OrderSelection(Dest : TOrderStyle);(*vb*) // my procedure OrderFigureToFront(aFigure: TFigure); procedure OrderFigureToBack(aFigure: TFigure); procedure RemoveSelection;(*vb*) Procedure RotateSelectionCenter(Angle: Double);(*vb*) Procedure RotateSelection(Angle: Double; rPoint: TDoublePoint);overload;(*vb*) Procedure MirrorSelection(Point1,Point2: TDoublePoint; Dupl: boolean);overload;(*vb*) Procedure KnifeSelection(Point1,Point2: TDoublePoint);(*vb*) Procedure CreateDimLinesOfSelection;(*vb*) Procedure ClearDimLinesOfSelection;(*vb*) Procedure InterBreakSelection;(*vb*) Procedure LockSelectionToMove(Locked:Boolean);(*vb*) Procedure LockSelectionToModify(Locked:Boolean);(*vb*) Procedure InvertArcsOfSelection;(*vb*) Procedure ArrangeArcStyleOfSelection(Value: TArcStyle);(*vb*) Procedure CloseSelectedPolyline;(*vb*) Procedure OpenSelectedPolyline;(*vb*) Procedure SimplfySelectedPolyline;(*vb*) Procedure NameSelection;(*vb*) Procedure ConvertPLToBezier;(*vb*) Procedure ConvertPLToPolyline;(*vb*) Procedure FlipImagesOfSelection(FlipMode: TFlipMode);(*vb*) Procedure setTransparentOfSelection(Transparent:Boolean);(*vb*) Procedure ScaleSelection(percentX,percentY: Double; rPoint: TDoublePoint);overload;(*vb*) Procedure ScaleDrawing(percentx,percenty:Double);(*vb*) Procedure ModifyFontName(value:String);(*vb*) Procedure ModifyFontBold(value:Boolean);(*vb*) Procedure ModifyFontItalic(value:Boolean);(*vb*) Procedure ModifyFontUnderline(value:Boolean);(*vb*) Procedure ModifyFontStrike(value:Boolean);(*vb*) Procedure ModifyFontSize(value:Double);(*vb*) Procedure ModifyFontCharset(value:Integer);(*vb*) Procedure ModifyFontColor(value:TColor);(*vb*) Procedure ModifyPenColor(value:TColor);(*vb*) Procedure ModifyBrushColor(value:TColor);(*vb*) Procedure ModifyPenStyle(value:TPenStyle);(*vb*) Procedure ModifyBrushStyle(value:TBrushStyle);(*vb*) Procedure ModifyRowStyle(value:TRowStyle);(*vb*) Procedure ModifyPenWidth(value:Integer);(*vb*) Function IsTextSelected:Boolean;(*vb*) Function GetSelectionRect: TDoubleRect;override;(*vb*) Function GetDrawingRect:TDoubleRect;override;(*vb*) function GetFigureListRect(AFigures: TList): TDoubleRect; //04.08.2011 Procedure GetSelectionBoundS(var MaxX,MaxY,MinX,MinY: Double);(*vb*) Procedure GetDrawingBounds(var MaxX,MaxY,MinX,MinY: Double);(*vb*) Procedure AlignSelection(HorzAlign: THorzAligns; VertAlign: TVertAligns); procedure Refresh;override;(*vb*) Procedure ReDrawSelection;virtual;(*vb*) Procedure ReDrawSelectionPoints;virtual;(*vb*) procedure ManualRefresh;(*vb*) Procedure RefreshSelection;(*vb*) Procedure Reselect;(*vb*) Function GetSurfaceBitmap:Tbitmap; Function GetSurfaceBitmapHandle:Integer;(*vb*) Procedure CollectSelectedFigures(var Selecteds:TList); Procedure CollectSelectionOrder(var Selecteds:TList); Function CheckByPointInt(LayerNbr:Integer;x,y:Integer):TFigure;override;(*vb*) Function CheckByPoint(LayerNbr:Integer;x,y:Double): TFigure; Function SelectByPoint(LayerNbr:Integer;x,y:Double;shiftpressed: boolean): Boolean;(*vb*) Function DoMagicWand(LayerNbr:Integer;x,y:Double):TFigHandle;(*vb*) Function SelectByFigure(LayerNbr:Integer;Fig:TFigHandle;shiftpressed: boolean):Boolean;(*vb*) Function SelectWithInArea(LayerNbr: integer;area:TDoubleRect;shiftpressed: boolean): Boolean;(*vb*) Procedure SelectFigure(FHandle: Integer);(*vb*) Procedure DeSelectFigure(FHandle: Integer);(*vb*) Procedure MoveSelection(deltax,deltay: Double);(*vb*) Procedure MoveAll(deltax,deltay: Double);(*vb*) Procedure MoveAllSilent(deltax,deltay: Double);(*vb*) Procedure DuplicateSelection(deltax,deltay: Double);(*vb*) Procedure DuplicateSelectionAsBezier(deltax,deltay: Double);(*vb*) Procedure ConvertSelectionToBezier;(*vb*) Procedure ArrayRectSelection(distanceX,distanceY: Double;col,row: integer);(*vb*) Procedure ArrayPolarSelection(cpoint: TDoublePoint; angle: Double);(*vb*) function GetSelectionBlock: TBlock; function GetSelectionBlockDuplicate: TBlock; Procedure MakeSelectionBlock(FileName : string);(*vb*) Procedure BoundSelectedLine;(*vb*) Procedure BoundLineToFigures(BLine:TFigHandle; jf1,jf2: TFigHandle);(*vb*) Procedure BoundLinePoint(BLine:TFigHandle; seqnbr: integer; bPoint: TDoublepoint);(*vb*) Procedure BoundLineByText(Line:String;ptIndex:integer); Procedure BoundPLineByText(Line:String;ptIndex:integer); Procedure UnBoundLine;(*vb*) Procedure GetLineJoins(var lines: TstringList); Function MakeSelectedLinesPolyline:TFigHandle;(*vb*) Function WeldIntoPolyline:TFigHandle;(*vb*) Procedure OffSetSelection(Thick:Double);(*vb*) Procedure ClipSelBitmapToSelFigure;(*vb*) Procedure UnClipSelBitmap;(*vb*) function SaveToFile(LayerNbr:integer; FileName : string): Boolean;(*vb*) function LoadFromFile(const FileName : string): Boolean;(*vb*) Procedure LoadFromStream(Stream: TStream); Procedure SaveToStream(Stream: TStream); Function InsertBlockwithFileName(LayerNbr:integer; FileName: string;x,y: Double):TFigHandle;(*vb*) Procedure SetBlockInfo(FigHandle:Integer;Info:String);(*vb*) Function InsertBlockFromStream(LayerNbr:integer;Stream:TStream;x,y: Double):TFigHandle; Procedure ExportAsWmf(FileName: string);(*vb*) Function DrawingAsWmf(dpm:Double):TMetafile;overload; Function DrawingAsWmf:TMetafile;overload; Function SelectionAsWmf:TMetafile; Function FigureAsWmf(FigHandle:TFigHandle;isGrayed:Boolean):TMetafile; Function SelectionAsBitmap(dpi:Integer):TBitmap; Function SelectionAsMetaFile:Integer;(*vb*) Function DrawingAsMetaFile:Integer;(*vb*) Function FigureAsMetaFile(FigHandle:TFigHandle):Integer;(*vb*) Function SelectionAsBmpHandle(dpi:Integer):Integer;(*vb*) Procedure SaveAsBitmap(FileName: string);(*vb*) // Tolik 24/09/2019 -- function SaveToBitmap(aPdfSave: Boolean = False): TBitmap; //function SaveToBitmap: TBitmap; //29.02.2012 // Procedure SaveSubstrateAsBitmap(FileName: string);(*vb*) // Tolik 24/09/2019 -- function SaveSubstrateToBitmap(aPdfSave: Boolean = False): TBitmap; //function SaveSubstrateToBitmap: TBitmap; //29.02.2012 // Function CreatePreviewBitmap: TBitmap; Function CreatePreviewBitmapHandle:Integer;(*vb*) Procedure DrawToDC(dc,x,y:Integer;DScale:Double);(*vb*) Procedure DrawToCanvas(xCanvas:TCanvas;x,y:Integer;DScale:Double); Procedure DrawRectToCanvas(ARect: TDoubleRect; xCanvas:TCanvas;x,y:Integer;DScale:Double); //24.11.2011 Procedure StretchToDC(dc,aLeft,aTop,aRight,aBottom:Integer);(*vb*) Procedure PrintDrawing(TitleinStatusBox: String);(*vb*) Procedure PrintDrawingAsWmf(TitleinStatusBox: String);(*vb*) Procedure PrnStartJob(TitleinStatusBox: String);(*vb*) Procedure PrnDoJob(NewPage:Boolean);(*vb*) Procedure PrnEndJob;(*vb*) Procedure PrnAbortJob;(*vb*) Procedure PrintByTiling(TitleinStatusBox: String; prWmm,prHmm: Double);(*vb*) procedure PrintRect(aRect: TDoubleRect); procedure CalcPrDims(var prWmm, prHmm: Double; var prow, pcol: Integer; AWorkW, AWorkH, AprnScale: Double); //05.12.2011 - calc print dimensions procedure DefinePrnDivIndent; //29.11.2011 Procedure ImportDXF(fileName: string; Layered,IncVertex: Boolean);(*vb*) procedure SCSImportDXF(fileName: string; Layered,IncVertex: Boolean); Procedure ExportAsDxf(FileName: string);(*vb*) Procedure SCSExportDXF(FileName: string); Procedure Clear(LayerNbr : integer; UndoRecord:Boolean);overload; Procedure Clear(LayerNbr : integer);overload;(*vb*) procedure ClearFigures; procedure ClearNoRect(ARect: TDoubleRect); Function RegisterModPoint(Figure: TFigure; PType: TModPointType;DType: TPointType; Color: Tcolor; aDim,X,Y: double; seqNbr: integer;z:Double=0;fOnlyIso:Boolean=False;isBlink:Boolean=false):TModPoint; Procedure UnRegisterModPoint(pt: TModPoint); Function HitTestModPoint(x,y:Double):TModPoint;override; Function HitTestModPointInt(x,y:Double):Integer;override;(*vb*) Function HitTestModPointIntVal(x,y:Integer):TModPoint;override; Function HitTestModPointDetVal(x,y:Integer):TModPoint;override; Procedure CopyToClipBoard;(*vb*) Procedure CutToClipBoard;(*vb*) Procedure SetFieldText(FName,FValue:String);(*vb*) Procedure PasteFromClipBoard(LayerNbr: integer);(*vb*) Function GetLayerNbr(LayerName: string): integer;overload;(*vb*) Function GetLayerNbr(xLayer: TLayer): integer;overload; Function FindFigureByName(FigName:String):TFighandle;(*vb*) Function GetCustomPropList(BlockName: String):Tlist; Function Line(LayerNbr:Integer;x1,y1,x2,y2:Double;w,s,c:integer; row: integer;selected: boolean):TFigHandle;(*vb*) Function Vertex(LayerNbr:Integer;x,y:Double;selected: boolean):TFigHandle;(*vb*) Function PolyLine(LayerNbr:integer;points:TDoublePointArr; w,s,c: integer; row,brs,brc:integer;closed:boolean;selected: boolean):TFigHandle;overload; Function PolyLine(LayerNbr:integer;var points:TDoublePoint; pCount,w,s,c: integer; row,brs,brc:integer;closed:boolean;selected: boolean):TFigHandle;overload;(*vb*) Function Polygon(LayerNbr:integer; points:TDoublePointArr; w,s,c,brs,brc:integer;selected: boolean):TFigHandle; Function Ellipse(LayerNbr:Integer; cx,cy,lenax,lenbx,angle: Double; w,s,c,brs,brc:integer;selected: boolean):TFigHandle;(*vb*) Function Circle(LayerNbr: Integer; cx,cy,radius: Double;w,s,c,brs,brc:integer;selected: boolean):TFigHandle; Function DrawCircle(LayerNbr: Integer; cx,cy,radius: Double;w,s,c,brs,brc:integer;selected: boolean):TFigHandle;(*vb*) Function Arc(LayerNbr:Integer; cx,cy,radius,a1,a2:Double; w,s,c,brs,brc,ArcStyle:Integer;selected: boolean):TFigHandle;(*vb*) Function ElpArc(LayerNbr:Integer; cx,cy,lenax,lenbx,angle,a1,a2:Double; w,s,c,brs,brc,ArcStyle:Integer;selected: boolean):TFigHandle;(*vb*) Function Rectangle(LayerNbr:Integer; x1,y1,x2,y2: DOuble; w,s,c,brs,brc:integer;selected: boolean):TFigHandle;(*vb*) //Tolik 10/03/2016 -- Function InsertBitmap(LayerNbr:Integer; x,y:Double; fName: string;transparent,selected: boolean; JPEGBounds: boolean = false):TFigHandle;(*vb*) //Function InsertBitmap(LayerNbr:Integer; x,y:Double; fName: string;transparent,selected: boolean):TFigHandle;(*vb*) // Function InsertBitmapHandle(LayerNbr:Integer; x,y:Double; xBitmap:TBitmap;transparent,selected: boolean):TFigHandle;overload; Function InsertBitmapHandle(LayerNbr:Integer; x,y:Double; xBitmap:HBitmap;transparent,selected: boolean):TFigHandle;overload;(*vb*) Function InsertWMF(LayerNbr:Integer; x,y:Double; fName: string;selected: boolean): TFigHandle;(*vb*) Function InsertMetafile(LayerNbr:Integer; x,y:Double; mf: TMetafile;selected: boolean): TFigHandle; Function ImportWMF(LayerNbr:integer; fName: string;selected: boolean): TFigHandle;(*vb*) Function ImportMetafile(LayerNbr:Integer; x,y:Double; mf: TMetafile;Selected: Boolean):TFigHandle; Function ImportDrawing(LayerNbr:Integer;x,y:Double;fName:String;Selected:Boolean):TFigHandle;(*vb*) Function TextOut(LayerNbr:Integer; x1,y1,angle,height,ratio: double;atext,aFontName: string;FontCharset:Byte;Color: Integer;Selected: Boolean):TFigHandle;(*vb*) Function AddCustomFigure(LayerNbr:integer;CustomFig: TFigure;Selected:Boolean): TFigHandle; Function GetFigureCustomStream(f:Integer; var size:Integer):Integer;(*vb*) Procedure SetFigureCustomStream(f:Integer;size:Integer;var data:Byte);(*vb*) Function GetCustomStream(var size:Integer):Integer;(*vb*) Procedure SetCustomStream(size:Integer;var data:Byte);(*vb*) Procedure RecordModifyUndo(xFig:Tfigure); Procedure PrintPreview;(*vb*) Procedure PrintRectPreview(ARect: TDoubleRect); //24.11.2011 // Information of Selection Function GetSlcPenStyle : Integer;(*vb*) Function GetSlcPenWidth : Integer;(*vb*) Function GetSlcPenColor : Integer;(*vb*) Function GetSlcRowStyle : Integer;(*vb*) Function GetSlcBrushStyle : Integer;(*vb*) Function GetSlcBrushColor : Integer;(*vb*) Function GetSlcFont : TFont; Function GetSlcFontName:String;(*vb*) Function GetSlcFontBold:Boolean;(*vb*) Function GetSlcFontItalic:Boolean;(*vb*) Function GetSlcFontUnderline:Boolean; Function GetSlcFontStrike:Boolean;(*vb*) Function GetSlcFontSize:Double;(*vb*) Function GetSlcFontCharset:Integer; Function GetSlcFontColor:TColor;(*vb*) Function GetSlcPolylineClosed: Boolean;(*vb*) Function GetSlcImageTransparent: Boolean;(*vb*) Function GetSlcImageClipped: Boolean;(*vb*) Function GetSlcArcStyle:TArcStyle;(*vb*) Function GetSlcLineBounded: Boolean;(*vb*) Function CountBlock(BlockName:String):integer;(*vb*) Procedure CountBlocks(list:TStrings); Procedure CountBlocksByInfo(list:TStrings); Function GetSelectionHandles(var Handles: Array of TFigHandle): Integer; Procedure ExecuteTBCommand(CommandId:integer);virtual;(*vb*) Function GetVersion:Integer;(*vb*) Function GetBuildNumber: Integer;(*vb*) Procedure RegisterFigureClass(Fig: TFigureClass); Procedure PrintMessage(Mes:String);override;(*vb*) Procedure SetTool(aToolIndex: TPCTool;aToolInfo:String;aToolData:Integer);virtual;(*vb*) Procedure NewPattern(pat:TPattern); Function BlockAsWmf(bPath: String):TMetafile; Function BlockAsMetafile(bPath: String):Integer;(*vb*) Function BlockObjAsWmf(ABlock: TFigureGrp):TMetafile; Procedure View3D(const AFileStream: String=''); function Get3DModel(const AFileStream: String=''): TObject; Procedure LockSelChange;(*vb*) Procedure UnLockSelChange;(*vb*) Procedure CenterPage;(*vb*) Procedure AlignPageDown;(*vb*) Procedure AlignPageUp;(*vb*) Procedure StartBlink;(*vb*) Procedure StopBlink;(*vb*) Procedure ResumeBlink;(*vb*) Function IsBlinking:Boolean;(*vb*) Procedure CalibrateLayerScale(p1,p2:TDoublePoint;cUnit:Byte);(*vb*) function GetFigureByDataID(aDataID: Integer): TFigure; //10.11.2011 function GetForm: TForm; //03.03.2012 function GetLineLengthM(p1, p2: TDoublePoint): Double; function GetLengthM(aPCLen: Double): Double; procedure BeginMultiDeselect; //02.04.2012 procedure EndMultiDeselect; //02.04.2012 procedure SelectFigures(aFigures: TList); //11.05.2012 procedure BeginUpdate; procedure EndUpdate(aReFresh: Boolean=true); function PointToScreen(aPt: TDoublePoint): TPoint; //06.05.2013 Procedure ResetRegions;override; //22.08.2012 function CheckFigureInsideCabinet(aLFigures: TList; var aTraceFigure: TFigure; needCheckConn: boolean = false): byte; Property Selection : TList read FSelection write FSelection; Property PenPattern[Index:Integer]:TPattern read GetPenPattern; Property PenPatternCount: Integer read GetPenPatCount; Property BrushPatternCount:Integer read GetBrushPatCount; Property RealScale: Boolean read FRealScale write frealScale;(*vb*) // Used in VerbalCommand Property MetricMode: Integer read FMetricMode write FMEtricMode;(*vb*) // 0 = MM 1= CMM //Used in VerbalCommand Property AngularMode: Integer read FAngularMode write FangularMode;(*vb*) // 0 = RAD 1= DEG //Used in VerbalCommand Property WmfPrinting:Boolean read FWMFPrint write FWMFPrint;(*vb*) published { Published declarations } Property DefaultPenColor : TColor read fdefPenColor write setPenColor default clBlack;(*vb*) Property DefaultBrushColor : TColor read fdefBrsColor write setBrushColor default clBlack;(*vb*) Property DefaultPenWidth : integer read fdefPenWidth write setPenWidth default 1;(*vb*) Property DefaultPenStyle : TPenStyle read fdefPenStyle write setPenStyle default psSolid;(*vb*) Property DefaultBrushStyle : TBrushStyle read fdefBrsStyle write setBrushStyle default bsClear;(*vb*) Property DefaultRowStyle : TRowStyle read fDefRowStyle write setRowStyle default rsNone;(*vb*) Property DefaultTextHeight : Double read fDefTextHeight write setTextHeight;(*vb*) (* default 12 *) Property DefaultTextRatio : Double read fDefTextRatio write setTextRatio;(*vb*) (* default 0 *) Property DefaultPLineClosed: Boolean read fDefPLineClosed write SetPLineClosed default False;(*vb*) Property DefaultArcStyle:TArcStyle read fDefArcStyle write SetArcStyle default asOpen;(*vb*) Property LayerCount: integer read GetLayerCount default 1;(*vb*) Property FigureCount: integer read GetFigureCount default 0;(*vb*) Property SelectedCount: integer read GetSelCount default 0;(*vb*) Property MapScale: Double read FMapScale write setmapScale{ default 100};(*vb*) Property RescaleToMap: TMapRescale read FRescale write fRescale default rsNever;(*vb*) Property AutoSelect: Boolean read FAutoSelect write setAutoSelect default True;(*vb*) Property Font; Property KeyCommands: Boolean read FKeyCommands write FKeyCommands default True;(*vb*) Property RecordUndo:Boolean read GetRecordUndo write FRecordUndo default True;(*vb*) Property UndoCount: Integer read FUndoCount write FUndoCount default 24;(*vb*) Property DefaultPictureFolder: String read FPictureFolder write FPictureFolder;(*vb*) (* default '' *) Property SaveWithPreview:Boolean read FSavePrev write fSavePrev default True;(*vb*) Property RulerMode:TRulerMode read FRulerMode write setRulerMode default rmPage;(*vb*) Property ZoomRect:Boolean read FZoomRect write SetZoomRect default False;(*vb*) Property RangeCheck:Boolean read fRangeCheck write SetRangeCheck default False;(*vb*) Property AutoTilePrint:Boolean read fAutoTile write FAutoTile default True;(*vb*) Property FigureGuides:Boolean read FFigureGuides write SetFigureGuides default True;(*vb*) Property NativeFill:Boolean read FNativeFill write FNativeFill default False;(*vb*) Property OnSelectionChange:TNotifyEvent read FOnSelChange write FOnSelChange;(*vb*) Property OnObjectInserted:TInsertEvent read FOnObjectInserted write FOnObjectInserted;(*vb*) Property OnBeforeFigureInsert:TBeforeInsertEvent read FBeforeFigureInsert write FBeforeFigureInsert;(*vb*) Property OnFigureMoved:TMoveEvent read FOnFigureMoved write FOnFigureMoved;(*vb*) Property OnFigureModify:TFigureEvent read FFigureModify write fFigureModify;(*vb*) Property OnFigureSelect:TFigureEvent read FFigureSelect write FFigureSelect;(*vb*) Property OnBeforeDelete: TFigureDeleteEvent read FOnFigureDel write FOnFigureDel;(*vb*) Property OnAfterDelete: TNotifyEvent read FOnAfterFigureDel write FOnAfterFigureDel;(*vb*) Property OnBeforeUndo: TNotifyEvent read FOnBeforeUndo write FOnBeforeUndo;(*vb*) Property OnAfterUndo: TNotifyEvent read FOnAfterUndo write FOnAfterUndo;(*vb*) Property OnSnapToFigure: TSnapEvent read FSnapToFigure write FSnapToFigure;(*vb*) Property OnSurfacePaint: TNotifyEvent read SOnPaint write SOnPaint;(*vb*) Property OnMapScaleChanged: TNotifyEvent read FOnMapScale write FOnMapScale;(*vb*) Property OnUserDraw:TuserDrawEvent read FOnUserDraw write FOnUserDraw;(*vb*) Property OnUserHitTest:TUserHitEvent read FonUserHitTest write FonUserHitTest;(*vb*) Property OnBeforeClear:TNotifyEvent read FOnBeforeClear write FOnBeforeClear;(*vb*) Property OnCollectFaces:TOnCollectFaces read FOnCollectFaces write FOnCollectFaces; Property OnCollectFigureFaces:TOnCollectFigureFaces read FOnCollectFigureFaces write FOnCollectFigureFaces; Property OnObjectSaved:TFigureEvent read FOnObjectSaved write FOnObjectSaved;(*vb*) Property OnFigureEdit:TFigureEvent read FOnFigureEdit write FOnFigureEdit;(*vb*) Property OnCustomUndo:TOnCustomUndoEvent read FOnCustomUndo write FOnCustomUndo;(*vb*) Property OnBeforeModify:TFigureEvent read FOnBeforeModify write FOnBeforeModify;(*vb*) Property OnBeforeMove:TFigureEvent read FOnBeforeMove write FOnBeforeMove;(*vb*) Property OnBeforeMoveAll:TBeforeMoveAllEvent read FBeforeMoveAll write FBeforeMoveAll;(*vb*) Property OnAfterMoveAll:TAfterMoveAllEvent read FAfterMoveAll write FAfterMoveAll;(*vb*) Property OnLayerInitData:TLayerInitData read FLayerInitData write FLayerInitData; Property OnLayerSaveData:TLayerSaveData read FLayerSaveData write FLayerSaveData; Property OnLayerLoadData:TLayerLoadData read FLayerLoadData write FLayerLoadData; Property OnCalibrateLayer:TCalibrateLayer read FCalibrateLayer write FCalibrateLayer;(*vb*) Property OnCustomStreamUpdate:TNotifyEvent read FCustomStreamUpdate write FCustomStreamUpdate;(*vb*) Property OnCustomStreamLoaded:TNotifyEvent read FCustomStreamLoaded write FCustomStreamLoaded;(*vb*) Property OnGetFigureToSelect: TGetFigureEvent read FGetFigureToSelect write FGetFigureToSelect; property OnGetModPointToSelect: TGetModPointEvent read FGetModPointToSelect write FGetModPointToSelect; property OnCheckPrnWithOffset: TCheckPrnWithOffsetEvent read FCheckPrnWithOffset write FCheckPrnWithOffset; end; (*vbclassexport end*) TGetVerbsProc = Function:pchar;stdcall; TDoVerbProc = Procedure (VerbIndex: integer);stdcall; TInitProc = Procedure (OwnerApp:integer);stdcall; Function ProcessMFRecord(DC:HDC; HT:PHandleTable; rec:PEnhMetaRecord; count: integer; param: pointer): integer;stdcall; var DeltaMoveX :Double; DeltaMoveY :Double; ThickUnit : Double = 0.25; implementation uses DXFEngine, DXFExport, U_DXFEngineSCS, U_Common, U_BaseCommon, Types, USCS_main, U_Constants, U_BaseConstants, U_ESCadClasess, fplan, U_Cad, U_SCSLists, U_ArchCommon, {U_Arch3D}U_Arch3DNew, U_SCSComponent, U_Main{Tolik 29/03/2017 -- }, U_Master_Compl {$ifdef 3D} ,Form3D {Tolik 26/10/2015}, U_HouseClasses, U_Navigator // {$endif 3D} ; {$R *.DCR} var PenRatio: Double = 1; BufferObj: TPCDrawing; wmfLayer: integer; pw,pc,ps,bc,bs: integer; MoveTOx,MOveToY,wmfwpy,wmfwpx,wmfwex,wmfwey,wmfx,wmfy: Double; xForm:TXForm; xFormId: Integer; wmfVZ:TVertZero; wmfHZ:THorzZero; mfdpmm: extended; Reccount : integer; wmfMapMode: DWORD; WmfPenBrush: Array [1..500] of TPenBrush; SavedDC: array [1..500] of TSavedDc; SaveCnt:Integer; ActivePen,ActiveBrush: Integer; wmfLogCnt : integer; wmfpl: Tpolyline; CF_PCAD: Word; TextObj: TText; FontName: String; FontCS: Word; FontW: Integer; FontH: Integer; blkvz,blkhz:Integer; blktopx,blkTopy,blkDistX,blkDistY: Double; blkW,blkH: Integer; prnDivIndent: Double = 8.5; //28.11.2011 DropOFFMM: Boolean = True; Constructor TPCDrawing.create(Aowner: TComponent); var l: TLayer; pw,pc: byte; txColor: Integer; txFont: String; txCharset: Byte; txSize: Integer; txRatio: Double; txBold,txItalic,txUnderline,txStrike: Byte; pVector: TVector; BPattern: Tpattern; cObject: TVectorObject; dp: TDoublePointArr; i: integer; //01.11.2011 fc: TFigureClass; Begin inherited create(aowner); //Tolik TextObj := nil; wmfpl := nil; isDrawingFigures := False; // FWMFPrint := False; PictureFrame:= True; FFigureGuides := True; SelFeed := 0; DrawSurface := True; Layers := Tlist.create; //Tolik 13/12/2019 -- //Figures := Tlist.create; Figures := TMyObjectList.create(False); // //ModPoints := TList.Create; ModPoints := TMyList.Create; // Tolik 24/12/2019 -- FAutoTile := True; FMapScale := 100; FAutoSelect := True; FAnySelected := False; FSelection := TList.create; FRulerMode := rmPage; //MacroEngine := THalComp.Create(nil); //SetInterfaceHandle; fDefPenColor := clBlack; fDefBrsColor := clYellow; fDefPenstyle := psSolid; fDefPenWidth := 1; fDefBrsStyle := bsClear; fDefTextHeight := 8; fDefTextRatio := 0; fDefPLineClosed := False; FNativeFill := False; AutoRefresh := True; RealScale := False; CurrentX := 0; CurrentY := 0; CpBlockNames:= TStringlist.Create; cpLists:= TList.Create; FPenPatList := TList.Create; BrushList := TList.Create; FRescale := rsNever; FDetailScale := 100; if not (csDesigning in self.ComponentState) then begin if FigureClasses.IndexOf(DrawObjects.TLine) = -1 then FigureClasses.Add(DrawObjects.TLine); if FigureClasses.IndexOf(THellical) = -1 then FigureClasses.Add(THellical); if FigureClasses.IndexOf(TPolyline) = -1 then FigureClasses.Add(TPolyline); if FigureClasses.IndexOf(TFreeHand) = -1 then FigureClasses.Add(TFreeHand); if FigureClasses.IndexOf(TEllipse) = -1 then FigureClasses.Add(TEllipse); if FigureClasses.IndexOf(TArc) = -1 then FigureClasses.Add(TArc); if FigureClasses.IndexOf(TElpArc) = -1 then FigureClasses.Add(TElpArc); if FigureClasses.IndexOf(TCircle) = -1 then FigureClasses.Add(TCircle); if FigureClasses.IndexOf(DrawObjects.TRectangle) = -1 then FigureClasses.Add(DrawObjects.TRectangle); if FigureClasses.IndexOf(TVertex) = -1 then FigureClasses.Add(TVertex); if FigureClasses.IndexOf(TCircleVertex) = -1 then FigureClasses.Add(TCircleVertex); if FigureClasses.IndexOf(TBMPObject) = -1 then FigureClasses.Add(TBMPObject); if FigureClasses.IndexOf(TText) = -1 then FigureClasses.Add(TText); if FigureClasses.IndexOf(TFigureGrp) = -1 then FigureClasses.Add(TFigureGrp); if FigureClasses.IndexOf(TBlock) = -1 then FigureClasses.Add(TBlock); if FigureClasses.IndexOf(TRotate) = -1 then FigureClasses.Add(TRotate); if FigureClasses.IndexOf(TMove) = -1 then FigureClasses.Add(TMove); if FigureClasses.IndexOf(TDuplicate) = -1 then FigureClasses.Add(TDuplicate); if FigureClasses.IndexOf(TDuplicateAsBezier) = -1 then FigureClasses.Add(TDuplicateAsBezier); if FigureClasses.IndexOf(TMirror) = -1 then FigureClasses.Add(TMirror); if FigureClasses.IndexOf(TArrayPol) = -1 then FigureClasses.Add(TArrayPol); if FigureClasses.IndexOf(TArrayRect) = -1 then FigureClasses.Add(TArrayRect); if FigureClasses.IndexOf(TRichText) = -1 then FigureClasses.Add(TRichText); if FigureClasses.IndexOf(TOleObject) = -1 then FigureClasses.Add(TOleObject); if FigureClasses.IndexOf(TMathGraph) = -1 then FigureClasses.Add(TMathGraph); if FigureClasses.IndexOf(TWmfObject) = -1 then FigureClasses.Add(TWmfObject); if FigureClasses.IndexOf(THDimLine) = -1 then FigureClasses.Add(THDimLine); if FigureClasses.IndexOf(TVDimLine) = -1 then FigureClasses.Add(TVDimLine); if FigureClasses.IndexOf(TADimLine) = -1 then FigureClasses.Add(TADimLine); if FigureClasses.IndexOf(TCDimLine) = -1 then FigureClasses.Add(TCDimLine); if FigureClasses.IndexOf(TArcDimLine) = -1 then FigureClasses.Add(TArcDimLine); if FigureClasses.IndexOf(TUserRectangle) = -1 then FigureClasses.Add(TUserRectangle); if FigureClasses.IndexOf(TUserLine) = -1 then FigureClasses.Add(TUserLine); if FigureClasses.IndexOf(TUserVertex) = -1 then FigureClasses.Add(TUserVertex); if FigureClasses.IndexOf(TUserCircle) = -1 then FigureClasses.Add(TUserCircle); if FigureClasses.IndexOf(TUserArc) = -1 then FigureClasses.Add(TUserArc); if FigureClasses.IndexOf(TUserEllipse) = -1 then FigureClasses.Add(TUserEllipse); if FigureClasses.IndexOf(TUserPolyline) = -1 then FigureClasses.Add(TUserPolyline); if FigureClasses.IndexOf(TKnife) = -1 then FigureClasses.Add(TKnife); if FigureClasses.IndexOf(TTextPanel) = -1 then FigureClasses.Add(TTextPanel); if FigureClasses.IndexOf(TPointSet) = -1 then FigureClasses.Add(TPointSet); if FigureClasses.IndexOf(TAngleLine) = -1 then FigureClasses.Add(TAngleLine); if FigureClasses.IndexOf(TCalibrate) = -1 then FigureClasses.Add(TCalibrate); if FigureClasses.IndexOf(TPrintRect) = -1 then FigureClasses.Add(TPrintRect); //25.11.2011 //Tolik 31/05/2017 -- if FigureClasses.IndexOf(TPie) = -1 then // Сектор FigureClasses.Add(TPie); if FigureClasses.IndexOf(TOverlappedEllipse) = -1 then // Сектор FigureClasses.Add(TOverlappedEllipse); // эллипс с вырезанным эллипсом внутри // //01.11.2011 - список классов в сорт виде for i := 0 to FigureClasses.Count - 1 do begin fc := TFigureClass(FigureClasses[i]); if FigureClassesSL.IndexOf(fc.ClassName) = -1 then FigureClassesSL.Addobject(fc.ClassName, TObject(fc)); end; l := TLayer.create('Base Layer'); l.vertZero := ord(VerticalZero); l.horzZero := ord(HorizontalZero); l.DrawEngine := Dengine; Layers.add(l); FUndoList := TList.Create; FUndoIdx := 0; RecordUndo := True; PVector:= TVector.Create(0); PVector.AddLineSegment(DoublePoint(2,2)); PVector.AddLineSegment(DoublePoint(4,0)); BPattern := Tpattern.Create(PVector,4,0); // Tolik 09/03/2017 -- pVector.Free; // BPattern.PatName := pnZigZag; FPenPatList.Add(BPattern); PVector:= TVector.Create(0); PVector.AddBezierSegment(DoublePoint(3,0),DoublePoint(0,2),DoublePoint(3,2)); BPattern := Tpattern.Create(PVector,3,0); // Tolik 09/03/2017 -- pVector.Free; // BPattern.PatName := pnFlower; FPenPatList.Add(BPattern); PVector:= TVector.Create(0); PVector.AddBezierSegment(DoublePoint(3,0),DoublePoint(0,2),DoublePoint(3,2)); PVector.AddBezierSegment(DoublePoint(6,0),DoublePoint(3,-2),DoublePoint(6,-2)); BPattern := Tpattern.Create(PVector,6,0); // Tolik 09/03/2017 -- pVector.Free; // BPattern.PatName := pnSinus; FPenPatList.Add(BPattern); PVector:= TVector.Create(0); cObject := TVectorObject.CreateCircleObject(DoublePoint(1.5,0),1.5); PVector.AddVectorObject(cObject); BPattern := Tpattern.Create(PVector,3,0.5); // Tolik 09/03/2017 -- pVector.Free; // BPattern.PatName := pnButtons; FPenPatList.Add(BPattern); PVector:= TVector.Create(0); SetLength(dp,4); dp[0] := doublePoint(0,0); dp[1] := doublePoint(0,3); dp[2] := doublePoint(3,3); dp[3] := doublePoint(3,0); cObject := TVectorObject.CreatePolygonObject(4,dp); PVector.AddVectorObject(cObject); BPattern := Tpattern.Create(PVector,3,0.5); // Tolik 09/03/2017 -- pVector.Free; // BPattern.PatName := pnSquare; FPenPatList.Add(BPattern); PVector:= TVector.Create(0); PVector.AddBezierSegment(DoublePoint(1.5,0),DoublePoint(0,1),DoublePoint(1.5,1)); PVector.AddBezierSegment(DoublePoint(3,0),DoublePoint(1.5,-1),DoublePoint(3,-1)); BPattern := Tpattern.Create(PVector,3,0); // Tolik 09/03/2017 -- pVector.Free; // BPattern.PatName := pnMiniSinus; FPenPatList.Add(BPattern); FBlinkTimer:= TTimer.Create(self); FBlinkTimer.Enabled := False; FblinkTimer.Interval := 400; FBlinkPaused := False; FBlinkTimer.OnTimer := OnBlinkTimer; end; CF_PCAD := RegisterClipboardFormat('PowerCad Figure'); FKeyCommands := True; evBrushStyle := EventEngine(cBrushStyle,ord(fDefBrsStyle),'',0); evPenStyle := EventEngine(cPenStyle,ord(fDefPenStyle),'',0); pw := (fDefPenWidth-1); evPenWidth := EventEngine(cPenWidth,pw,'',0); evRowStyle := EventEngine(cRowStyle,ord(fDefRowStyle),'',0); evPenColor := EventEngine(cPenColor,fDefPenColor,'',0); evBrushColor := EventEngine(cBrushColor,fDefBrsColor,'',0); txColor := Font.Color; evTextColor := EventEngine(cTextColor,txColor,'',0); txFont := Font.Name; evTextFont := EventEngine(cFontName,0,txFont,0); evTextSize := EventEngine(cTextSize,8,'',0); evTextCharset := EventEngine(cTextCharset,0,'',0); txBold := 0; if fsBold in Font.Style then txBold := 1; evTextBold := EventEngine(cBold,txBold,'',0); txItalic := 0; if fsItalic in Font.Style then txItalic := 1; evTextItalic := EventEngine(cItalic,txItalic,'',0); txUnderline := 0; if fsUnderline in Font.Style then txUnderline := 1; evTextUnderline := EventEngine(cUnderline,txUnderline,'',0); txStrike := 0; if fsStrikeOut in Font.Style then txStrike := 1; evTextStrike := EventEngine(cStrike,txStrike,'',0); evToolIndex := EventEngine(cDrawTool,Integer(Self),'',0); pc := 0;evPLineClosed := EventEngine(cPolylineClosed,pc,'',0); evTransparent := EventEngine(cTransparentImage,0,'',0); evClipped := EventEngine(cClipImage,0,'',0); evArcStyle := EventEngine(cArcStyle,ord(fDefArcStyle),'',0); evBounded := EventEngine(cBoundLine,0,'',0); evArcSel := EventEngine(cArcSel,0,'',0); evBmpSel := EventEngine(cBmpSel,0,'',0); evLineSel := EventEngine(cLineSel,0,'',0); evPLineSel := EventEngine(cPLineSel,0,'',0); evGroupSel := EventEngine(cGroupSel,0,'',0); evAnySel := EventEngine(cAnySel,0,'',0); evRulerMode := EventEngine(cRulerMode,ord(FRulerMode),'',0); RecordUndo := True; FUndoCount := 24; Freed:= TList.Create; fPictureFolder := ''; PrevForm := TfrmPrv.Create(self); SlcBitmapCnt := 0; SlcLineCnt := 0; SlcPlineCnt := 0; SlcArcCnt := 0; SlcCircleCnt := 0; SlcEllipseCnt := 0; SlcVertexCnt := 0; SlcGroupCnt := 0; SlcRectangleCnt:= 0; SlcDimCnt := 0; FSavePrev := True; CustomStream := nil; AutoRefresh := False; SetRulerValues(FMapScale,ord(FRulerMode)); AutoRefresh := True; MetricMode := 1; //CM AngularMode := 1; //MM Faces := TList.Create; FSelChangeLocked := False; FRangeCheck := False; PlotHeight := 0; PlotCopy := 1; prnDivOverlay := 0; //01.12.2011 prnScale := 1; FMultiDeselectCount := 0; //02.04.2012 FUpdateCount := 0; //06.08.2012 FUpdateCountAdd := 0; //Tolik SetLength(dp,0); FLastFigureID := 1000000; // 25/10/2017 FLastFigureIDOnLoad := 1000000; // 25/10/2017 FBreakedOnQuota := False; // 16/11/2017 -- // end; // Tolik 23/03./2017 -- Destructor TPCDrawing.Destroy; var i, j: Integer; Figure: TFigure; begin FOnFigureDel := nil; RecordUndo := False; AutoRefresh := False; // if not (csDesigning in self.ComponentState) then begin ClearUndoList; ExitClear; // FUndoList.Clear; FUndoList.Free; end; try For i := 0 to Layers.Count - 1 do begin for j := (TLayer(Layers[i]).ModPoints.Count - 1) downto 0 do UnRegisterModPoint(TModPoint(TLayer(Layers[i]).ModPoints[j])); TLayer(Layers[i]).ModPoints.Clear; TLayer(Layers[i]).Free; end; except // on E: Exception do AddExceptionToLog(CPowerCadMessage + 'TPCDrawing.Destroy' + E.Message); end; Layers.Free; For i := (ModPoints.Count - 1) downto 0 do begin UnRegisterModPoint(TModPoint(ModPoints[i])); end; ModPoints.Free; FreeAndNil(Figures); //MacroEngine.Free; //NilInterfaceHandle; CpBlockNames.Free; // cpLists.Clear; cpLists.Free; try for i := 0 to FPenPatList.Count - 1 do begin TPattern(FPenPatList[i]).Free; end; for i := 0 to BrushList.Count-1 do begin TBitmap(BrushList[i]).Free; end; except // on E: Exception do AddExceptionToLog(CPowerCadMessage + 'TPCDrawing.Destroy' + E.Message); end; FSelection.Free; FPenPatList.Free; BrushList.Free; //Freed.Free; // Tolik If Assigned(PrevForm.Tbmp) then prevForm.tBmp.Free; // PrevForm.free; if assigned(CustomStream) then CustomStream.Free; //Tolik -- это выполнится на дестрое PCDrawBox, т.к. они "сидят" там {if TempBitMap <> nil then FreeAndNil(TempBitMap); if BaseBitMap <> nil then FreeAndNil(BaseBitMap);} ClearFaces; Faces.Free; if TextObj <> nil then begin end; FBlinkTimer.Free; // inherited destroy; end; // (* Destructor TPCDrawing.Destroy; var i: Integer; Figure: TFigure; begin FOnFigureDel := nil; RecordUndo := False; AutoRefresh := False; // if not (csDesigning in self.ComponentState) then begin ClearUndoList; ExitClear; // FUndoList.Clear; FUndoList.Free; end; try For i := 0 to Layers.Count - 1 do begin TLayer(Layers[i]).Free; end; except // on E: Exception do AddExceptionToLog(CPowerCadMessage + 'TPCDrawing.Destroy' + E.Message); end; Layers.Free; //Figures.Free; //Tolik // ниже закомменченое не применять, т.к. все бы хорошо, но на некоторых битых проектах ModPoint не убивается, // получим "вылет" процедуры, КАД, соответственно, тоже не убивается, получаем "висящий" в памяти лист и авеху на // открытии след. проекта, если у него такое же или большее количество листов с матюком, что такой лист уже имеется // ВНИМАНИЕ!!! MDICHILDCOUNT основной формы уже декрементирован до прихода сюда, так что там, вроде, все - ОК, а здесь - нет!!! { if ModPoints.Count > 0 then begin for i := 0 to ModPoints.Count - 1 do begin if assigned(ModPoints[i]) then TModPoint(ModPoints[i]).Destroy; end; end;} ModPoints.Free; FreeAndNil(Figures); //MacroEngine.Free; //NilInterfaceHandle; // CpBlockNames.Clear; CpBlockNames.Free; // cpLists.Clear; cpLists.Free; try for i := 0 to FPenPatList.Count - 1 do begin TPattern(FPenPatList[i]).Free; end; for i := 0 to BrushList.Count-1 do begin TBitmap(BrushList[i]).Free; end; except // on E: Exception do AddExceptionToLog(CPowerCadMessage + 'TPCDrawing.Destroy' + E.Message); end; FSelection.Free; FPenPatList.Free; BrushList.Free; //Freed.Free; // Tolik If Assigned(PrevForm.Tbmp) then prevForm.tBmp.Free; // PrevForm.free; if assigned(CustomStream) then CustomStream.Free; //Tolik -- это выполнится на дестрое PCDrawBox, т.к. они "сидят" там {if TempBitMap <> nil then FreeAndNil(TempBitMap); if BaseBitMap <> nil then FreeAndNil(BaseBitMap);} ClearFaces; Faces.Free; if TextObj <> nil then begin end; FBlinkTimer.Free; // inherited destroy; end; *) Procedure TPCDrawing.Undo; var xAction: TUndoAction; xType: TUndoActionType; xFig,aFigure : TFigure; xbmp: TbmpObject; grp: TFigureGrp; i,t: integer; p:PPoint; s:TMemoryStream; RecordRedo : Boolean; k,j: integer; oldVal, newVal: double; xFigH: TSCSHDimLine; xFigV: TSCSVDimLine; Begin try //if (ActiveLAyer <> 1)and(Activelayer <> 7)and(not TLayer(TF_CAD(Self.Owner).PCad.GetLayer(Activelayer)).IsDxf) then // Exit; //EXIT {if GDropComponent <> nil then Exit;} CancelActions; // Tolik 18/12/2019 -- //GShadowObject := nil; if GShadowObject <> nil then DestroyShadowObject; // try //Проверка фигуры на вхождение в кабинет if CheckAssignedPCAD(Self) then begin if TF_CAD(Self.Owner).FNeedUpdateCheckedFigures then TF_CAD(Self.Owner).UpdateCheckedFigures; for j := 0 to TF_CAD(Self.Owner).FCheckedFigures.Count - 1 do begin aFigure := TFigure(TF_CAD(Self.Owner).FCheckedFigures[j]); TF_CAD(Self.Owner).Pcad.CheckFigureInsideCabinet(TF_CAD(Self.Owner).FCheckedFigures, aFigure); end; TF_CAD(Self.Owner).Pcad.Refresh; end; except end; if (ActiveLAyer <> 1)and(Activelayer <> 7)and(not TLayer(TF_CAD(Self.Owner).PCad.GetLayer(Activelayer)).IsDxf) then Exit; //EXIT if assigned(FOnCustomUndo) then begin FOnCustomUndo(Self,False); exit; end; if FUndoList.Count = 0 then exit; if FUndoIdx >= FUndoList.Count then exit; if assigned(FOnBeforeUndo) then FOnBeforeUndo(Self); xAction := TUndoAction(FUndoList[FUndoIdx]); xType := xAction.ActionType; case xType of uaInsert: begin for i := 0 to xAction.List.Count-1 do begin xFig := TFigure(xAction.List[i]); xfig.deselect; xFig.Deleted := True; Figures.Remove(xFig); end; end; uaReplace: begin for i := 0 to xAction.List.Count-1 do begin xFig := TFigure(xAction.List[i]); xfig.deselect; Figures.Remove(xFig); end; for i := 1 to xAction.Params.Count do begin k := xAction.Params.Count-i; xFig := TFigure(xAction.Params[k]); xFig.Deleted := False; t := xFig.DelIndex; Figures.Insert(t,xFig); xFig.Selected := True; end; end; uaRemove: begin for i := 1 to xAction.List.Count do begin k := xAction.List.Count-i; xFig := TFigure(xAction.List[k]); xFig.Deleted := False; t := xFig.DelIndex; Figures.Insert(t,xFig); xFig.Selected := True; end; end; uaModify: begin t := 0; RecordRedo := false; if xAction.RedoList.Count = 0 then RecordRedo := True; for i := 0 to xAction.List.Count-1 do begin xFig := TFigure(xAction.List[i]); if RecordRedo then begin s := TMemoryStream.Create; xFig.WriteToStream(s); xAction.RedoList.Add(s); end; if xFig is TFigureGrp then begin TFigureGrp(xfig).Reloading := True; end; s:= TMemoryStream(xAction.Params[i]); s.Position := 0; ReadStringFromStream(s); if (xFig is TSCSHDimLine) then oldVal := StrToFloat_My(TSCSHDimLine(xFig).DLabel); if (xFig is TSCSVDimLine) then oldVal := StrToFloat_My(TSCSVDimLine(xFig).DLabel); xFig.SetPropertiesFromStream(s); if xFig is TFigureGrp then begin TFigureGrp(xfig).Reloading := False; end; if (xFig is TSCSHDimLine) then begin xFigH := TSCSHDimLine(xFig); newVal := xFigH.FValue; xFigH.ReScaleHCAD(oldVal, newVal); ReScaleAllDimLines; newVal := MetreToUOM(newVal); xFigH.DLabel := FormatFloat(ffMask, newVal); end; if (xFig is TSCSVDimLine) then begin xFigV := TSCSVDimLine(xFig); newVal := xFigV.FValue; xFigV.ReScaleVCAD(oldVal, newVal); ReScaleAllDimLines; newVal := MetreToUOM(newVal); xFigV.DLabel := FormatFloat(ffMask, newVal); end; xFig.Modified := True; xFig.RefreshHatch; end; end; uaGroup: begin grp := TFigureGrp(xAction.List[0]); grp.UnGroup; figures.Remove(grp); end; uaUnGroup: begin for i := 0 to xAction.List.Count-1 do begin grp := TFigureGrp(xAction.List[i]); figures.Add(grp); grp.UnGrouped := false; for k := 0 to grp.InFigures.Count-1 do begin figures.Remove(grp.Infigures[k]); end; end; end; uaOrder: begin for i := 0 to xAction.List.Count-1 do begin if xAction.FIndex = 1 then j := xAction.List.Count-1-i else j := i; xFig := TFigure(xAction.List[j]); k := Integer(xAction.Params[j]); t := Figures.IndexOf(xFig); Figures.Move(t,k); end; end; uaClip: begin xBmp := TBmpObject(xAction.List[0]); xFig := TFigure(xAction.Params[0]); Figures.Add(xfig); xFig.Select; xBmp.ClipFigure := nil; end; uaUnClip: begin xBmp := TBmpObject(xAction.List[0]); xFig := TFigure(xAction.Params[0]); Figures.Remove(xfig); xBmp.ClipFigure :=xFig; end; uaDimLine: begin t := 0; RecordRedo := false; if xAction.RedoList.Count = 0 then RecordRedo := True; for i := 0 to xAction.List.Count-1 do begin xFig := TFigure(xAction.List[i]); if RecordRedo then begin s := TMemoryStream.Create; xFig.WriteToStream(s); xAction.RedoList.Add(s); end; if xFig is TFigureGrp then begin TFigureGrp(xfig).Reloading := True; end; s:= TMemoryStream(xAction.Params[i]); s.Position := 0; ReadStringFromStream(s); xFig.SetPropertiesFromStream(s); if xFig is TFigureGrp then begin TFigureGrp(xfig).Reloading := False; end; xFig.Modified := True; // Tolik 15/10/2020 -- применить масштаб if xFig is TSCSHDimLine then TSCSHDimLine(xFig).ReScaleHCAD(0,TSCSHDimLine(xFig).FValue) else if xFig is TSCSVDimLine then TSCSVDimLine(xFig).ReScaleVCAD(0,TSCSVDimLine(xFig).FValue); // xFig.RefreshHatch; end; end; // Tolik 03/06/2021 -- uaList: TF_Cad(Owner).SCSUndoElScheme; //Tolik 23/06/2021 -- uaDesignList: TF_Cad(Owner).SCSUndoDesignList; // Tolik 25/06/2021 -- uaProjectPlan: TF_Cad(Owner).SCSUndoProjectPlan; end; FUndoIdx := FUndoIdx +1; if xAction.Tag = 1 then Undo; if assigned(FOnAfterUndo) then FOnAfterUndo(Self); Refresh; except // on E: Exception do AddExceptionToLog(CPowerCadMessage + 'TPCDrawing.Undo' + E.Message); end; End; Procedure TPCDrawing.Redo; var xAction: TUndoAction; xType: TUndoActionType; xFig,aFigure : TFigure; xBmp: TBmpObject; i,k,t,j: integer; s:TmemoryStream; grp: TFigureGrp; oldVal, newVal: double; xFigH: TSCSHDimLine; xFigV: TSCSVDimLine; Begin try //if (ActiveLAyer <> 1)and(Activelayer <> 7)and(not TLayer(TF_CAD(Self.Owner).PCad.GetLayer(Activelayer)).IsDxf) then // Exit; //EXIT CancelActions; // Tolik 18/12/2019 -- if GShadowObject <> nil then DestroyShadowObject; //GShadowObject := nil; // try //Проверка фигуры на вхождение в кабинет if CheckAssignedPCAD(Self) then begin if TF_CAD(Self.Owner).FNeedUpdateCheckedFigures then TF_CAD(Self.Owner).UpdateCheckedFigures; for j := 0 to TF_CAD(Self.Owner).FCheckedFigures.Count - 1 do begin aFigure := TFigure(TF_CAD(Self.Owner).FCheckedFigures[j]); TF_CAD(Self.Owner).Pcad.CheckFigureInsideCabinet(TF_CAD(Self.Owner).FCheckedFigures, aFigure); end; TF_CAD(Self.Owner).Pcad.Refresh; end; except end; if (ActiveLAyer <> 1)and(Activelayer <> 7)and(not TLayer(TF_CAD(Self.Owner).PCad.GetLayer(Activelayer)).IsDxf) then Exit; //EXIT if assigned(FOnCustomUndo) then begin FOnCustomUndo(Self,True); exit; end; if FUndoList.Count = 0 then exit; if FUndoIdx = 0 then exit; FUndoIdx := FUndoIdx -1; xAction := TUndoAction(FUndoList[FUndoIdx]); xType := xAction.ActionType; case xType of uaInsert: begin for i := 0 to xAction.List.Count-1 do begin xFig := TFigure(xAction.List[i]); Figures.Add(xFig); xFig.Selected := True; xFig.Deleted := False; end; end; uaReplace: begin for i := 0 to xAction.List.Count-1 do begin xFig := TFigure(xAction.List[i]); Figures.Add(xFig); xFig.Selected := True; xFig.Deleted := False; end; for i := 0 to xAction.Params.Count-1 do begin xFig := TFigure(xAction.Params[i]); xFig.Deleted := True; xFig.DelIndex := Figures.IndexOf(xFig); xfig.deselect; Figures.Remove(xFig); end; end; uaRemove: begin for i := 0 to xAction.List.Count-1 do begin xFig := TFigure(xAction.List[i]); xFig.Deleted := True; xFig.DelIndex := Figures.IndexOf(xFig); xfig.deselect; Figures.Remove(xFig); end; end; uaModify: begin for i := 0 to xAction.RedoList.Count-1 do begin xFig := TFigure(xAction.List[i]); s:= TMemoryStream(xAction.RedoList[i]); s.Position := 0; if xFig is TFigureGrp then begin TFigureGrp(xfig).Reloading := True; TFigureGrp(xfig).LoadIdx := 0; end; ReadStringFromStream(s); if (xFig is TSCSHDimLine) then oldVal := StrToFloat_My(TSCSHDimLine(xFig).DLabel); if (xFig is TSCSVDimLine) then oldVal := StrToFloat_My(TSCSVDimLine(xFig).DLabel); xFig.SetPropertiesFromStream(s); if xFig is TFigureGrp then begin TFigureGrp(xfig).Reloading := False; TFigureGrp(xfig).LoadIdx := 0; end; if (xFig is TSCSHDimLine) then begin xFigH := TSCSHDimLine(xFig); newVal := xFigH.FValue; xFigH.ReScaleHCAD(oldVal, newVal); ReScaleAllDimLines; newVal := MetreToUOM(newVal); xFigH.DLabel := FormatFloat(ffMask, newVal); end; if (xFig is TSCSVDimLine) then begin xFigV := TSCSVDimLine(xFig); newVal := xFigV.FValue; xFigV.ReScaleVCAD(oldVal, newVal); ReScaleAllDimLines; newVal := MetreToUOM(newVal); xFigV.DLabel := FormatFloat(ffMask, newVal); end; xFig.Modified := True; end; end; uaGroup: begin grp := TFigureGrp(xAction.List[0]); for i := 0 to grp.InFigures.Count -1 do begin figures.Remove(grp.InFigures[i]); end; figures.Add(grp); grp.UnGrouped := false; end; uaUnGroup: begin for i := 0 to xAction.List.Count-1 do begin grp := TFigureGrp(xAction.List[i]); figures.Remove(grp); for k := 0 to grp.InFigures.Count-1 do begin figures.Add(grp.Infigures[k]); end; grp.UnGrouped := true; end; end; uaOrder: begin for i := 0 to xAction.List.Count-1 do begin xFig := TFigure(xAction.List[i]); k := Integer(xAction.RedoList[i]); t := Figures.IndexOf(xFig); Figures.Move(t,k); end; end; uaClip: begin xBmp := TBmpObject(xAction.List[0]); xFig := TFigure(xAction.Params[0]); Figures.Remove(xfig); xBmp.ClipFigure := xfig; end; uaUnClip: begin xBmp := TBmpObject(xAction.List[0]); xFig := TFigure(xAction.Params[0]); Figures.Add(xfig); xFig.Select; xBmp.ClipFigure := nil; end; uaList: TF_Cad(Owner).SCSRedoNormalList; uaDesignList, uaProjectPlan: //TF_Cad(Owner).SCSRedoDesignList; TF_Cad(Owner).SCSRedoNormalList; end; if xAction.Tag = 2 then Redo; Refresh; except // on E: Exception do AddExceptionToLog(CPowerCadMessage + 'TPCDrawing.Undo' + E.Message); end; End; Procedure TPCDrawing.KillUndoAction(xAction:TUndoAction); var k,j: integer; xFig: TFigure; s: TMemoryStream; grp: TFigureGrp; begin try // Tolik -- 08/12/2016 -- вот это все нах, правильная очистка фигур у нас раньше произойдет (* if (xAction.ActionType = uaRemove) or (xAction.ActionType = uaInsert) then begin for k := 0 to xAction.List.Count-1 do begin xFig := TFigure(xAction.List[k]); if (xAction.ActionType = uaRemove) or (Figures.IndexOf(xFig) = -1) then begin xFig.urc := xFig.urc-1; if (xFig.urc = 0) and (xFig.Deleted) and (Freed.IndexOf(xFig) = -1) then begin Freed.Add(xFig); if xFig is TFigureGrp then begin grp := xFig as TFigureGrp; for j := 0 to grp.Infigures.Count-1 do begin if Freed.IndexOf(grp.Infigures[j]) = -1 then begin Freed.Add(grp.Infigures[j]); TFigure(grp.Infigures[j]).Free; end; end; grp.ClearFigureList; end; xFig.Free; end; end; end; end else if (xAction.ActionType = uaReplace) then begin for k := 0 to xAction.List.Count-1 do begin xFig := TFigure(xAction.List[k]); xFig.urc := xFig.urc-1; if (xFig.urc = 0) and (xFig.Deleted) and (Freed.IndexOf(xFig) = -1) then begin Freed.Add(xFig); if xFig is TFigureGrp then begin grp := xFig as TFigureGrp; for j := 0 to grp.Infigures.Count-1 do begin if Freed.IndexOf(grp.Infigures[j]) = -1 then begin Freed.Add(grp.Infigures[j]); TFigure(grp.Infigures[j]).Free; end; end; end; xFig.Free; end; end; for k := 0 to xAction.Params.Count-1 do begin xFig := TFigure(xAction.Params[k]); xFig.urc := xFig.urc-1; if (xFig.urc = 0) and (xFig.Deleted) and (Freed.IndexOf(xFig) = -1) then begin Freed.Add(xFig); if xFig is TFigureGrp then begin grp := xFig as TFigureGrp; for j := 0 to grp.Infigures.Count-1 do begin if Freed.IndexOf(grp.Infigures[j]) = -1 then begin Freed.Add(grp.Infigures[j]); TFigure(grp.Infigures[j]).Free; end; end; end; xFig.Free; end; end; end else if (xAction.ActionType = uaModify) then begin for k := 0 to xAction.Params.Count-1 do begin s := TMemoryStream(xAction.Params[k]); s.free; if xAction.RedoList.Count > k then begin s := TMemoryStream(xAction.RedoList[k]); s.free; end; end; end else if (xAction.ActionType = uaGroup) or (xAction.ActionType = uaUnGroup) then begin for k := 0 to xAction.List.Count-1 do begin grp := TFigureGrp(xAction.List[k]); if (grp.UnGrouped) and (Freed.IndexOf(grp) = -1) then begin Freed.Add(grp); grp.DestroyGrp; end; end; end; *) finally // ShowMessage(CPowerCadMessage + 'TPCDrawing.KillUndoAction'); xAction.List.Clear; xAction.Free; end; end; Procedure TPCDrawing.ClearUndoList; var xAction: TUndoAction; i: integer; begin try for i := 0 to FUndoList.Count-1 do begin xAction := TUndoAction(FUndoList[i]); KillUndoAction(xAction); end; FUndoList.Clear; Freed.Clear; FUndoIdx := 0; except // on E: Exception do AddExceptionToLog(CPowerCadMessage + 'TPCDrawing.ClearUndoList' + E.Message); end; end; Procedure TPCDrawing.Draw; // Tolik -- 22/12/2016-- var CAdRefreshFlagChanged : Boolean; begin // Tolik -- 22/12/2016 -- if not GCanRefreshCad then exit; try // TempBitmap.PixelFormat := pf4bit; // TempBitmap.HandleType := bmDIB; // BaseBitmap.PixelFormat := pf4bit; // BaseBitmap.HandleType := bmDIB; except end; GCanRefreshCad := False; // try SetBufferEngine; DrawFigures(FRangeCheck); SetBufferDetailEngine; ClipToDetailRegion(TempBitmap.Canvas); DrawDetail; UnClip(TempBitmap.Canvas); except on E: Exception do; end; // Tolik GCanRefreshCad := True; // //SetBufferEngine; //22.08.2012 end; Procedure GetCorrectlyPOints(aCabinet: TFigure; var aParr:TDoublepointArr); var i: integer; begin try if Length(aParr) <> 0 then SetLength(aParr,0); SetLength(aParr,aCabinet.PointCount); for i := 0 to aCabinet.PointCount - 1 do begin aParr[i] := aCabinet.ActualPoints[i+1]; end; except end; end; Function CheckByIntersectionInCabinetExt(ACabinet, aTracefigure: TFigure): boolean; var i: integer; p: TDoublePoint; begin try result := false; for i := 0 to ACAbinet.PointCount - 1 do begin if (i+1) <> ACAbinet.PointCount then begin if GetIntersectionPoint(aTraceFigure.ActualPoints[1], aTraceFigure.ActualPoints[2], aCabinet.ActualPoints[i+1], aCabinet.ActualPoints[i+2], p,false) then begin result := true; break; end; end else begin if GetIntersectionPoint(aTraceFigure.ActualPoints[1], aTraceFigure.ActualPoints[2], aCabinet.ActualPoints[i+1], aCabinet.ActualPoints[1], p,false) then begin result := true; break; end; end; end; except end; end; Function CheckOrtholineCablesOnProperty(SCSCatalog: TSCSCatalog): boolean; var i,j: integer; SCSCompon: TSCSComponent; ExistSpec_Cable: boolean; begin result := true; if SCSCatalog <> nil then begin if SCSCatalog.ComponentReferences.Count > 0 then begin for i := 0 to SCSCatalog.ComponentReferences.Count - 1 do begin ExistSpec_Cable := false; SCSCompon := SCSCatalog.ComponentReferences[i]; if CheckSysNameIsCable(SCSCompon.ComponentType.SysName) then begin for j := 0 to SCSCompon.Properties.Count - 1 do if PProperty(SCSCompon.Properties[j]).SysName = 'SPEC_CABLE' then begin ExistSpec_Cable := true; if PProperty(SCSCompon.Properties[j]).Value = '1' then begin Result := false; end else begin Result := True; break; end; end; if not ExistSpec_Cable then result := True; if result then break; end; end; end else result := false; end; end; //Проверка фигуры внутри кабинета////////////////////////////////////////////////// function TPCDrawing.CheckFigureInsideCabinet(aLFigures: TList; var aTraceFigure: TFigure; needCheckConn: boolean = false): byte; var i: Integer; aFigure: TFigure; Cabinet: TCabinet; CabinetExt: TCabinetExt; p: TDoublepoint; Parr: TDoublePointArr; z:double; SCSCatalog: TSCSCatalog; JoinedLen: integer; // Tolik 13/02/2020 -- begin result := 0; try if Owner.ClassName = 'TF_CAD' then begin aTraceFigure.InsideCabinet := False; //По умолчанию, фигура не внутри кабинета if CheckFigureByClassName(aTraceFigure, 'TConnectorObject') then //Если это... begin // Tolik 12/02/2020 -- это чтобы не выбило ошибку на подъезде дома if TConnectorObject(aTraceFigure).FisApproach then exit; // Коннекторы, установенные на углах дома -- тоже нафиг if TConnectorObject(aTraceFigure).HouseIndex <> -1 then exit; // NeedCheckConn := True; // Tolik 13/02/2020 -- if TConnectorObject(aTraceFigure).ConnectorType = ct_Clear then // Tolik 27/08/2019 -- это чтобы не "проскочил" Точечный объект, // если его вдруг нет в ПМ (битый проект) // если это коннектор прицепленный к ТО - то такого коннектора и не должно быть в ПМке begin // Tolik 13/02/2020 -- JoinedLen := length(TConnectorObject(aTraceFigure).FJoinedConnectorsIndexes); //if length(TConnectorObject(aTraceFigure).FJoinedConnectorsIndexes) > 0 then if JoinedLen > 0 then NeedCheckConn := false; end; if NeedCheckConn then SCSCatalog := F_ProjMan.GSCSBase.CurrProject.GetCatalogFromReferencesBySCSID(aTraceFigure.ID); if NeedCheckConn and (SCSCatalog = nil) then begin if TConnectorObject(aTraceFigure).ConnectorType = ct_Clear then result := 1 else result := 2; end else begin for i:= 0 to aLFigures.Count - 1 do //Проходим по всем фигурам begin aFigure := TFigure(aLFigures[i]); if CheckFigureByClassName(aFigure, 'TCabinet') then //находим кабинет begin Cabinet := TCabinet(aFigure); if Cabinet.CabinetConfig.aUnroutableArea then begin if (Cabinet.FIndex <> -1)and(GCadForm.FRemFigures.IndexOf(Cabinet) = - 1) then //У которого индекс не -1 и он не в удаленных кабинетах begin p := aTraceFigure.ActualPoints[1]; // GetCorrectlyPOints(Figure, Parr); if (Cabinet.isPointInMod(p.x, p.y))and(Cabinet.CabinetConfig.aUnroutableArea)and(Cabinet.FIndex <> -1) then begin aTraceFigure.InsideCabinet := true; //Если фигура входит в кабинет, ставим флажок break; end else aTraceFigure.InsideCabinet := False; end; end; end else if CheckFigureByClassName(aFigure, 'TCabinetExt') then //С Ext кабинетами то же самое begin Cabinetext := TCabinetExt(aFigure); if Cabinet.CabinetConfig.aUnroutableArea then begin if (Cabinetext.FIndex <> - 1)and(GCadForm.FRemFigures.IndexOf(CabinetExt) = - 1) then begin p := aTraceFigure.ActualPoints[1]; // GetCorrectlyPOints(Figure, Parr); if (Cabinetext.isPointInMod(p.x,p.y))and(Cabinetext.CabinetConfig.aUnroutableArea)and(Cabinetext.FIndex <> -1) then begin aTraceFigure.InsideCabinet := true; break; end else aTraceFigure.InsideCabinet := False; end; end; end; end; end; end else if CheckFigureByClassName(aTraceFigure, 'TOrthoLine') then begin SCSCatalog := F_ProjMan.GSCSBase.CurrProject.GetCatalogFromReferencesBySCSID(aTraceFigure.ID); //Для проверки свойств кабеля if SCSCatalog = nil then begin result := 4; end else begin for i:= 0 to aLFigures.Count - 1 do //Проходим по всем фигурам begin aFigure := TFigure(aLFigures[i]); if CheckFigureByClassName(aFigure, 'TCabinet') then begin Cabinet := TCabinet(aFigure); if Cabinet.CabinetConfig.aUnroutableArea or Cabinet.CabinetConfig.aPlenumArea then begin if (Cabinet.FIndex <> -1)and(GCadForm.FRemFigures.IndexOf(Cabinet) = - 1) then begin if (Cabinet.isPointInMod(aTraceFigure.ActualPoints[1].x, aTraceFigure.ActualPoints[1].y))and ((Cabinet.CabinetConfig.aPlenumArea)or(Cabinet.CabinetConfig.aUnroutableArea)) then begin aTraceFigure.InsideCabinet := true; if (aTraceFigure.InsideCabinet)and(not Cabinet.CabinetConfig.aUnroutableArea) then begin aTraceFigure.InsideCabinet := CheckOrtholineCablesOnProperty(SCSCatalog); end; if aTraceFigure.InsideCabinet then //Если фигура внутри кабинета, только тогда выходить из цикла break; end else if (Cabinet.isPointInMod(aTraceFigure.ActualPoints[2].x, aTraceFigure.ActualPoints[2].y))and ((Cabinet.CabinetConfig.aPlenumArea)or(Cabinet.CabinetConfig.aUnroutableArea)) then begin aTraceFigure.InsideCabinet := true; if (aTraceFigure.InsideCabinet)and(not Cabinet.CabinetConfig.aUnroutableArea) then begin aTraceFigure.InsideCabinet := CheckOrtholineCablesOnProperty(SCSCatalog); end; if aTraceFigure.InsideCabinet then break; end else if ((GetIntersectionPoint(aTraceFigure.ActualPoints[1], aTraceFigure.ActualPoints[2], Cabinet.ap1,Cabinet.AP2, p,false))or (GetIntersectionPoint(aTraceFigure.ActualPoints[1], aTraceFigure.ActualPoints[2], Cabinet.ap2,Cabinet.AP3, p,false))or (GetIntersectionPoint(aTraceFigure.ActualPoints[1], aTraceFigure.ActualPoints[2], Cabinet.ap3,Cabinet.AP4, p,false))or (GetIntersectionPoint(aTraceFigure.ActualPoints[1], aTraceFigure.ActualPoints[2], Cabinet.ap4,Cabinet.AP1, p,false)))and ((Cabinet.CabinetConfig.aPlenumArea)or(Cabinet.CabinetConfig.aUnroutableArea)) then begin aTraceFigure.InsideCabinet := true; if (aTraceFigure.InsideCabinet)and(not Cabinet.CabinetConfig.aUnroutableArea) then begin aTraceFigure.InsideCabinet := CheckOrtholineCablesOnProperty(SCSCatalog); end; if aTraceFigure.InsideCabinet then break; end else aTraceFigure.InsideCabinet := False; end; end; end else if CheckFigureByClassName(aFigure, 'TCabinetExt') then begin CabinetExt := TCabinetext(aFigure); if Cabinet.CabinetConfig.aUnroutableArea or Cabinet.CabinetConfig.aPlenumArea then begin if (Cabinetext.FIndex <> -1)and(GCadForm.FRemFigures.IndexOf(CabinetExt) = - 1) then begin if (CabinetExt.isPointInMod(aTraceFigure.ActualPoints[1].x, aTraceFigure.ActualPoints[1].y))and ((CabinetExt.CabinetConfig.aPlenumArea)or(CabinetExt.CabinetConfig.aUnroutableArea)) then begin aTraceFigure.InsideCabinet := true; if (aTraceFigure.InsideCabinet)and(not CabinetExt.CabinetConfig.aUnroutableArea) then begin aTraceFigure.InsideCabinet := CheckOrtholineCablesOnProperty(SCSCatalog); end; if aTraceFigure.InsideCabinet then break; end else if (CabinetExt.isPointInMod(aTraceFigure.ActualPoints[2].x, aTraceFigure.ActualPoints[2].y))and ((CabinetExt.CabinetConfig.aPlenumArea)or(CabinetExt.CabinetConfig.aUnroutableArea)) then begin aTraceFigure.InsideCabinet := true; if (aTraceFigure.InsideCabinet)and(not CabinetExt.CabinetConfig.aUnroutableArea) then begin aTraceFigure.InsideCabinet := CheckOrtholineCablesOnProperty(SCSCatalog); end; if aTraceFigure.InsideCabinet then break; end else //Так как это кабинет Ext,то у него может быть куча граней, потому внутри этого метода //проверяются все грани))))) if (CheckByIntersectionInCabinetExt(aFigure, aTraceFigure))and ((CabinetExt.CabinetConfig.aPlenumArea)or(CabinetExt.CabinetConfig.aUnroutableArea)) then begin aTraceFigure.InsideCabinet := true; if (aTraceFigure.InsideCabinet)and(not CabinetExt.CabinetConfig.aUnroutableArea) then begin aTraceFigure.InsideCabinet := CheckOrtholineCablesOnProperty(SCSCatalog); end; if aTraceFigure.InsideCabinet then break; end else aTraceFigure.InsideCabinet := False; end; end; end; end; end; end; end; except end end; Procedure TPCDrawing.DrawFigures(OnlyVisibles:Boolean); var a, i: integer; Figure : TFigure; Layer : TLayer; isDraw,isFlue: Boolean; unreg: string; xFont: TFont; nh,nl:Integer; vRect: TDoubleRect; frect: TDoubleRect; cReg:HRGN; // Tolik 28/08/2019 -- эти переменные юзаются для GetTickCount, но она возвращает число типа Dword, которое // не помещается в cardinal, поэтому возникает математическое переполнение ... //OldTick, CurrTick: Cardinal; OldTick, CurrTick: DWord; // SLayers: TRapList; TmpRect: TRect; pmc: PPROCESS_MEMORY_COUNTERS; cb: Integer; // Tolik -- 14/09/2017 -- FigMinX, FigMinY, FigMaxX, FigMaxY: double; // если есть автосозданные фигуры в фигуре отрисовки - не выставлять флажок, чтобы // границы такого объекта пересчитывались постоянно function CheckisAutoFigureIn(aFigure: TFigureGrp): Boolean; var i: Integer; begin Result := False; for i := 0 to aFigure.Infigures.Count - 1 do begin if not TFigure(aFigure.InFigures[i]).deleted then begin if not TFigure(aFigure.InFigures[i]).deleted then begin if TFigure(aFigure.InFigures[i]) is TFigureGrp then Result := CheckisAutoFigureIn(TFigureGrp(aFigure.InFigures[i])) else if (TFigure(aFigure.InFigures[i]).isAutoCreatedFigure = bitrue) then Result := True; end; end; if Result then exit; end; end; // begin isDrawingFigures := True; try Figures.Pack; //Tolik 04/01/2022 if FUpdateCount = 0 then begin //GProcCnt := 0; OldTick := GetTickCount; //SLayers := TRapList.Create; //for a := 0 to Layers.Count - 1 do // InsertValueToSortetRapList(TLayer(Layers[a]), SLayers); Dengine.CachePen := true; //01.11.2011 Dengine.ClearPens; //01.11.2011 Dengine.DefinePrinting; //01.11.2011 vRect := GetVisibleRect; a := 0; while a < Figures.count do begin //Tolik try // try Figure := TFigure(Figures[a]); //Tolik //if Figure.ID <> -1 then if (Figure.ID <> -1) and (not Figure.Deleted) then // 31/10/2015 begin // isDraw := Figure.Visible and (not Figure.InClip); isFlue := False; if (Figure.LayerHandle > 0) and Figure.Visible and (not Figure.InClip) then begin Layer := TLayer(Figure.LayerHandle); {//31.10.2011} if Layers.IndexOf(Layer) > -1 then //if GetValueIndexFromSortedRapList(Layer, SLayers) > -1 then begin isDraw := (Layer.visible <> lost); isFlue := (Layer.visible = grayed); end; end; if isDraw then begin if Figure is TfigureGrpMod then begin //if CheckisAutoFigureIn(TFigureGrp(Figure)) then if TFigureGrpMod(Figure).HasAutocreatedFigures then begin TFigureGrp(fiGure).GetBoundsWithAutoCreatedFigures(FigMaxX, FigMaxY, FigMinX, FigMinY); frect := DoubleRect(FigMinX, FigMinY, FigMaxX, FigMaxY); end else begin if Figure.FIsLoadedBounds then frect := Figure.FBoundRect else begin fRect := fiGure.GetBoundRect; Figure.FBoundRect := fRect; Figure.FIsLoadedBounds := true; end; end end else begin if Figure.FIsLoadedBounds then frect := Figure.FBoundRect else begin fRect := fiGure.GetBoundRect; Figure.FBoundRect := fRect; Figure.FIsLoadedBounds := true; end; end; //31.10.2011 }isDraw := isDraw and ((not onlyVisibles) or (OnlyVisibles and RectOverlaps(vRect,fRect))); isDraw := isDraw and ((not onlyVisibles) or (OnlyVisibles and OverlapDoubleRects(vRect,fRect) )); // test - OverlapDoubleRects //if a = 0 then //begin // OldTick := GetTickCount; // for i := 0 to 1000000 do // RectOverlaps(vRect,fRect); // CurrTick := GetTickCount - OldTick; // CurrTick := GetTickCount - OldTick; // OldTick := GetTickCount; // for i := 0 to 1000000 do // OverlapDoubleRects(vRect,fRect); // CurrTick := GetTickCount - OldTick; // CurrTick := GetTickCount - OldTick; //end; end; if (isDraw)(* or (Figure is TFigureGrp))*) then begin Figure.Draw(Dengine,isflue); Figure.DrawDimLines(DEngine,isFlue); end; end; finally inc(a); end; //Tolik except on E: Exception do begin AddExceptionToLog(CPowerCadMessage + 'TPCDrawing.DrawFigures ' + E.Message); // Tolik -- 19/07/2017 -- cb := SizeOf(_PROCESS_MEMORY_COUNTERS); GetMem(pmc, cb); pmc^.cb := cb; if GetProcessMemoryInfo(GetCurrentProcess(), pmc, cb) then begin AddExceptionToLog('WORK MEM : ' + IntToStr(pmc^.WorkingSetSize) + ' KBytes'); AddExceptionToLog('VIRT MEM : ' + IntToStr(pmc^.PageFileUsage) + ' KBytes'); // Label1.Caption := IntToStr(pmc^.WorkingSetSize) + ' Bytes' end; //else // Label1.Caption := 'Unable to retrieve memory usage structure'; FreeMem(pmc); // end; end; // end; Dengine.CachePen := false; Dengine.ClearPens; {$ifdef unregistered} Unreg := ''; For a:= 1 to 30 do begin UnReg := Unreg + chr(regChars[a]); end; DEngine.Canvas.Font.Name := 'Arial'; DEngine.Canvas.Font.Color := clBlack; DEngine.Canvas.Font.Size := 16; Dengine.Canvas.Brush.Style := bsClear; DEngine.Canvas.TextOut(30,30,Unreg); {$endif unregistered} //SLayers.Free; CurrTick := GetTickCount - OldTick; CurrTick := GetTickCount - OldTick; end; except on E: Exception do AddExceptionToLog('TPCDrawing.DrawFigures' + E.Message); end; isDrawingFigures := False; end; procedure TPCDrawing.TestListFigures(aCheckOverlap: Boolean); var a, i: integer; Figure : TFigure; Layer : TLayer; isDraw,isFlue: Boolean; unreg: string; xFont: TFont; nh,nl:Integer; vRect: TDoubleRect; frect: TDoubleRect; cReg:HRGN; // Tolik 28/08/2019 -- //OldTick, CurrTick: Cardinal; OldTick, CurrTick: DWord; // SLayers: TRapList; TmpRect: TRect; OnlyVisibles: Boolean; begin if FUpdateCount = 0 then begin //GProcCnt := 0; OnlyVisibles := true; OldTick := GetTickCount; Dengine.CachePen := true; //01.11.2011 Dengine.ClearPens; //01.11.2011 Dengine.DefinePrinting; //01.11.2011 vRect := GetVisibleRect; a := 0; while a < Figures.count do begin try Figure := TFigure(Figures[a]); isDraw := Figure.Visible and (not Figure.InClip); isFlue := False; if (Figure.LayerHandle > 0) and Figure.Visible and (not Figure.InClip) then begin Layer := TLayer(Figure.LayerHandle); {//31.10.2011} if Layers.IndexOf(Layer) > -1 then begin isDraw := (Layer.visible <> lost); isFlue := (Layer.visible = grayed); end; end; if isDraw then begin if Figure.FIsLoadedBounds then frect := Figure.FBoundRect else begin fRect := fiGure.GetBoundRect; Figure.FBoundRect := fRect; Figure.FIsLoadedBounds := true; end; if aCheckOverlap then isDraw := isDraw and ((not onlyVisibles) or (OnlyVisibles and OverlapDoubleRects(vRect,fRect) )); end; finally inc(a); end; end; Dengine.CachePen := false; Dengine.ClearPens; {$ifdef unregistered} Unreg := ''; For a:= 1 to 30 do begin UnReg := Unreg + chr(regChars[a]); end; DEngine.Canvas.Font.Name := 'Arial'; DEngine.Canvas.Font.Color := clBlack; DEngine.Canvas.Font.Size := 16; Dengine.Canvas.Brush.Style := bsClear; DEngine.Canvas.TextOut(30,30,Unreg); {$endif unregistered} //SLayers.Free; CurrTick := GetTickCount - OldTick; CurrTick := GetTickCount - OldTick; end; end; Procedure TPCDrawing.DrawSubstrateFigures(OnlyVisibles:Boolean); var a: integer; Figure : TFigure; Layer : TLayer; isDraw,isFlue: Boolean; unreg: string; xFont: TFont; nh,nl:Integer; vRect: TDoubleRect; frect: TDoubleRect; cReg:HRGN; begin vRect := GetVisibleRect; a := 0; while a < Figures.count do begin try Figure := TFigure(Figures[a]); isDraw := Figure.Visible and (not Figure.InClip); isFlue := False; if (Figure.LayerHandle > 0) and Figure.Visible and (not Figure.InClip) then begin Layer := TLayer(Figure.LayerHandle); if (Layers.IndexOf(Layer) = 1) or (Layers.IndexOf(Layer) = 8) or (Layer.IsDxf) then begin isDraw := (Layer.visible <> lost); isFlue := (Layer.visible = grayed); end else isDraw := False; end; if isDraw then begin fRect := fiGure.GetBoundRect; isDraw := isDraw and ((not onlyVisibles) or (OnlyVisibles and RectOverlaps(vRect,fRect))); end; if (isDraw)(* or (Figure is TFigureGrp))*) then begin Figure.Draw(Dengine,isflue); Figure.DrawDimLines(DEngine,isFlue); end; finally inc(a); end; end; end; Procedure TPCDrawing.ClearFaces; var i: Integer; face: TfaceRecord; begin try for i := 0 to Faces.Count-1 do begin Face := TFaceRecord(faces[i]); Face.Free; end; Faces.Clear; except on E: Exception do AddExceptionToLog(CPowerCadMessage + 'TPCDrawing.ClearFaces' + E.Message); end; end; Procedure TPCDrawing.CollectFaces; var {//04.01.2012 - Перенос в CollectFacesFromFigures isDraw,isFlue:Boolean; i,k: Integer; Layer: TLayer; Figure: TFigure; face: TfaceRecord; pCnt: Integer; p: T3dPoint; xRoom: T3DRoom; NeedAdd: boolean;} // 22.07.2011 xNets, xScsObjects: TList; procedure CollectFacesFromFigures(AFigures: TList); var isDraw,isFlue:Boolean; i,k: Integer; Layer: TLayer; Figure: TFigure; face: TfaceRecord; pCnt: Integer; p: T3dPoint; xRoom: T3DRoom; NeedAdd: boolean; begin For i := 0 to AFigures.count - 1 do begin try Figure := TFigure(AFigures[i]); isDraw := True; isFlue := False; if Figure.LayerHandle > 0 then begin Layer := TLayer(Figure.LayerHandle); isDraw := (Layer.visible <> lost); isFlue := (Layer.visible = grayed); end; if (isDraw or (Figure is TFigureGrp)) then begin if Figure is TNet then begin // Tolik 15/06/2018 -- NeedAdd := True; {NeedAdd := False; if TNet(Figure).FComponID <> 0 then NeedAdd := True;} // {$if Not Defined(ES_GRAPH_SC)} //Tolik -- 15/06/2018 -- { if NeedAdd then if GetArchObjByCADObj(TNet(Figure)).IsLine = ctArhRoofSeg then NeedAdd := False;} {$ifend} if NeedAdd and (TNet(Figure).Paths.Count > 0) then begin xNets.Add(Figure); //xRoom := T3DRoom.Create(Faces, TNet(Figure), xModel); //xModel.FRooms.Add(xRoom); end; end else if Figure is TFigureGrp then begin CollectFacesFromFigures(TFigureGrp(Figure).InFigures); //04.01.2012 end else begin // 22.07.2011 //Figure.CollectFaces(Faces); if Figure.Name = 'Anchor' then Figure.CollectFaces(Faces) else begin //xScsObjects.Add(Figure); //Figure.CollectFaces(Faces); //04.01.2012 xScsObjects.Add(Figure); //04.01.2012 - test if (Figure.ClassName = 'TConnectorObject') then begin //if (TConnectorObject(Figure).ConnectorType <> ct_Clear) then //if TConnectorObject(Figure).FTrunkName = '' then xScsObjects.Add(Figure); end else if Figure.ClassName = TOrthoLine.ClassName then begin xScsObjects.Add(Figure); end; end; end; if assigned(FOnCollectFigureFaces) then FOnCollectFigureFaces(Self,Figure,Faces); end; except end; end; end; begin xNets := TList.create; xScsObjects := TList.create; ClearFaces; CollectFacesFromFigures(Figures); (* For i := 0 to Figures.count - 1 do begin try Figure := TFigure(Figures[i]); isDraw := True; isFlue := False; if Figure.LayerHandle > 0 then begin Layer := TLayer(Figure.LayerHandle); isDraw := (Layer.visible <> lost); isFlue := (Layer.visible = grayed); end; if (isDraw or (Figure is TFigureGrp)) then begin if Figure is TNet then begin NeedAdd := False; if TNet(Figure).FComponID <> 0 then NeedAdd := True; {$if Defined(FINAL_SCS)} if NeedAdd then if GetArchObjByCADObj(TNet(Figure)).IsLine = ctArhRoofSeg then NeedAdd := False; {$ifend} if NeedAdd and (TNet(Figure).Paths.Count > 0) then begin xNets.Add(Figure); //xRoom := T3DRoom.Create(Faces, TNet(Figure), xModel); //xModel.FRooms.Add(xRoom); end; end else begin // 22.07.2011 //Figure.CollectFaces(Faces); if Figure.Name = 'Anchor' then Figure.CollectFaces(Faces) else begin xScsObjects.Add(Figure); end; end; if assigned(FOnCollectFigureFaces) then FOnCollectFigureFaces(Self,Figure,Faces); end; except end; end;*) // 22.07.2011 {$ifdef 3D} frm3D.F3DModel.CollectModel(Faces, xNets); frm3D.F3DModel.CollectScsModel(Faces, xScsObjects); {$endif 3D} // 22.07.2011 if assigned(FOnCollectFaces) then FOnCollectFaces(Self,Faces); // Tolik -- 23/03/2017 -- xNets.Free; xScsObjects.Free; // end; function TPCDrawing.GetFacadeArea(AResInM: Boolean): Double; // AResInM - результат в метрах var isDraw,isFlue:Boolean; i,j,k,l: Integer; Layer: TLayer; Figure: TFigure; face: TfaceRecord; pCnt: Integer; p: T3dPoint; xModel: T3DModel; xRoom: T3DRoom; xWall: T3DWall; xSide: T3DSide; DoublePointArr: TDoublePointArr; PointCnt: Integer; FaceNames: TStringList; function Normalize3DFace(var APoints: T3DPointArray): T3DPointArray; //var //a1, a2: begin end; begin Result := 0; GCurrentRoom3DView := nil; ClearFaces; FaceNames := TStringList.Create; xModel := T3DModel.Create; For i := 0 to Figures.count - 1 do begin try Figure := TFigure(Figures[i]); if Figure is TNet then begin if TNet(Figure).Paths.Count > 0 then begin xRoom := T3DRoom.Create(Faces, TNet(Figure), xModel); xModel.FRooms.Add(xRoom); end; end; except end; end; for i := 0 to xModel.FRooms.Count - 1 do begin xRoom := T3DRoom(xModel.FRooms[i]); for j := 0 to xRoom.FWalls.Count - 1 do begin xWall := T3DWall(xRoom.FWalls[j]); for k := 0 to xWall.FSides.Count - 1 do begin xSide := T3DSide(xWall.FSides[k]); if (xSide.FFaceType = ftNetPath) and (xSide.FWallType = fwtOuter) and (xSide.FSideType in [wstLeft, wstRight]) then begin PointCnt := Length(xSide.FPoints); //if PointCnt > 0 then // begin // SetLength(DoublePointArr, PointCnt+1); // for l := 0 to PointCnt do // begin // DoublePointArr[l].x := xSide.FPoints[l].x; // // Поскольку грани вертикальные, то координата Y для всех точек одинакова // DoublePointArr[l].y := xSide.FPoints[l].z; // end; // DoublePointArr[PointCnt] := DoublePointArr[0]; // Result := Result + GetAreaFromPolygon(DoublePointArr); // SetLength(DoublePointArr, 0); // end; if PointCnt = 4 then begin Result := Result + GetTriangleArea3D(xSide.FPoints[0], xSide.FPoints[1], xSide.FPoints[2])+ GetTriangleArea3D(xSide.FPoints[2], xSide.FPoints[3], xSide.FPoints[0]); FaceNames.Add(xWall.FName +'.'+ xSide.FName); end; end; end; end; end; FreeAndNil(xModel); if AResInM then Result := Result * sqr(MapScale / 1000); FaceNames.Free; end; Procedure TPCDrawing.DrawFaces; var i,k:Integer; face: TfaceRecord; pArr:TdoublePointArr; rgn: HRGN; unreg:String; begin for i := 0 to Faces.Count-1 do begin Face := TFaceRecord(faces[i]); SetLength(pArr,Length(Face.Points)); for k := 0 to Length(pArr)-1 do pArr[k] := Convert3DPoint(Face.Points[k]); //LocateIsometricArray(pArr); rgn := 1; DEngine.drawpolygon(pArr,clBlack,1,ord(psSolid),Face.color,ord(bsSolid),rgn); end; {$ifdef unregistered} Unreg := ''; For i:= 1 to 30 do begin UnReg := Unreg + chr(regChars[i]); end; DEngine.Canvas.Font.Name := 'Arial'; DEngine.Canvas.Font.Color := clBlack; DEngine.Canvas.Font.Size := 16; Dengine.Canvas.Brush.Style := bsClear; DEngine.Canvas.TextOut(30,30,Unreg); {$endif unregistered} end; Procedure TPCDrawing.DrawSelectedFigures; var a: integer; Figure : TFigure; Layer : TLayer; isDraw,isFlue: Boolean; unreg: string; xFont: TFont; nh,nl: Integer; begin For a := 0 to Figures.count-1 do begin Figure := TFigure(Figures[a]); isDraw := True; isFlue := False; if Figure.LayerHandle > 0 then begin Layer := TLayer(Figure.LayerHandle); isDraw := (Layer.visible <> lost); isFlue := (Layer.visible = grayed); end; if ((isDraw or (Figure is TFigureGrp)) and (Figure.Selected)) and (not Figure.InClip) then begin Figure.ResetRegion; Figure.draw(Dengine,isflue); Figure.DrawDimLines(Dengine,isFlue); Figure.ResetRegion; end; end; {$ifdef unregistered} Unreg := ''; For a:= 1 to 30 do begin UnReg := Unreg + chr(regChars[a]); end; DEngine.Canvas.Font.Name := 'Arial'; DEngine.Canvas.Font.Color := clBlack; DEngine.Canvas.Font.Size := 16; DEngine.Canvas.TextOut(30,30,Unreg); {$endif unregistered} end; Procedure TPCDrawing.DrawSelectionPoints; var a: integer; Figure : TFigure; Layer : TLayer; LInfo: TLayerInfo; isDraw,isFlue: Boolean; begin if FDetail then begin SetBufferDetailEngine; ClipToDetailRegion(TempBitmap.Canvas); For a := 0 to Figures.count - 1 do begin Figure := TFigure(Figures[a]); // Tolik 26/10/2015 if not Figure.Deleted then begin // isDraw := True; isFlue := False; if Figure.LayerHandle > 0 then begin Layer := TLayer(Figure.LayerHandle); isDraw := (Layer.visible <> Lost); isFlue := (Layer.visible = grayed); end; if (isDraw and Figure.Selected) then begin Figure.IsDrawingDetail := True; Figure.drawselectionpoints(Dengine,isFlue); Figure.IsDrawingDetail := False; end; end; end; UnClip(TempBitmap.Canvas); end; SetBufferEngine; ClipToActiveRegion(TempBitmap.Canvas); For a := 0 to Figures.count - 1 do begin Figure := TFigure(Figures[a]); // Tolik 26/10/2015 if not Figure.Deleted then begin // isDraw := True; isFlue := False; if Figure.LayerHandle > 0 then begin try Layer := TLayer(Figure.LayerHandle); except on E: Exception do AddExceptionToLog(CPowerCadMessage + 'TPCDrawing.DrawSelectionPoints' + E.Message); end; isDraw := (Layer.visible <> Lost); isFlue := (Layer.visible = grayed); end; if (isDraw and Figure.Selected) then Figure.drawselectionpoints(Dengine,isFlue); end; end; UnClip(TempBitmap.Canvas); end; Procedure TPCDrawing.DrawFigureGuides; var a: integer; Figure : TFigure; Layer : TLayer; LInfo: TLayerInfo; isDraw,isFlue: Boolean; begin if not FFigureGuides then exit; if FDetail then begin ClipToDetailRegion(TempBitmap.Canvas); SetEngine(TempBitmap.Canvas,DetConvertXY,DetDeConvertXY,DetConvertDim,DetDeConvertDim,false,nil); For a := 0 to Figures.count-1 do begin Figure := TFigure(Figures[a]); isDraw := True; isFlue := False; if Figure.LayerHandle > 0 then begin Layer := TLayer(Figure.LayerHandle); isDraw := (Layer.visible <> lost); isFlue := (Layer.visible = grayed); end; if isDraw and (Figure.inClip = False) then Figure.DrawFigureGuidesInDetail(Dengine,DetailStyle); end; UnClip(TempBitmap.Canvas); end; SetEngine(TempBitmap.Canvas,ConvertXY,DeConvertXY,ConvertDim,DeConvertDim,false,nil); ClipToActiveRegion(TempBitmap.Canvas); try For a := 0 to Figures.count-1 do begin Figure := TFigure(Figures[a]); isDraw := True;isFlue := False; if Figure.LayerHandle > 0 then begin Layer := TLayer(Figure.LayerHandle); isDraw := (Layer.visible <> lost); isFlue := (Layer.visible = grayed); end; if isDraw then Figure.DrawFigureGuides(Dengine); end; {Mityai} //D0000006303 //Проверка при перемещении объектов, чтоб не пропадала топовая направляющая//// //if Assigned(GCadForm) then // if GuidesVisible then // DrawGuidesTop(DEngine.Canvas); // except end; UnClip(TempBitmap.Canvas); end; Procedure TPCDrawing.ManualRefresh; Begin DoSurfacePaint(surface); End; Function TPCDrawing.GetSurfaceBitmap:Tbitmap; begin result := TempBitmap; end; Function TPCDrawing.GetSurfaceBitmapHandle:Integer; Begin result := TempBitmap.Handle; End; Procedure TPCDrawing.Refresh; var xCanvas: TCanvas; begin GisCadRefresh := True; try // Tolik 18/02/2018 -- if not GCanRefreshCad then exit; // if AutoRefresh then begin //GCadForm.GWallTracePointList.Clear; // Tolik 17/01/2021 - - DoSurfacePaint(surface); DoSelChange; //Tolik 17/01/2022 { if Assigned(TraceFigure) then begin if traceFigure is TwallPath then begin TWallPath(TraceFigure).ShadowTrace(TWallPath(TraceFigure).PointCount, GCurrMousePos.x, GCurrMousePos.y); end; end; } end; except // TODO - на 2.3.0 было закоменчено, пока оставим тоже закоменченным // on E: Exception do AddExceptionToLog(CPowerCadMessage + 'TPCDrawing.Refresh' + E.Message); end; //Tolik 26/08/2021 -- сбросить описание выбранной фигуры в статус баре (если, например, удалили все или еще чего) if Selection.Count = 0 then begin if Assigned(Owner) then begin if Owner is TF_CAD then begin if Assigned(TF_Cad(Owner).sbView) then TF_Cad(Owner).sbView.Panels[2].Text := ''; TF_Cad(Owner).ShowHideButtons; // Tolik 27/01/2022 - - end; end; end; // GisCadRefresh := False; end; Procedure TPCDrawing.RefreshSelection; var a,i: integer; Layer : TLayer; istyle: Integer; bStyle: Byte; color: TColor; aFont:TFont; txFont: String; pc,txCharset: Byte; txSize: Double; txRatio: Double; txBold,txItalic,txUnderline,txStrike: Byte; hasBool: Boolean; begin //Tolik try FSelection.Clear; SetEngine(TempBitmap.Canvas,ConvertXY,DeConvertXY,ConvertDim,DeConvertDim,false,nil); Reselect; drawselectionpoints; collectSelectedFigures(FSelection); istyle := GetSlcBrushStyle; if iStyle = -1 then bstyle := ord(fdefBrsStyle) else bStyle := istyle; if bStyle in [bsExHatch,bsExGrad,bsExTexture] then bStyle := 8; evBrushStyle.RaiseEvent(bStyle,'',0); istyle := GetSlcPenStyle; if iStyle = -1 then bstyle := ord(fdefPenStyle) else bStyle := istyle; evPenStyle.RaiseEvent(bStyle,'',0); istyle := GetSlcPenWidth-1; if iStyle < 0 then bstyle := fdefPenWidth-1 else bStyle := istyle; evPenWidth.RaiseEvent(bStyle,'',0); istyle := GetSlcRowStyle; if iStyle = -1 then bstyle := ord(fdefRowStyle) else bStyle := istyle; evRowStyle.RaiseEvent(bStyle,'',0); color := GetSlcPenColor; if color = -1 then color := fdefPenColor; evPenColor.RaiseEvent(Color,'',0); color := GetSlcBrushColor; if color = -1 then color := fdefBrsColor; evBrushColor.RaiseEvent(Color,'',0); aFont := nil; aFont := GetSlcFont; if not assigned(aFont) then aFont := Font; color := aFont.Color;evTextColor.RaiseEvent(Color,'',0); txFont := aFont.Name;evTextFont.RaiseEvent(0,txFont,0); txSize := GetSlcFontSize; if txSize <= 0 then txSize := 80; evTextSize.RaiseEvent(txSize); txCharSet := 0; for i := 0 to 17 do if aFont.Charset = csArray[i] then txCharSet := i; evTextCharSet.RaiseEvent(txCharSet); txBold := 0; if fsBold in aFont.Style then txBold := 1; evTextBold.RaiseEvent(txBold,'',0); txItalic := 0; if fsItalic in aFont.Style then txItalic := 1; evTextItalic.RaiseEvent(txItalic,'',0); txUnderline := 0; if fsUnderline in aFont.Style then txUnderline := 1; evTextUnderline.RaiseEvent(txUnderline,'',0); txStrike := 0; if fsStrikeOut in aFont.Style then txStrike := 1; evTextStrike.RaiseEvent(txStrike,'',0); pc := 0; if GetSlcPolyLineClosed = True then pc := 1; evPLineClosed.RaiseEvent(pc); if SlcBitmapCnt = 0 then begin evTransparent.EnableEvent(false); evClipped.EnableEvent(false); evBmpSel.EnableEvent(false); end else begin pc := 0; if GetSlcImageTransparent = True then pc := 1; evTransparent.RaiseEvent(pc); pc := 0; if GetSlcImageClipped = True then pc := 1; evClipped.RaiseEvent(pc); evBmpSel.EnableEvent(true); end; if (SlcLineCnt = 0) and (slcPlineCnt = 0) then begin evBounded.EnableEvent(false); end else begin pc := 0; if GetSlcLineBounded = True then pc := 1; evBounded.RaiseEvent(pc); end; pc := ord(GetSlcArcStyle);evArcStyle.RaiseEvent(pc); if slcArcCnt = 0 then begin evArcSel.EnableEvent(False); end else begin evArcSel.EnableEvent(True); end; if (SlcLineCnt = 0) then begin evLineSel.EnableEvent(false); end else begin evLineSel.EnableEvent(true); end; if (SlcPLineCnt = 0) then begin evPLineSel.EnableEvent(false); end else begin evPLineSel.EnableEvent(true); end; if (SlcGroupCnt = 0) then begin evGroupSel.EnableEvent(false); end else begin evGroupSel.EnableEvent(true); end; if (FSelection.Count = 0) then begin evAnySel.EnableEvent(false); end else begin evAnySel.EnableEvent(true); end; except on E: Exception do AddExceptionToLog('TPCDrawing.RefreshSelection!!! ' + E.Message); end; end; //Tolik 26/11/2021 -- старая закомменчена - см ниже, здесь - немножко оптимизирвано Procedure TPCDrawing.CollectSelectionOrder(var Selecteds:TList); var a:integer; f, fs: Tfigure; ord, i: Integer; inserted: Boolean; begin if not assigned(selecteds) then exit; Selecteds.Clear; for a := 0 to figures.count - 1 do begin if TFigure(figures[a]).Selected then begin //f := figures[a]; f := TFigure(figures[a]); ord := f.SelOrder; if Selecteds.Count = 0 then Selecteds.Add(f) else begin i := 0; inserted := false; repeat fs := TFigure(Selecteds[i]); if ord < fs.SelOrder then begin Selecteds.Insert(i,f); inserted := true; i := Selecteds.Count; end else inc(i); until i = Selecteds.Count; if not inserted then Selecteds.Add(f); end; end; end; end; (* Procedure TPCDrawing.CollectSelectionOrder(var Selecteds:TList); var a:integer; f, fs: Tfigure; ord, i: Integer; inserted, done: Boolean; begin if not assigned(selecteds) then exit; Selecteds.Clear; for a := 0 to figures.count - 1 do begin if TFigure(figures[a]).Selected then begin //f := figures[a]; f := TFigure(figures[a]); ord := f.SelOrder; if Selecteds.Count = 0 then Selecteds.Add(f) else begin i := 0; done := false; inserted := false; repeat fs := Selecteds[i]; if ord < fs.SelOrder then begin Selecteds.Insert(i,f); done := True; inserted := true; end; i := i+1; if i = selecteds.Count then done := true; until done; if not inserted then Selecteds.Add(f); end; end; end; end; *) Procedure TPCDrawing.collectSelectedFigures(var Selecteds:TList); var a:integer; f: Tfigure; begin if not assigned(selecteds) then exit; SlcBitmapCnt := 0; SlcLineCnt := 0; SlcPlineCnt := 0; SlcArcCnt := 0; SlcCircleCnt := 0; SlcEllipseCnt := 0; SlcVertexCnt := 0; SlcGroupCnt := 0; SlcRectangleCnt:= 0; SlcDimCnt := 0; for a := 0 to figures.count - 1 do // Tolik 25/10/2015 --- ибо нех удаленные фигуры снова выбирать // if TFigure(figures[a]).Selected then if TFigure(figures[a]).Selected and (not TFigure(figures[a]).Deleted) then // begin //f := figures[a]; f := TFigure(figures[a]); Selecteds.add(figures[a]); //Tolik 26/11/2021 -- чуть ускорить и здесь ... { if f is TbmpObject then inc(SlcBitmapCnt); if f is DrawObjects.TLine then inc(SlcLineCnt); if f is TPolyline then inc(SlcPlineCnt); if f is TArc then inc(SlcArcCnt); if f is TCircle then inc(SlcCircleCnt); if f is TEllipse then inc(SlcEllipseCnt); if f is DrawObjects.TRectangle then inc(SlcRectangleCnt); if f is TVertex then inc(SlcVertexCnt); if f is TFigureGrp then inc(SlcGroupCnt); if f is TDimLine then inc(SlcDimCnt); } if f is TbmpObject then inc(SlcBitmapCnt) else //Tolik 17/02/2022 -- //if f is DrawObjects.TLine then if f.ClassName = 'TLine' then // inc(SlcLineCnt) else if f is TPolyline then inc(SlcPlineCnt) else if f is TArc then inc(SlcArcCnt) else if f is TCircle then inc(SlcCircleCnt) else if f is TEllipse then inc(SlcEllipseCnt) else if f is DrawObjects.TRectangle then inc(SlcRectangleCnt) else if f is TVertex then inc(SlcVertexCnt) else if f is TFigureGrp then inc(SlcGroupCnt) else if f is TDimLine then inc(SlcDimCnt); end; end; procedure TPCDrawing.reselect; var a,k: integer; Figure : TFigure; begin //Tolik 26/11/2021 -- это вытащил с условий ниже, т.к. по нему все равно ничего не происходит, //чтобы впустую не колотило и работало быстрее ... if (TraceFigure <> nil) and (GCadForm.PCad.ModPoint <> nil) then exit; // {//02.04.2012 for a := 0 to figures.count-1 do begin Figure := TFigure(Figures[a]); if Figure.selected then begin Figure.Reselect; end; end;} //02.04.2012 if figures.count > 0 then begin BeginMultiDeselect; //02.04.2012 try for a := 0 to figures.count-1 do begin Figure := TFigure(Figures[a]); // Tolik if (Assigned(Figure) and (not Figure.Deleted)) then begin // if Figure.selected then begin // commented by Tolik 26/11/2021 -- //if (TraceFigure <> nil) and (GCadForm.PCad.ModPoint <> nil) then // IGOR D0000006157 //else // Figure.ReSelectUnsel; end; end; end; finally EndMultiDeselect; //02.04.2012 end; for a := 0 to figures.count-1 do begin Figure := TFigure(Figures[a]); // Tolik 26/10/2015 --- ибо нех удаленные фигуры выбирать // if Figure.selected then if (Figure.selected and (not Figure.Deleted)) then // begin // commented by Tolik 26/11/2021 -- //if (TraceFigure <> nil) and (GCadForm.PCad.ModPoint <> nil) then // IGOR D0000006157 //else // Figure.ReSelectSel; end; end; end; end; Procedure TPCDrawing.ReDrawSelection; begin if not (csDesigning in self.ComponentState) then begin DrawGuideTrace(-25000,-25000); TempBitmap.Assign(BaseBitmap); RefreshSelection; DrawFigureGuides; if assigned(self.parent) then Surface.Canvas.Draw(0,0,TempBitmap); if assigned(CustomSurface) then CustomSurface.Draw(0,0,TempBitmap); end; end; Procedure TPCDrawing.DoSurfacePaint(sender: Tobject); var xCanvas: Tcanvas; ExeDir: string; begin if FUpdateCount = 0 then //04.04.2013 begin try if Assigned(GCadForm) then if GCanRefreshCad then DrawShadowCrossPoints; // Tolik 17/01/2022 inherited; if locked then exit; if Self.Owner.ClassName = 'TF_CAD' then if (GCadForm = nil) then GCadForm := TF_CAD(self.Owner); if not (csDesigning in self.ComponentState) then begin draw; end; DrawRulersToCanvas(TempBitmap.Canvas); DrawScrollsToCanvas(TempBitmap.Canvas, False, False, False); // DrawGuides(TempBitmap.Canvas); // if assigned(BaseBitmap) then // DrawGuides(BaseBitmap.Canvas); // DrawGuidesTop(DEngine.Canvas); // DrawGuidesTop(TempBitmap.Canvas); if not (csDesigning in self.ComponentState) then begin if assigned(BaseBitmap) then begin Basebitmap.Free; Basebitmap := TBitmap.Create; end; BaseBitmap.Assign(TempBitmap); RefreshSelection; DrawFigureGuides; ExeDir := ExtractFileDir(Application.ExeName); if copy(ExeDir,length(ExeDir), 1) <> '\' then ExeDir := ExeDir + '\'; if Not FileExists(ExeDir + 'NoTopGuides.ini') then begin SetEngine(TempBitmap.Canvas,ConvertXY,DeConvertXY,ConvertDim,DeConvertDim,false,nil); ClipToActiveRegion(TempBitmap.Canvas); {Mityai} //D0000006303 //if Assigned(GCadForm) then if GuidesVisible then DrawGuidesTop(DEngine.Canvas); DrawCenterGuide(DEngine.Canvas); UnClip(TempBitmap.Canvas); end; end; if DrawSurface then begin if assigned(CustomSurface) then begin CustomSurface.Draw(0, 0, TempBitmap); end else if assigned(self.parent) then begin Surface.Canvas.Draw(0, 0, TempBitmap); end; end; Surface.Canvas.Pen.Mode := pmCopy; If assigned(SOnPaint) then SOnPaint(self); except on E: Exception do AddExceptionToLog(CPowerCadMessage + 'TPCDrawing.DoSurfacePaint' + E.Message); end; end else begin RefreshSelection; //06.08.2013 - чтобы выполнялись все зарегистрированные события в TF_CAD.PCadGUIEvent end; end; Function TPCDrawing.NewLayer(Layername: string):integer; var Layer: Tlayer; Begin Layer := TLayer.create(layerName); Layer.DrawEngine := DEngine; Layer.vertZero := ord(VerticalZero); Layer.horzZero := ord(HorizontalZero); Layers.add(Layer); Result := Layers.count-1; Updated := True; if assigned(FLayerInitData) then FLayerInitData(Self,Layer); SyncEnv; end; Procedure TPCDrawing.SetCursor(cr:TCursor); begin inherited; //if assigned(cbCursorChange) then cbCursorChange(LongInt(Self),LongInt(OleCursor(cr)),False); end; Function TPCDrawing.GetLayerCount: integer; Begin result := Layers.count; end; Function TPCDrawing.GetFigureCount:integer; Begin result := Figures.count; end; Function TPCDrawing.GetSelCount:integer; Begin result := Selection.count; end; Function TPCDrawing.GetLayerNbr(LayerName: string): integer; var a: integer; s: string[255]; // Tolik 10/12/2021 Begin result := -1; s := Copy(LayerName, 1, 255); for a := 0 to Layers.Count -1 do begin //if TLayer(layers[a]).Name = LayerName then if TLayer(layers[a]).Name = s then // Tolik 10/12/2021 begin result := a; exit; end; end; End; Procedure TPCDrawing.DeleteAllUserLayers; var c,a: integer; Begin c := layerCount; For a := c - 1 downto 1 do begin DeleteLayerWithNbr(a); end; end; Function TPCDrawing.DeleteLayer(LayerName: string): boolean; var LayerNbr : integer; begin LayerNbr := GetLayerNbr(LayerName); if LayerNbr <> -1 then begin result := DeleteLayerWithNbr(LayerNbr); SyncEnv; Updated := True; ClearUndoList; end else result := false; end; Function TPCDrawing.DeleteLayerWithNbr(LayerNbr: integer): boolean; var a,b,cnt: Integer; f: Tfigure; CanDelete:Boolean; begin if (LayerNbr = 0) or (LayerNbr > LayerCount-1) then result := false else begin if (LayerNbr = ActiveLayer) then ActiveLayer := 0; cnt := figures.count; for a:= 0 to cnt-1 do begin b := cnt-1-a; f := TFigure(figures[b]); if f.LayerHandle = LongInt(Layers[LayerNbr]) then begin //if assigned(FOnFigureDel) then FOnFigureDel(Self,f,CanDelete); f.Destroy; figures.Delete(b); if assigned(FOnAfterFigureDel) then FOnAfterFigureDel(Self); end; end; TLayer(Layers[LayerNbr]).destroy; Layers.Delete(LayerNbr); result := true; refresh; SyncEnv; Updated := True; end; end; Procedure TPCDrawing.ShowLayer(LayerNbr:integer); begin If (LayerNbr < 0) or (LayerNbr > Layers.Count - 1) then exit; TLayer(Layers[LayerNbr]).visible := seen; refresh; SyncEnv; Updated := True; end; Procedure TPCDrawing.ShowAllLayers; var a: integer; begin For a:= 0 to LayerCount-1 do TLayer(Layers[a]).visible := seen; refresh; SyncEnv; Updated := True; end; Procedure TPCDrawing.HideLayer(LayerNbr:integer); begin If (LayerNbr < 0) or (LayerNbr > Layers.Count - 1) then exit; DeselectAll(LayerNbr); TLayer(Layers[LayerNbr]).visible := lost; refresh; SyncEnv; Updated := True; end; Procedure TPCDrawing.HideAllLayers; var a: integer; begin DeselectAll(0); For a:= 0 to LayerCount-1 do TLayer(Layers[a]).visible := lost; refresh; SyncEnv; Updated := True; end; Procedure TPCDrawing.GrayLayer(LayerNbr:integer); begin If (LayerNbr < 0) or (LayerNbr > Layers.Count - 1) then exit; If TLayer(Layers[LayerNbr]).visible = lost then exit; TLayer(Layers[LayerNbr]).visible := Grayed; refresh; SyncEnv; Updated := True; end; Procedure TPCDrawing.ExGrayLayer(LayerNbr:integer); var a: integer; Layer : Tlayer; begin If (LayerNbr < 0) or (LayerNbr > Layers.Count - 1) then exit; For a := 0 to Layers.Count - 1 do begin Layer := Tlayer(Layers[a]); If Layer.visible = seen then Layer.visible := Grayed; end; TLayer(Layers[LayerNbr]).visible := seen; refresh; SyncEnv; Updated := True; end; Procedure TPCDrawing.ExHideLayer(LayerNbr:integer); var a: integer; Layer : Tlayer; begin If (LayerNbr < 0) or (LayerNbr > Layers.Count - 1) then exit; For a := 0 to Layers.Count - 1 do begin Layer := Tlayer(Layers[a]); //If Layer.visible = seen then Layer.visible := lost; end; TLayer(Layers[LayerNbr]).visible := seen; refresh; SyncEnv; Updated := True; end; Procedure TPCDrawing.MergeAllLayers; var BaseLayer,Layer : TLayer; a,b,len : integer; Begin BaseLayer := TLayer(Layers[0]); For a := 0 to Figures.count - 1 do begin TFigure(Figures[a]).LayerHandle := LongInt(BaseLayer); end; len := Layers.Count-1; For a := 1 to len do Begin b := (len - a)+1; Layer := TLayer(Layers[b]); Layer.Free; Layers.Delete(b); End; refresh; SyncEnv; Updated := True; End; Procedure TPCDrawing.MergeVisibleLayers; var BaseLayer,Layer : TLayer; a,b,len,x : integer; found : Boolean; Saved : TList; f: TFigure; Begin found := false; a:= 0; repeat if TLayer(Layers[a]).visible <> lost then begin x := a; found := true; end; inc(a); until (found) or (a = Layers.Count); If not found then exit; BaseLayer := TLayer(Layers[x]); For b := 0 to Figures.count - 1 do begin f := TFigure(Figures[b]); Layer := TLayer(f.LayerHandle); if (Layer.Visible <> lost) and (Layer <> BaseLayer) then f.LayerHandle := LongInt(BaseLayer); end; Saved := TList.create; len := Layers.Count-1; For a := 0 to len do Begin Layer := TLayer(Layers[a]); if (a = x) or (Layer.Visible = lost) then Saved.Add(Layer) else begin Layer.Free; end; End; Layers.Clear; For a := 0 to Saved.count -1 do Layers.Add(Saved[a]); saved.free; refresh; SyncEnv; Updated := True; End; Procedure TPCDrawing.Clear(LayerNbr : integer; UndoRecord:Boolean); var a,cnt,b: integer; f: TFigure; xAction: TUndoAction; CanDelete:Boolean; begin //Tolik xAction := nil; // if assigned(FOnBeforeClear) then FOnBeforeClear(Self); if RecordUndo and UndoRecord then xAction := TUndoAction.Create(uaRemove); If (LayerNbr < 0) or (LayerNbr > Layers.Count - 1) then exit; if not (RecordUndo and UndoRecord) then ClearUndoList; cnt := figures.count; //cnt := figures.count - 1; for a:= 0 to cnt-1 do begin b := cnt-1-a; f := TFigure(figures[b]); if (LayerNbr=0) or (f.LayerHandle = LongInt(Layers[LayerNbr])) then begin CanDelete := True; if CanDelete then begin TFigure(figures[b]).deselect; TFigure(figures[b]).Deleted := True; if not (RecordUndo and UndoRecord) then TFigure(figures[b]).Free; if RecordUndo and UndoRecord then begin xAction.List.Add(figures[b]); TFigure(figures[b]).Urc := TFigure(figures[b]).Urc+1; TFigure(figures[b]).DelIndex := b; end; figures.Delete(b); if assigned(FOnAfterFigureDel) then FOnAfterFigureDel(Self); end; end; end; {for a := cnt Downto 0 do begin f := TFigure(figures[a]); if (LayerNbr=0) or (f.LayerHandle = LongInt(Layers[LayerNbr])) then begin CanDelete := True; if CanDelete then begin TFigure(figures[a]).deselect; TFigure(figures[a]).Deleted := True; if not (RecordUndo and UndoRecord) then //FreeAndNil(TFigure(figures[a])); FreeAndNil(f); if RecordUndo and UndoRecord then begin if xAction <> nil then begin xAction.List.Add(figures[a]); TFigure(figures[a]).Urc := TFigure(figures[a]).Urc+1; TFigure(figures[a]).DelIndex := a; end else FreeAndNil(f); end; figures.Delete(a); if assigned(FOnAfterFigureDel) then FOnAfterFigureDel(Self); end; end; end; } if RecordUndo and UndoRecord then //begin // if xAction <> nil then InsertUndoAction(xAction); // end; ClearGuides; refresh; Updated := True; End; Function TPCDrawing.GetLayerInfo(LayerNbr: integer): TLayerInfo; Var Info : TLayerInfo; Layer : Tlayer; Begin if (LayerNbr > LayerCount - 1) then begin Info.Name := ''; end else begin Layer := TLayer(Layers[LayerNbr]); Info.Name := Layer.Name; Info.Visible := (Layer.visible = seen) or (Layer.visible = Grayed); Info.Grayed := (Layer.visible = Grayed); end; result := Info; end; Function TPCDrawing.GetLayerName(LayerNbr: integer): String; var Layer : Tlayer; begin Result := ''; if (LayerNbr < LayerCount) then begin Result := TLayer(Layers[LayerNbr]).Name; end; end; Function TPCDrawing.GetLayerHandle(LayerNbr: integer): Integer; begin Result := 0; if (LayerNbr < LayerCount) then begin Result := Integer(Layers[LayerNbr]); end; end; Function TPCDrawing.GetLayerVisible(LayerNbr: integer): Boolean; var Layer : Tlayer; begin Result := False; if (LayerNbr < LayerCount) then begin Result := (Layer.visible = seen) or (Layer.visible = Grayed); end; end; Function TPCDrawing.GetLayerGrayed(LayerNbr: integer): Boolean; var Layer : Tlayer; begin Result := False; if (LayerNbr < LayerCount) then begin Result := (Layer.visible = Grayed); end; end; Procedure TPCDrawing.setMapscale(value: double); var px: Double; begin if value = 0 then value := 1; px := FMapScale/Value; FMapScale := value; SetRulerValues(FMapScale,ord(FRulerMode)); if assigned(FOnMapScale) then FOnMapScale(Self); if (Figures.Count > 0) and ((FRescale = rsAlways) or ((FReScale = rsAskUser) and (MessageDlg(ReScaleMessage,mtConfirmation,[mbYes,mbNo],0) = mrYes) )) then ScaleDrawing(px,px); Refresh; SyncEnv; Updated := True; end; Function TPCDrawing.selectbypoint(LayerNbr:Integer;x,y:Double;shiftpressed: boolean): Boolean; var a: integer; Res : TFigure; found : boolean; begin result := false; res := nil; If (LayerNbr < 0) or (LayerNbr > Layers.Count - 1) then exit; res := checkbypoint(LayerNbr,x,y); if Assigned(FGetFigureToSelect) then //#From Oleg# //04.10.2010 FGetFigureToSelect(Self, res, x, y); if (res <> nil) and (res.LockSelect = False) then begin result := SelectByFigure(LayerNbr,res.Handle,ShiftPressed); end else begin If (not shiftpressed) and (FAnySelected) then begin ClearTreeSelection; // Tolik 30/11/2021 -- deselectall(0); DoSelChange; end; end; end; Function TPCDrawing.RegisterModPoint(Figure: TFigure; PType: TModPointType; DType : TPointType; Color: TColor; aDim,X,Y: Double; SeqNbr: integer; z:DOuble=0;fOnlyIso:Boolean=False;isBlink:Boolean=False): TModPoint; var MP : TModPoint; Begin MP := TModPoint.Create(Figure,PType,DType,color,aDim,X,Y,SeqNbr,z); mp.OnlyIso := fOnlyIso; mp.isBlink := isBlink; ModPoints.Add(MP); result := MP; End; Procedure TPCDrawing.UnRegisterModPoint(pt: TModPoint); var idx: Integer; i, j: Integer; Begin //02.04.2012 ModPoints.Remove(pt); //02.04.2012 if FMultiDeselectCount = 0 then ModPoints.Remove(pt) else begin for i := FModPointsStartIdx to ModPoints.Count - 1 do if ModPoints.List^[i] = pt then begin idx := i; ModPoints[idx] := nil; // если точку нашли в начале списка, то увелисиваем позицию поиска на 1 if i = FModPointsStartIdx then Inc(FModPointsStartIdx) else ModPoints.Delete(idx); //else // иначе определяем от FModPointsStartIdx до i сколько пустых значений, смещая FModPointsStartIdx //for j := FModPointsStartIdx+1 to i do //begin // if ModPoints.List^[j] = nil then // FModPointsStartIdx := j; //end; Break; //// BREAK //// end; end; if assigned(pt) then begin //Tolik 02/01/2019 -- if Assigned(GCadForm) then if Assigned(GCadForm.PCad) then if GCadForm.PCad.ModPoint = pt then GCadForm.PCad.ModPoint := nil; // pt.free; pt := nil; end; End; Function TPCDrawing.HitTestModPointInt(x,y: Double):Integer; begin result := Integer(HitTestModPoint(x,y)); end; Function TPCDrawing.HitTestModPoint(x,y: Double):TModPoint; var a: integer; pdim : Double; Begin result := nil; //DeConvertDim(pdim); for a := 0 to ModPoints.count-1 do begin pdim := pointdim; if TModPoint(ModPoints[a]).Figure <> nil then begin try if (TModPoint(ModPoints[a]).Figure is TOrthoLine) or (TModPoint(ModPoints[a]).Figure is TConnectorObject) then pdim := pdim + dimp_add; except //НЕЛБЗЯ анрег делать - непонятно пока почему - но падает потом все если анрег сделать! //if Figures.IndexOf(TModPoint(ModPoints[a]).Figure) = -1 then //begin // try // UnRegisterModPoint(TModPoint(ModPoints[a])); // except // end; // break; //end; pdim := pdim; end; end; DeConvertDim(pdim); if TModPoint(ModPoints[a]).IsPointIn(x,y,pdim) then begin result := ModPoints[a]; exit; end; end; End; //Tolik 30/11/2021 -- Function TPCDrawing.selectwithinArea(LayerNbr: integer;area:TDoubleRect;shiftpressed: boolean):Boolean; var a: integer; f: TFigure; invis:Boolean; RefreshFlag: boolean; begin RefreshFlag := GCanRefreshCad; GCanRefreshCad := False; try FSCS_Main.TimerRefresh.Enabled := False; result := false; //Tolik 29/11/2021 - - //if not shiftpressed then ClearTreeSelection; // If (not shiftpressed) and (FAnySelected) then begin deselectall(LayerNbr); RedrawSelection; SyncEnv; DoSelChange; end; If (LayerNbr < 0) or (LayerNbr > Layers.Count - 1) then exit; result := false; for a := 0 to figures.count-1 do begin f := TFigure(figures[a]); invis := false; if (f.LayerHandle <> 0) then invis := (TLayer(f.LayerHandle).Visible = lost); if (not invis) and (not f.LockSelect) and ((LayerNbr = 0) or (f.LayerHandle = LongInt(Layers[LayerNbr]))) and (f.checkifInArea(area)) then begin f.rMode := false; if f is Tnet then begin TNet(f).SelType := stStruct; TNet(f).SelIndex := 0; end; f.select; if assigned(FFigureSelect) then FFigureSelect(Self,f); f.drawSelectionPoints(DEngine,false); If not FAnySelected then f.FirstSelected := True; FAnySelected := True; result := true; end; // подложка, ДХФ слои if (not invis) and (not f.LockSelect) and ((LayerNbr = 1) and TLayer(f.LayerHandle).IsDxf {CheckFigureInDXFLayer(f)}) and (f.checkifInArea(area)) then begin f.rMode := false; f.select; if assigned(FFigureSelect) then FFigureSelect(Self,f); f.drawSelectionPoints(DEngine,false); If not FAnySelected then f.FirstSelected := True; FAnySelected := True; result := true; end; end; if result = true then begin SyncEnv; RedrawSelection; DoSelChange; end; Except on E: Exception do AddExceptionToLog('TPCDrawing.SelectArea' + E.Message); end; GCanRefreshCad := RefreshFlag; end; // (* Function TPCDrawing.selectwithinArea(LayerNbr: integer;area:TDoubleRect;shiftpressed: boolean):Boolean; var a: integer; f: TFigure; invis:Boolean; begin result := false; //Tolik 29/11/2021 - - //if not shiftpressed then ClearTreeSelection; // If (not shiftpressed) and (FAnySelected) then begin deselectall(LayerNbr); RedrawSelection; SyncEnv; DoSelChange; end; If (LayerNbr < 0) or (LayerNbr > Layers.Count - 1) then exit; result := false; for a := 0 to figures.count-1 do begin f := TFigure(figures[a]); invis := false; if (f.LayerHandle <> 0) then invis := (TLayer(f.LayerHandle).Visible = lost); if (not invis) and (not f.LockSelect) and ((LayerNbr = 0) or (f.LayerHandle = LongInt(Layers[LayerNbr]))) and (f.checkifInArea(area)) then begin f.rMode := false; if f is Tnet then begin TNet(f).SelType := stStruct; TNet(f).SelIndex := 0; end; f.select; if assigned(FFigureSelect) then FFigureSelect(Self,f); f.drawSelectionPoints(DEngine,false); If not FAnySelected then f.FirstSelected := True; FAnySelected := True; result := true; end; // подложка, ДХФ слои if (not invis) and (not f.LockSelect) and ((LayerNbr = 1) and TLayer(f.LayerHandle).IsDxf {CheckFigureInDXFLayer(f)}) and (f.checkifInArea(area)) then begin f.rMode := false; f.select; if assigned(FFigureSelect) then FFigureSelect(Self,f); f.drawSelectionPoints(DEngine,false); If not FAnySelected then f.FirstSelected := True; FAnySelected := True; result := true; end; end; if result = true then begin SyncEnv; RedrawSelection; DoSelChange; end; end; *) Procedure TPCDrawing.SelectFigure(FHandle: Integer); begin if Figures.IndexOf(Pointer(FHandle)) <> -1 then begin if TFigure(FHandle).LockSelect then exit; TFigure(FHandle).Select; FAnySelected := True; SyncEnv; RedrawSelection; DoSelChange; end; end; Procedure TPCDrawing.DeSelectFigure(FHandle: Integer); begin if Figures.IndexOf(Pointer(FHandle)) <> -1 then begin TFigure(FHandle).DeSelect; SyncEnv; RedrawSelection; end; end; Function TPCDrawing.checkbypoint(LayerNbr:Integer;x,y:Double): TFigure; var a, i, k: integer; f, fc: Tfigure; invis: boolean; begin result := nil; for i := 0 to figures.count - 1 do begin a := figures.count - 1 - i; f := TFigure(figures[a]); invis := false; if (f.LayerHandle <> 0) then invis := (TLayer(f.LayerHandle).Visible = lost); if (not invis) and ((LayerNbr = 0) or (f.LayerHandle = LongInt(Layers[LayerNbr]))) then begin if (f.isPointIn(x, y)) then begin Result := f; exit; end; end; // подложка, ДХФ слои if (not invis) and ((LayerNbr = 1) and TLayer(f.LayerHandle).IsDxf {CheckFigureInDXFLayer(f)}) then begin if (f.isPointIn(x, y)) then begin Result := f; exit; end; end; end; end; { Procedure TPCDrawing.moveselection(deltax,deltay:Double); var a: integer; MovedList: TList; curFigure: TFigure; begin if RecordUndo then RecordModifyUndo(nil); for a := 0 to figures.count - 1 do begin if (TFigure(figures[a]).selected) and not (TFigure(figures[a]).LockMove) and (TFigure(figures[a]) is DrawObjects.TLine) then begin DrawObjects.TLine(figures[a]).InMoveList := True; end; end; MovedList := TList.create; for a := 0 to figures.count - 1 do begin if (TFigure(figures[a]).selected) and not (TFigure(figures[a]).LockMove) then begin MovedList.Add(TFigure(figures[a])); end end; for a := 0 to MovedList.Count - 1 do begin curFigure := TFigure(MovedList[a]); if not curFigure.Deleted then begin curFigure.move(deltax,deltay); if assigned(FOnFigureMoved) then FOnFigureMoved(Self, curFigure ,deltax, deltay); end; end; FreeAndNil(MovedList); Updated := True; end; } Procedure TPCDrawing.moveselection(deltax,deltay:Double); var a, i: integer; MovedList: TList; curFigure: TFigure; // Tolik LineCount: Integer; CanMakeMove: Boolean; LineList, RaiseList: TList; isVerticalLine, isHorizontalLine: Boolean; CanRefreshFlag: Boolean; Procedure AddConnectorToMoveList(AConnector: TConnectorObject); var MovedConnector: TConnectorObject; CanMove: Boolean; begin MovedConnector := TConnectorObject(AConnector); if TConnectorObject(AConnector).JoinedConnectorsList.Count > 0 then MovedConnector := TConnectorObject(AConnector).JoinedConnectorsList[0]; if TConnectorObject(AConnector).FConnRaiseType <> crt_None then if TConnectorObject(AConnector).FObjectFromRaise <> nil then MovedConnector := TConnectorObject(AConnector).FObjectFromRaise; // ******************************************************************* CanMove := True; if (MovedConnector.FIsApproach) and (not MovedConnector.fHouse.Selected) then CanMove := MovedConnector.IsApproachInHouse(deltax, deltay); if CanMove then begin if (not MovedConnector.Selected) and (not GDisableMove) then if not ((MovedConnector.FIsHouseJoined) and (MovedConnector.fHouse <> nil) and (MovedConnector.fHouse.Selected)) then if MovedList.IndexOF(MovedConnector) = -1 then MovedList.Add(MovedConnector); end; end; // // Tolik -- 28/03/2016 -- Function CheckCanMove(aLineList: TList): Boolean; var i: Integer; LeftRigthLine, UpDownLine: Boolean; currLine: TOrthoLine; isVerticalLine, isHorizontalLine: Boolean; tmpConn, Conn1, Conn2: TConnectorObject; NBConn: TConnectorObject; begin Result := True; if LineList.Count = 1 then begin isVerticalLine := False; isHorizontalLine := False; //Result := False; currLine := TOrthoLine(aLineList[0]); Conn1 := TConnectorObject(currLine.JoinConnector1); Conn2 := TConnectorObject(currLine.JoinConnector2); if CompareValue(conn1.ap1.x, conn2.ap1.x) = 0 then isVerticalLine := True else if CompareValue(conn1.ap1.y, Conn2.ap1.y) = 0 then isHorizontalLine := True; {if (isVerticalLine and (deltay = 0) ) then Result := True else if (isHorizontalLine and (deltax = 0)) then Result := True; if not Result then begin if ((not isHorizontalLine) and (not isVerticalLine)) then Result := True; end } if isVerticalLine then deltay := 0 else if isHorizontalLine then deltax := 0; end; end; Function CanMoveConn(aConn: TConnectorObject): Boolean; var i,j: Integer; RaiseLine: TOrthoLine; begin Result := True; RaiseLine := Nil; if aConn.ConnectorType = ct_Nb then begin for i := 0 to aConn.JoinedConnectorsList.Count - 1 do begin for j := 0 to TConnectorObject(aConn.JoinedConnectorsList[i]).JoinedOrtholinesList.Count - 1 do begin if TOrthoLine(TConnectorObject(aConn.JoinedConnectorsList[i]).JoinedOrtholinesList[j]).FIsRaiseUpDown then begin RaiseLine := TOrthoLine(TConnectorObject(aConn.JoinedConnectorsList[i]).JoinedOrtholinesList[j]); break; end; end; if RaiseLine <> nil then break; end; end else if AConn.ConnectorType = ct_Clear then begin for i := 0 to AConn.JoinedOrtholinesList.Count - 1 do begin if TOrthoLine(AConn.JoinedOrtholinesList[i]).FIsRaiseUpDown then begin RaiseLine := TOrthoLine(AConn.JoinedOrtholinesList[i]); break; end; end; end; if RaiseLine <> nil then if RaiseList.IndexOf(RaiseLine) <> -1 then Result := False; end; begin if RecordUndo then RecordModifyUndo(nil); // Tolik -- 29/03/2016 -- LineCount := 0; CanMakeMove := False; LineList := TList.Create; MovedList := TList.Create; RaiseList := TList.Create; // список райзов, чтобы двигать райзы отдельно, т.к. если их двигать через коннекторы, // райз двигается только горизонтально // Tolik 24/01/2017 -- CanRefreshFlag := GCanRefreshCad; GCanRefreshCad := False; try // // // Tolik -- 16/11/2015 // во-первых, есть Selection на CADе, так что нех все фигуры перебирать -- здесь немножко ускорим процесс // во-вторых, здесь можно вкинуть коннекторы ортолинии в Move-лист и избавиться от проблемы // повторного сдвига общего коннектора для нескольких линий, когда выбраны только сами линии // (через Shift) { for a := 0 to figures.count - 1 do begin if (TFigure(figures[a]).selected) and not (TFigure(figures[a]).LockMove) and (TFigure(figures[a]) is DrawObjects.TLine) then begin DrawObjects.TLine(figures[a]).InMoveList := True; end; end; MovedList := TList.create; for a := 0 to figures.count - 1 do begin if (TFigure(figures[a]).selected) and not (TFigure(figures[a]).LockMove) then begin MovedList.Add(TFigure(figures[a])); end end;} // Tolik 16/11/2015 -- линии совать тоже не будем -- подвинем только коннектора for a := 0 to Selection.Count - 1 do begin if (TFigure(Selection[a]).selected) and not (TFigure(Selection[a]).LockMove) and (TFigure(Selection[a]) is DrawObjects.TLine) then if not TFigure(Selection[a]).Deleted then begin DrawObjects.TLine(Selection[a]).InMoveList := True; //Tolik -- if CheckFigureByClassName(TFigure(Selection[a]), cTOrthoLine) then begin // 07/08/2018 -- if TOrthoLine(Selection[a]).FisRaiseUpDown then begin if RaiseList.IndexOf(TOrthoLine(Selection[a])) = -1 then RaiseList.Add(TOrthoLine(Selection[a])); end else // begin Inc(LineCount); LineList.Add(TOrthoLine(Selection[a])); end; end; // end; end; for a := 0 to Selection.Count - 1 do begin curFigure := TFigure(Selection[a]); if ((not curFigure.Deleted) and (not Curfigure.LockMove)) then begin // ортолинии двинуть по коннекторам if CheckFigureByClassName(curFigure, cTOrthoLine) then begin if not TOrthoLine(curFigure).FisRaiseUpDown then begin if TConnectorObject(TOrthoLine(curFigure).JoinConnector1) <> nil then if not TConnectorObject(TOrthoLine(curFigure).JoinConnector1).Selected then if MovedList.IndexOF(TConnectorObject(TOrthoLine(curFigure).JoinConnector1)) = -1 then AddConnectorToMoveList(TConnectorObject(TOrthoLine(curFigure).JoinConnector1)); //Toilk -- 13/06/2017 -- //для вертикали -- двинуть только один коннектор if not TOrthoLine(curFigure).FisVertical then // if TConnectorObject(TOrthoLine(curFigure).JoinConnector2) <> nil then if not TConnectorObject(TOrthoLine(curFigure).JoinConnector2).Selected then if MovedList.IndexOF(TConnectorObject(TOrthoLine(curFigure).JoinConnector2)) = -1 then AddConnectorToMoveList(TConnectorObject(TOrthoLine(curFigure).JoinConnector2)); end; end else // точечные двинуть как есть if MovedList.IndexOf(curFigure) = -1 then MovedList.Add(curFigure); end end; if LineCount > 1 then CanMakeMove := True else CanMakeMove := CheckCanMove(LineList); for i := 0 to RaiseList.Count - 1 do begin curFigure := Tfigure(RaiseList[i]); curFigure.move(deltax, deltay); if assigned(FOnFigureMoved) then FOnFigureMoved(Self, curFigure, deltax, deltay); end; if CanMakeMove then begin // ---------------- M O V E -------------------------- // Tolik -- 07/06/2016 -- // -- исправлен прое, когда точечный расположден на коннекторе, нужно сначала двинуть точечные, // а потом пустые коннекторы трасс, иначе неправильно пересчитается длина трасс // двинуть точечные for a := 0 to MovedList.Count - 1 do begin curFigure := TFigure(MovedList[a]); if CheckFigureByClassName(curFigure, cTConnectorObject) then begin if TConnectorObject(curFigure).ConnectorType = ct_NB then begin if CanMoveConn(TConnectorObject(curFigure)) then begin curFigure.move(deltax, deltay); if assigned(FOnFigureMoved) then FOnFigureMoved(Self, curFigure, deltax, deltay); end; end; end else begin curFigure.move(deltax, deltay); if assigned(FOnFigureMoved) then FOnFigureMoved(Self, curFigure, deltax, deltay); end; end; // двинуть пустые коннектора трасс for a := 0 to MovedList.Count - 1 do begin curFigure := TFigure(MovedList[a]); if CheckFigureByClassName(curFigure, cTConnectorObject) and (TConnectorObject(curFigure).ConnectorType = ct_Clear) then begin if CanMoveConn(TConnectorObject(curFigure)) then begin curFigure.move(deltax, deltay); if assigned(FOnFigureMoved) then FOnFigureMoved(Self, curFigure, deltax, deltay); end; end; end; {for a := 0 to MovedList.Count - 1 do begin curFigure := TFigure(MovedList[a]); curFigure.move(deltax, deltay); if assigned(FOnFigureMoved) then FOnFigureMoved(Self, curFigure, deltax, deltay); end;} // Updated := True; end; except on E: exception do AddExceptionToLog('TPCDrawing.moveselection' + E.Message); end; FreeAndNil(MovedList); FreeAndNil(LineList); RaiseList.Free; GCanRefreshCad := CanRefreshFlag; end; Procedure TPCDrawing.CopyToClipBoard; var a: integer; Selecteds : TList; fStream,mStream:TMemoryStream; fCount: integer; xSize: Integer; Figure :TFigure; mf: TMetafile; Data: THandle; Format: Word; Palette: HPALETTE; Clp :TClipBoard; xBmp:TBitmap; Begin Selecteds := TList.create; collectSelectedFigures(Selecteds); // Tolik -- 07/02/2017 -- утечка памяти !!! // If Selecteds.count = 0 then exit; If Selecteds.count = 0 then begin FreeAndNil(Selecteds); exit; end; // mStream := TMemoryStream.Create; fCount := Selecteds.count; mStream.Write(fCount,4); For a := 0 to fCount-1 do begin Figure := TFigure(Selecteds[a]); fStream := TMemoryStream.Create; Figure.WriteToStream(fStream); xSize := fStream.Size; fStream.Seek(0,soFromBeginning); mStream.Write(xSize,4); StreamToStream(fStream,mStream,xSize); fStream.Free; end; mStream.Seek(0,soFromBeginning); StreamToClipBoard(mStream,CF_PCAD); mStream.Free; mf := SelectionAsWmf; OpenClipBoard(0); mf.SaveToClipboardFormat(Format, Data, Palette); SetClipboardData(Format, Data); if Palette <> 0 then SetClipboardData(CF_PALETTE, Palette); CloseClipBoard; DoSurfacePaint(Surface); xBmp := SelectionAsBitmap(80); OpenClipBoard(0); xBmp.SaveToClipboardFormat(Format,Data,Palette); SetClipboardData(Format, Data); if Palette <> 0 then SetClipboardData(CF_PALETTE, Palette); CloseClipBoard; End; Procedure TPCDrawing.CutToClipBoard; Begin copytoclipboard; RemoveSelection; Updated := True; End; Procedure TPCDrawing.PasteFromClipBoard(LayerNbr: integer); var a: integer; clp : TClipBoard; fig,inFig: Tfigure; xAction : TUndoAction; mStream:TmemoryStream; fCount: integer; Figure : TFigure; xSize: Integer; fStream:TMemoryStream; mf: TMetafile; LayerHandle: Integer; Cont: TFigure; Begin Cont := nil; // Tolik -- 20/11/2015 // о целесообразности использования данной технологии история умалчивает, НО // если юзать, то приводит к интересному БАГУ: в случае, если выбрана не та фигура, которая // вставляется из буфера, то ВСТАВЛЕННАЯ ФИГУРА БУДЕТ ОТРИСОВЫВАТЬСЯ ТОЛЬКО В ГРАНИЦАХ ФИГУРЫ, // ВЫБРАННОЙ В ДАННЫЙ МОМЕНТ --- поэтому закомментил // if Selection.Count = 1 then // Cont := TFigure(Selection[0]); // // Tolik 27/10/2015 // if assigned(Cont) and (Cont.RegHandle = 0) then if assigned(Cont) and (Cont.RegHandle = 0) and ((Cont.RegObject = nil) or ((Cont.RegObject <> nil) and (Cont.RegObject.RegObjData = nil))) then Cont := nil; if RecordUndo then xAction := TUndoAction.Create(uaInsert); if IsClipboardFormatAvailable(CF_PCAD) then begin Layerhandle := 0; if (LayerNbr >-1) and (LayerNbr < Layers.Count) then LayerHandle := Integer(layers[LayerNbr]); mStream := TMemoryStream.Create; ClipBoardToStream(mStream,CF_PCAD); if mStream.Size = 0 then exit; mStream.Read(fCount,4); DeselectAll(LayerNbr); For a := 1 to fCount do begin mStream.Read(xSize,4); fStream := TMemoryStream.Create; StreamToStream(mStream,fStream,xSize); fStream.Seek(0,soFromBeginning); Figure := nil; Figure := TFigure.CreateFromStream(fStream,0,mydsNormal,self); fStream.Free; if Figure <> nil then begin if layerHandle <> 0 then Figure.LayerHandle := LayerHandle; if FindFigureByName(figure.name) <> 0 then Figure.Rename; if assigned(Cont) then begin Figure.Deselect; Cont.ClipFigures.Add(Figure); Figure.inClip := True; Figures.Add(Figure); end else begin Figure.Selected := True; Figure.inClip := False; Figures.Add(Figure); end; if RecordUndo then xAction.List.Add(figure); if assigned(FOnObjectInserted) then FOnObjectInserted(self,irPaste); // сдвинуть новый объект Figure.Move(1, 1); end; end; // === mStream.Free; end else if IsClipboardFormatAvailable(CF_METAFILEPICT) then begin mf := TMetafile.Create; mf.Assign(ClipBoard); insertMetafile(0,0,0,mf,True); mf.Free; end; FAnySelected := true; if RecordUndo then begin if xAction.List.Count > 0 then begin InsertUndoAction(xAction); end else begin xAction.Free; end; end; refresh; Updated := True; End; Function CanAlign(ActiveLayer: Integer; Figure: TFigure): Boolean; begin REsult := false; if ActiveLayer = 2 then begin if not CheckFigureByClassName(Figure, 'TOrthoLine') then begin if (CheckFigureByClassName(Figure, 'TConnectorObject'))and (TConnectorObject(Figure).JoinedOrtholinesList.count = 0) then Result := true else Result := false; end else Result := false; end else Result := true; end; // Tolik 06/02/2017 -- старая закомменчена - смотри ниже // здесь дописано выравнивание для архитектурного проектирования Procedure TPCDrawing.alignSelection(HorzAlign: THorzAligns; VertAlign: TVertAligns); var a,b,ocx,ocy,RefBlockIdx : integer; Selecteds : TList; RefFigure : TFigure; CustFigure : TFigure; MaxFig : TFigure; MinFig : Tfigure; CurrentFig : TFigure; MaxY,MinY : Double; RefRect : TDoubleRect; CustRect : TDoubleRect; HelpRect : TDoubleRect; Found : Boolean; Dist : Double; PartDist : real; centers : array [0..1000] of Double; occupied : array [0..1000] of Boolean; Center, MinDist, FirstCenter: Double; figMaxX,figMaxY,figMinX,figMinY: Double; // Tolik -- 06/02/2017 -- NetList: TList; currNet: TNet; currPath: TNetPath; PointToMove: PDoublePoint; i: Integer; RefreshFlag: Boolean; pathMoveAllPoints: Boolean; p: PDoublePoint; function GetMovePointByMode: PDoublePoint; var currNet, NetForRemove: TNet; NetPoint: PDoublePoint; i, j: Integer; begin NetForRemove := TNet(NetList[0]); Result := PDoublePoint(NetForRemove.Points[0]); for i := 0 to NetList.Count - 1 do begin currNet := TNet(NetList[i]); for j := 0 to currNet.Points.Count - 1 do begin // по левому краю if (HorzAlign = haNoChange) and (VertAlign = vaLeft) then begin if CompareValue(Result^.x, TDoublePoint(currNet.Points[j]^).x) = 1 then begin NetForRemove := currNet; Result := PDoublePoint(currNet.Points[j]); end; end; // по правому краюд if (HorzAlign = haNoChange) and (VertAlign = vaRight) then begin if CompareValue(Result^.x, TDoublePoint(currNet.Points[j]^).x) = -1 then begin NetForRemove := currNet; Result := PDoublePoint(currNet.Points[j]); end; end; // по верхнему краю if (HorzAlign = haTop) and (VertAlign = vaNoChange) then begin if CompareValue(Result^.y, TDoublePoint(currNet.Points[j]^).y) = 1 then begin NetForRemove := currNet; Result := PDoublePoint(currNet.Points[j]); end; end; // по нижнему краю if (HorzAlign = haBottom) and (VertAlign = vaNoChange) then begin if CompareValue(Result^.y, TDoublePoint(currNet.Points[j]^).y) = -1 then begin NetForRemove := currNet; Result := PDoublePoint(currNet.Points[j]); end; end; end; end; NetList.Remove(NetForRemove); end; function GetNetPointByMode(aNet: TNet) : PDoublePoint; var i: Integer; begin Result := PDoublePoint(aNet.Points[0]); // по левому краю if (HorzAlign = haNoChange) and (VertAlign = vaLeft) then begin if aNet.Points.Count > 1 then begin for i := 1 to aNet.Points.Count - 1 do begin if CompareValue(Result^.x, TDoublePoint(aNet.Points[i]^).x) = 1 then Result := PDoublePoint(aNet.Points[i]); end; end; end; // по правому краю if (HorzAlign = haNoChange) and (VertAlign = vaRight) then begin if aNet.Points.Count > 1 then begin for i := 1 to aNet.Points.Count - 1 do begin if CompareValue(Result^.x, TDoublePoint(aNet.Points[i]^).x) = -1 then Result := PDoublePoint(aNet.Points[i]); end; end; end; // по верхнему краю if (HorzAlign = haTop) and (VertAlign = vaNoChange) then begin if aNet.Points.Count > 1 then begin for i := 1 to aNet.Points.Count - 1 do begin if CompareValue(Result^.y, TDoublePoint(aNet.Points[i]^).y) = 1 then Result := PDoublePoint(aNet.Points[i]); end; end; end; // по нижнему краю if (HorzAlign = haBottom) and (VertAlign = vaNoChange) then begin if aNet.Points.Count > 1 then begin for i := 1 to aNet.Points.Count - 1 do begin if CompareValue(Result^.y, TDoublePoint(aNet.Points[i]^).y) = -1 then Result := PDoublePoint(aNet.Points[i]); end; end; end; end; procedure MoveNets(ANetList: TList); var i, j: Integer; MovingNet: TNet; DeltaX, DeltaY: Double; Procedure GetDeltaForMove; var currNetPoint: PDoublePoint; begin DeltaX := 0; DeltaY := 0; currNetPoint := GetNetPointByMode(MovingNet); // по левому или по правому краю if (HorzAlign = haNoChange) and ((VertAlign = vaLeft)or(VertAlign = vaRight)) then DeltaX := PointToMove^.x - currNetPoint^.x; //по верхнему краю или по нижнему краю if ((HorzAlign = haBottom) or (HorzAlign = haTop)) and (VertAlign = vaNoChange) then DeltaY := PointToMove^.y - currNetPoint^.y; end; begin for i := 0 to ANetList.Count - 1 do begin MovingNet := TNet(ANetList[i]); GetDeltaForMove; j:= 0 ; for j := 0 to MovingNet.Points.Count - 1 do begin p := PDoublePoint(MovingNet.Points[j]); p.x := p.x + DeltaX; p.y := P.y + DeltaY; end; MovingNet.SetModified; end; end; // begin //RefreshFlag := False; RefreshFlag := GCanRefreshCad; GCanRefreshCad := False; {if GCanRefreshCad then begin GCanRefreshCad := False; RefreshFlag := True; end; } try if (GCadForm.PCad.ActiveLayer = 2) then GCadForm.SaveForUndo(uat_None, True, False); if GCadForm.PCad.ActiveLayer = 8 then begin NetList := TList.Create; for i := 0 to Selection.Count - 1 do begin if TFigure(Selection[i]).ClassName = 'TNetPath' then begin currPath := TNetPath(Selection[i]); if Assigned(currPath.Net) and (NetList.IndexOf(currPath.Net) = -1) then NetList.Add(currPath.Net); end else if (TFigure(Selection[i]).ClassName = 'TNet') and (NetList.IndexOf(TNet(Selection[i])) = -1) then NetList.Add(TNet(Selection[i])); end; // хотя бы две фигуры (не сегмента, а именно ТНЕТ фигуры) if NetList.Count > 1 then begin // УНДО GCadForm.SaveForUndo(uat_None, True, False); // выравнивание (от параметра) PointToMove := GetMovePointByMode; MoveNets(NetList); end; FreeAndNil(NetList); end else begin Selecteds := TList.Create; collectSelectedFigures(Selecteds); If Selecteds.Count < 2 then begin GCanRefreshCad := RefreshFlag; FreeAndNil(Selecteds); exit; end; RefBlockIdx := 0; a := 0; Found := false; while (a < selecteds.Count) and (not found) do begin If TFigure(Selecteds[a]).firstselected then begin RefBlockIdx := a; found := true; end; inc(a); end; if RecordUndo then RecordModifyUndo(nil); RefFigure := TFigure(Selecteds[RefBlockIdx]); RefRect := RefFigure.GetBoundRect; a := 0; while (a < selecteds.Count) do begin if CanAlign(GCadform.PCad.ActiveLayer, TFigure(Selecteds[a])) then begin if ssCtrl in GGlobalShiftState then RefRect := TFigure(Selecteds[a]).GetBoundRect else begin if GCadForm.PCad.ActiveLayer = 2 then RefRect := TFigure(Selecteds[a]).GetBoundRect(false) else RefRect := TFigure(Selecteds[a]).GetBoundRect; end; break; end; Inc(a); end; a := 0; while (a < selecteds.Count) do begin if CanAlign(GCadform.PCad.ActiveLayer, TFigure(Selecteds[a])) then begin if ssCtrl in GGlobalShiftState then HelpRect := TFigure(Selecteds[a]).GetBoundRect else begin if GCadForm.PCad.ActiveLayer = 2 then HelpRect := TFigure(Selecteds[a]).GetBoundRect(false) else HelpRect := TFigure(Selecteds[a]).GetBoundRect; end; if RefRect.left > HelpRect.left then RefRect.left := HelpRect.left; if RefRect.Right < HelpRect.right then RefRect.Right := HelpRect.Right; if RefRect.top > HelpRect.Top then RefRect.Top := HelpRect.Top; if RefRect.Bottom < HelpRect.Bottom then RefRect.Bottom := HelpRect.Bottom; end; inc(a); end; if (VertAlign = vaDistVert) and (selecteds.count > 2) then begin MaxY := TFigure(Selecteds[0]).GetBoundRect.Top; MaxFig := TFigure(Selecteds[0]); MinY := TFigure(Selecteds[0]).GetBoundRect.Top; MinFig := TFigure(Selecteds[0]); for a := 1 to Selecteds.Count - 1 do begin if TFigure(Selecteds[a]).GetBoundRect.Top > MaxY then begin MaxY := TFigure(Selecteds[a]).GetBoundRect.Top; MaxFig := TFigure(Selecteds[a]); end; if TFigure(Selecteds[a]).GetBoundRect.Top < MinY then begin MinY := TFigure(Selecteds[a]).GetBoundRect.Top; MinFig := TFigure(Selecteds[a]); end; end; Dist := (((MaxFig.GetBoundRect.Top - MaxFig.GetBoundRect.Bottom)/2) + MaxFig.GetBoundRect.Bottom) - (((MinFig.GetBoundRect.Top - MinFig.GetBoundRect.Bottom)/2) + MinFig.GetBoundRect.Bottom); PartDist := Dist / (selecteds.count - 1); FirstCenter := (((MinFig.GetBoundRect.Top - MinFig.GetBoundRect.Bottom)/2) + MinFig.GetBoundRect.Bottom); for a := 0 to Selecteds.count -1 do begin centers[a] := FirstCenter + round(a*PartDist); occupied[a] := false; end; for a := 0 to Selecteds.count - 1 do begin CurrentFig := TFigure(Selecteds[a]); if (CurrentFig <> MinFig) and (CurrentFig <> MaxFig) then begin Center := (((CurrentFig.GetBoundRect.Top - CurrentFig.GetBoundRect.Bottom)/2) + CurrentFig.GetBoundRect.Bottom); MinDist := abs(Centers[1] - center); ocx := 1; for b := 2 to Selecteds.count -2 do if (abs(Centers[b] - center) < MinDist) and (not occupied[b]) then begin MinDist := abs(Centers[b] - center); ocx := b; end; occupied[ocx] := true; MinDist := Centers[ocx] - center; CurrentFig.Move(0,MinDist); end; end; end; if (HorzAlign = haDistHorz) and (selecteds.count > 2) then begin MaxY := TFigure(Selecteds[0]).GetBoundRect.Right; MaxFig := TFigure(Selecteds[0]); MinY := TFigure(Selecteds[0]).GetBoundRect.Right; MinFig := TFigure(Selecteds[0]); for a := 1 to Selecteds.Count - 1 do begin if TFigure(Selecteds[a]).GetBoundRect.Right > MaxY then begin MaxY := TFigure(Selecteds[a]).GetBoundRect.Right; MaxFig := TFigure(Selecteds[a]); end; if TFigure(Selecteds[a]).GetBoundRect.Right < MinY then begin MinY := TFigure(Selecteds[a]).GetBoundRect.Right; MinFig := TFigure(Selecteds[a]); end; end; Dist := (((MaxFig.GetBoundRect.Right - MaxFig.GetBoundRect.Left)/2) + MaxFig.GetBoundRect.Left) - (((MinFig.GetBoundRect.Right - MinFig.GetBoundRect.Left)/2) + MinFig.GetBoundRect.Left); PartDist := Dist / (selecteds.count - 1); FirstCenter := (((MinFig.GetBoundRect.Right - MinFig.GetBoundRect.Left)/2) + MinFig.GetBoundRect.Left); for a := 0 to Selecteds.count -1 do begin centers[a] := FirstCenter + (a*PartDist); occupied[a] := false; end; for a := 0 to Selecteds.count - 1 do begin CurrentFig := TFigure(Selecteds[a]); if (CurrentFig <> MinFig) and (CurrentFig <> MaxFig) then begin Center := (((CurrentFig.GetBoundRect.Right - CurrentFig.GetBoundRect.Left)/2) + CurrentFig.GetBoundRect.Left); for b := 1 to Selecteds.count -2 do begin if (not occupied[b]) then begin MinDist := abs(Centers[b] - center); ocx := b; ocy := b; end; end; for b := ocy+1 to Selecteds.count-2 do if (abs(Centers[b] - center) < MinDist) and (not occupied[b]) then begin MinDist := abs(Centers[b] - center); ocx := b; end; occupied[ocx] := true; MinDist := Centers[ocx] - center; CurrentFig.Move(MinDist,0); end; end; end; for a := 0 to Selecteds.Count - 1 do begin // if a <> RefBlockIdx then begin CustFigure := TFigure(Selecteds[a]); if ssCtrl in GGlobalShiftState then CustRect := CustFigure.GetBoundRect else begin if GCadForm.PCad.ActiveLayer = 2 then CustRect := CustFigure.GetBoundRect(false) else CustRect := CustFigure.GetBoundRect; end; if CanAlign(GCadform.PCad.ActiveLayer, CustFigure) then begin case HorzAlign of haNoChange : begin end; haTop: begin if VerticalZero = vzTop then CustFigure.Move(0,(RefRect.top - CustRect.top)) else CustFigure.Move(0,(RefRect.Bottom - CustRect.Bottom)); end; haBottom: begin if VerticalZero = vzTop then CustFigure.Move(0,(RefRect.Bottom - CustRect.Bottom)) else CustFigure.Move(0,(RefRect.top - CustRect.top)); end; haCenter: begin CustFigure.Move(0,(RefRect.Bottom + ((RefRect.Top-RefRect.Bottom)/2)) - (CustRect.Bottom + ((CustRect.Top-CustRect.Bottom)/2))); end; end; case VertAlign of vaNoChange: begin end; vaLeft: begin if HorizontalZero = vzLeft then CustFigure.Move((RefRect.left - CustRect.left),0) else CustFigure.Move((RefRect.right - CustRect.right),0); end; vaRight: begin if HorizontalZero = vzLeft then CustFigure.Move((RefRect.right - CustRect.right),0) else CustFigure.Move((RefRect.left - CustRect.left),0); end; vaCenter: begin CustFigure.Move((RefRect.Left + ((RefRect.Right-RefRect.Left)/2)) - (CustRect.Left + ((CustRect.Right-CustRect.Left)/2)) ,0); end; end; end; end; end; Selecteds.Free; end; except on E: exception do begin AddExceptionToLog('TPCDrawing.alignSelection' + E.Message); end; end; GCanRefreshCad := RefreshFlag; Updated := True; refresh; end; (* Procedure TPCDrawing.alignSelection(HorzAlign: THorzAligns; VertAlign: TVertAligns); var a,b,ocx,ocy,RefBlockIdx : integer; Selecteds : TList; RefFigure : TFigure; CustFigure : TFigure; MaxFig : TFigure; MinFig : Tfigure; CurrentFig : TFigure; MaxY,MinY : Double; RefRect : TDoubleRect; CustRect : TDoubleRect; HelpRect : TDoubleRect; Found : Boolean; Dist : Double; PartDist : real; centers : array [0..1000] of Double; occupied : array [0..1000] of Boolean; Center, MinDist, FirstCenter: Double; figMaxX,figMaxY,figMinX,figMinY: Double; begin if (GCadForm.PCad.ActiveLayer = 2) then GCadForm.SaveForUndo(uat_None, True, False); Selecteds := TList.Create; collectSelectedFigures(Selecteds); If Selecteds.Count < 2 then exit; RefBlockIdx := 0; a := 0; Found := false; while (a < selecteds.Count) and (not found) do begin If TFigure(Selecteds[a]).firstselected then begin RefBlockIdx := a; found := true; end; inc(a); end; if RecordUndo then RecordModifyUndo(nil); RefFigure := TFigure(Selecteds[RefBlockIdx]); RefRect := RefFigure.GetBoundRect; a := 0; while (a < selecteds.Count) do begin if CanAlign(GCadform.PCad.ActiveLayer, TFigure(Selecteds[a])) then begin if ssCtrl in GGlobalShiftState then RefRect := TFigure(Selecteds[a]).GetBoundRect else begin if GCadForm.PCad.ActiveLayer = 2 then RefRect := TFigure(Selecteds[a]).GetBoundRect(false) else RefRect := TFigure(Selecteds[a]).GetBoundRect; end; break; end; Inc(a); end; a := 0; while (a < selecteds.Count) do begin if CanAlign(GCadform.PCad.ActiveLayer, TFigure(Selecteds[a])) then begin if ssCtrl in GGlobalShiftState then HelpRect := TFigure(Selecteds[a]).GetBoundRect else begin if GCadForm.PCad.ActiveLayer = 2 then HelpRect := TFigure(Selecteds[a]).GetBoundRect(false) else HelpRect := TFigure(Selecteds[a]).GetBoundRect; end; if RefRect.left > HelpRect.left then RefRect.left := HelpRect.left; if RefRect.Right < HelpRect.right then RefRect.Right := HelpRect.Right; if RefRect.top > HelpRect.Top then RefRect.Top := HelpRect.Top; if RefRect.Bottom < HelpRect.Bottom then RefRect.Bottom := HelpRect.Bottom; end; inc(a); end; if (VertAlign = vaDistVert) and (selecteds.count > 2) then begin MaxY := TFigure(Selecteds[0]).GetBoundRect.Top; MaxFig := TFigure(Selecteds[0]); MinY := TFigure(Selecteds[0]).GetBoundRect.Top; MinFig := TFigure(Selecteds[0]); for a := 1 to Selecteds.Count - 1 do begin if TFigure(Selecteds[a]).GetBoundRect.Top > MaxY then begin MaxY := TFigure(Selecteds[a]).GetBoundRect.Top; MaxFig := TFigure(Selecteds[a]); end; if TFigure(Selecteds[a]).GetBoundRect.Top < MinY then begin MinY := TFigure(Selecteds[a]).GetBoundRect.Top; MinFig := TFigure(Selecteds[a]); end; end; Dist := (((MaxFig.GetBoundRect.Top - MaxFig.GetBoundRect.Bottom)/2) + MaxFig.GetBoundRect.Bottom) - (((MinFig.GetBoundRect.Top - MinFig.GetBoundRect.Bottom)/2) + MinFig.GetBoundRect.Bottom); PartDist := Dist / (selecteds.count - 1); FirstCenter := (((MinFig.GetBoundRect.Top - MinFig.GetBoundRect.Bottom)/2) + MinFig.GetBoundRect.Bottom); for a := 0 to Selecteds.count -1 do begin centers[a] := FirstCenter + round(a*PartDist); occupied[a] := false; end; for a := 0 to Selecteds.count - 1 do begin CurrentFig := TFigure(Selecteds[a]); if (CurrentFig <> MinFig) and (CurrentFig <> MaxFig) then begin Center := (((CurrentFig.GetBoundRect.Top - CurrentFig.GetBoundRect.Bottom)/2) + CurrentFig.GetBoundRect.Bottom); MinDist := abs(Centers[1] - center); ocx := 1; for b := 2 to Selecteds.count -2 do if (abs(Centers[b] - center) < MinDist) and (not occupied[b]) then begin MinDist := abs(Centers[b] - center); ocx := b; end; occupied[ocx] := true; MinDist := Centers[ocx] - center; CurrentFig.Move(0,MinDist); end; end; end; if (HorzAlign = haDistHorz) and (selecteds.count > 2) then begin MaxY := TFigure(Selecteds[0]).GetBoundRect.Right; MaxFig := TFigure(Selecteds[0]); MinY := TFigure(Selecteds[0]).GetBoundRect.Right; MinFig := TFigure(Selecteds[0]); for a := 1 to Selecteds.Count - 1 do begin if TFigure(Selecteds[a]).GetBoundRect.Right > MaxY then begin MaxY := TFigure(Selecteds[a]).GetBoundRect.Right; MaxFig := TFigure(Selecteds[a]); end; if TFigure(Selecteds[a]).GetBoundRect.Right < MinY then begin MinY := TFigure(Selecteds[a]).GetBoundRect.Right; MinFig := TFigure(Selecteds[a]); end; end; Dist := (((MaxFig.GetBoundRect.Right - MaxFig.GetBoundRect.Left)/2) + MaxFig.GetBoundRect.Left) - (((MinFig.GetBoundRect.Right - MinFig.GetBoundRect.Left)/2) + MinFig.GetBoundRect.Left); PartDist := Dist / (selecteds.count - 1); FirstCenter := (((MinFig.GetBoundRect.Right - MinFig.GetBoundRect.Left)/2) + MinFig.GetBoundRect.Left); for a := 0 to Selecteds.count -1 do begin centers[a] := FirstCenter + (a*PartDist); occupied[a] := false; end; for a := 0 to Selecteds.count - 1 do begin CurrentFig := TFigure(Selecteds[a]); if (CurrentFig <> MinFig) and (CurrentFig <> MaxFig) then begin Center := (((CurrentFig.GetBoundRect.Right - CurrentFig.GetBoundRect.Left)/2) + CurrentFig.GetBoundRect.Left); for b := 1 to Selecteds.count -2 do begin if (not occupied[b]) then begin MinDist := abs(Centers[b] - center); ocx := b; ocy := b; end; end; for b := ocy+1 to Selecteds.count-2 do if (abs(Centers[b] - center) < MinDist) and (not occupied[b]) then begin MinDist := abs(Centers[b] - center); ocx := b; end; occupied[ocx] := true; MinDist := Centers[ocx] - center; CurrentFig.Move(MinDist,0); end; end; end; for a := 0 to Selecteds.Count - 1 do begin // if a <> RefBlockIdx then begin CustFigure := TFigure(Selecteds[a]); if ssCtrl in GGlobalShiftState then CustRect := CustFigure.GetBoundRect else begin if GCadForm.PCad.ActiveLayer = 2 then CustRect := CustFigure.GetBoundRect(false) else CustRect := CustFigure.GetBoundRect; end; if CanAlign(GCadform.PCad.ActiveLayer, CustFigure) then begin case HorzAlign of haNoChange : begin end; haTop: begin if VerticalZero = vzTop then CustFigure.Move(0,(RefRect.top - CustRect.top)) else CustFigure.Move(0,(RefRect.Bottom - CustRect.Bottom)); end; haBottom: begin if VerticalZero = vzTop then CustFigure.Move(0,(RefRect.Bottom - CustRect.Bottom)) else CustFigure.Move(0,(RefRect.top - CustRect.top)); end; haCenter: begin CustFigure.Move(0,(RefRect.Bottom + ((RefRect.Top-RefRect.Bottom)/2)) - (CustRect.Bottom + ((CustRect.Top-CustRect.Bottom)/2))); end; end; case VertAlign of vaNoChange: begin end; vaLeft: begin if HorizontalZero = vzLeft then CustFigure.Move((RefRect.left - CustRect.left),0) else CustFigure.Move((RefRect.right - CustRect.right),0); end; vaRight: begin if HorizontalZero = vzLeft then CustFigure.Move((RefRect.right - CustRect.right),0) else CustFigure.Move((RefRect.left - CustRect.left),0); end; vaCenter: begin CustFigure.Move((RefRect.Left + ((RefRect.Right-RefRect.Left)/2)) - (CustRect.Left + ((CustRect.Right-CustRect.Left)/2)) ,0); end; end; end; end; end; Selecteds.Free; Updated := True; refresh; end; *) Procedure TPCDrawing.selectall(LayerNbr : integer); var i, a: integer; f: TFigure; invis: Boolean; layer: TLayer; RefreshFlag: Boolean;//Tolik 30/11/2021 -- begin If (LayerNbr < 0) or (LayerNbr > Layers.Count - 1) then exit; //Tolik 30/11/2021 - - RefreshFlag := GCanRefreshCad; GCanRefreshCad := False; Try // for a := 0 to figures.count - 1 do begin f := TFigure(figures[a]); invis := false; if (f.LayerHandle <> 0) then invis := (TLayer(f.LayerHandle).Visible = lost); if (not invis) and (not f.InClip) and (not f.Selected) and ((LayerNbr = 0) or (f.LayerHandle = LongInt(Layers[LayerNbr]))) then begin if not f.LockSelect then begin if f is Tnet then begin TNet(f).SelType := stStruct; TNet(f).SelIndex := 0; end; f.Select; FAnySelected := true; end; end; // если на подложке, а фигура на ДХФ слое if (not invis) and (not f.InClip) and (not f.Selected) and ((LayerNbr = 1) and TLayer(f.LayerHandle).IsDxf {CheckFigureInDXFLayer(f)}) then begin if not f.LockSelect then begin f.Select; FAnySelected := true; end; end; end; ReDrawSelection; SyncEnv; Except On e: Exception do AddExceptionToLog('TPCDrawing.SelectAll' + E.Message); End; GCanRefreshCad := RefreshFlag;//Tolik 30/11/2021- end; //Tolik 30/11/2021 -- старая закомменчена - см. ниже. Здесь выполнена попытка ускорить процесс Procedure TPCDrawing.deselectall(LayerNbr : integer); var a: integer; f: TFigure; stillSelected: Boolean; RefreshFlag: Boolean; begin SelFeed := 0; if not FAnySelected then exit; If (LayerNbr < 0) or (LayerNbr > Layers.Count - 1) then exit; FAnySelected := false; RefreshFlag := GCanRefreshCad; GCanRefreshCad := False; BeginMultiDeselect; //02.04.2012 try if LayerNbr = 0 then begin for a := 0 to figures.count - 1 do begin f := TFigure(figures[a]); if f.Selected then begin f.Deselect; end end; end else // если на подложке, а фигура на ДХФ слое if LayerNbr = 1 then begin for a := 0 to figures.count - 1 do begin f := TFigure(figures[a]); if (TLayer(f.LayerHandle).IsDxf and (f.Selected)) then begin if not f.LockSelect then begin f.Deselect; end; end else if f.Selected then begin FAnySelected := True; end; end; end else begin for a := 0 to figures.count - 1 do begin f := TFigure(figures[a]); if ((f.LayerHandle = LongInt(Layers[LayerNbr])) and (f.Selected)) then begin f.Deselect; end else if f.Selected then begin FAnySelected := True; end; end; end; finally EndMultiDeselect; //02.04.2012 end; GCanRefreshCad := RefreshFlag; RedrawSelection; SyncEnv; end; (* Procedure TPCDrawing.deselectall(LayerNbr : integer); var a: integer; f: TFigure; stillSelected: Boolean; begin SelFeed := 0; if not FAnySelected then exit; If (LayerNbr < 0) or (LayerNbr > Layers.Count - 1) then exit; FAnySelected := false; BeginMultiDeselect; //02.04.2012 try for a := 0 to figures.count - 1 do begin f := TFigure(figures[a]); if ((LayerNbr = 0) or (f.LayerHandle = LongInt(Layers[LayerNbr]))) and (f.Selected) then begin f.Deselect; end else if f.Selected then begin FAnySelected := True; end; // если на подложке, а фигура на ДХФ слое if ((LayerNbr = 1) and TLayer(f.LayerHandle).IsDxf {CheckFigureInDXFLayer(f)}) and (f.Selected) then begin if not f.LockSelect then begin f.Deselect; end; end else if f.Selected then begin FAnySelected := True; end; end; finally EndMultiDeselect; //02.04.2012 end; RedrawSelection; SyncEnv; end; *) Procedure TPCDrawing.InvertSelection; var a: integer; f: TFigure; begin if not FAnySelected then exit; for a := 0 to figures.count-1 do begin f := TFigure(figures[a]); if (f.Selected) then begin f.Deselect; end else begin f.Select; end; end; Refresh; SyncEnv; end; Function TPCDrawing.groupselection: TFigHandle; var grpId: integer; a: integer; Fig: Tfigure; grp: TFigureGrp; sel: TList; cnt: integer; LHandle: LongInt; xAction: TUndoAction; zOrder: Integer; RefFig: Pointer; isLast: Boolean; begin result := 0; sel := TList.Create; collectselectedFigures(sel); cnt := sel.count; sel.Clear; //Tolik -- 07/02/2017 -- if cnt = 0 then begin FreeAndNil(Sel); // --шлепать нужно, раз создали!!! exit; end; if RecordUndo then begin xAction := TUndoAction.Create(uaGroup); end; grp := TfigureGrp.create(LongInt(Layers[0]), self); if RecordUndo then xAction.List.Add(grp); LHandle := 0; zOrder := 0; RefFig := nil; isLast := False; try BeginMultiDeselect; //02.04.2012 try for a := figures.count - 1 downto 0 do begin Fig := Tfigure(figures[a]); if fig.Selected then begin if not(Fig.ClassName = 'TCabinet') and not(Fig.ClassName = 'TCabinetNumber') then begin if (RefFig = nil) and (not isLast) then begin if a = figures.count - 1 then isLast := True else RefFig := Figures[a + 1]; end; //02.04.2012 fig.Deselect; //02.04.2012 sel.Add(fig); //02.04.2012 figures.Remove(fig); //02.04.2012 LHandle := fig.LayerHandle; //02.04.2012 - для выделения запоминаем в списке sel.Add(fig); LHandle := fig.LayerHandle; end; end; end; //02.04.2012 - снимаем выделение в нормельном порядке, а не обратном (обратный от первого цыкла, который обратный for a := figures.count - 1), //02.04.2012 чтобы на UnRegisterModPoint при поиске индекса точки в ModPoints ее индекс был вначале (меньше перебора) for a := sel.Count - 1 downto 0 do TFigure(sel[a]).Deselect; //02.04.2012 Удаляем из списка figures в том порядке в котором был первый цыкл (чтобы удаление шло с конца списка figures - так быстрее) for a := 0 to sel.Count - 1 do figures.Remove(sel[a]); finally EndMultiDeselect; //02.04.2012 end; except // on E: Exception do AddExceptionToLog(CPowerCadMessage + 'TPCDrawing.groupselection' + E.Message); end; for a := sel.count - 1 downto 0 do begin grp.AddFigure(sel[a], false); end; grp.ResetRegion; sel.free; grp.LayerHandle := LHandle; grp.select; if (isLast) or (RefFig = nil) then figures.Add(grp) else begin Zorder := Figures.indexOf(RefFig); if zOrder = -1 then figures.Add(grp) else figures.Insert(zOrder,grp); end; result := grp.Handle; if RecordUndo then begin InsertUndoAction(xAction); end; grp.CreateMetaFile; refresh; Updated := True; end; // Tolik -- 30/11/2021 -- procedure TPCDrawing.ungroupselection; var a: integer; fig: TFigure; xAction: TUndoAction; RefreshFlag :Boolean; begin RefreshFlag := GCanRefreshCad; GCanRefreshCad := False; try // Tolik -- 12/12/2016 -- if GCadForm.FNotSCSDeletedFiguresList = nil then GCadForm.FNotSCSDeletedFiguresList := TList.Create; // if RecordUndo then xAction := TUndoAction.Create(uaUnGroup); for a := figures.count - 1 downto 0 do begin fig := TFigure(figures[a]); if (TFigure(fig) is TFigureGrp) and (TFigure(fig).selected) then begin if not TFigureGrp(fig).AlwaysTogether then begin TFigureGrp(fig).UnGroup; if RecordUndo then xAction.List.Add(fig); // Tolik //Fig.deleted := True; if GCadForm.FNotSCSDeletedFiguresList.IndexOf(fig) = -1 then GCadForm.FNotSCSDeletedFiguresList.Add(fig); // figures.Delete(a); //13.03.2012 - не удаляем, так как объект может запоминатся для отката - xAction.List.Add(fig) //13.03.2012 TFigureGrp(fig).InFigures.Clear; //30.05.2011 //13.03.2012 fig.Free; //30.05.2011 end; end; end; if RecordUndo then begin if xAction.List.Count > 0 then begin InsertUndoAction(xAction); end else begin xAction.Free; end; end; //refresh; //Updated := True; except on E: Exception do AddExceptionToLog(CPowerCadMessage + 'TPCDrawing.ungroupselection' + E.Message); end; GCanRefreshCad := RefreshFlag; refresh; Updated := True; end; (* // Tolik -- 07/12/2016 -- // тут немножко переписано, чтобы удалить групповую фигуру, а то как-то непонятно, куда она делась procedure TPCDrawing.ungroupselection; var a: integer; fig: TFigure; xAction: TUndoAction; begin try // Tolik -- 12/12/2016 -- if GCadForm.FNotSCSDeletedFiguresList = nil then GCadForm.FNotSCSDeletedFiguresList := TList.Create; // if RecordUndo then xAction := TUndoAction.Create(uaUnGroup); for a := figures.count - 1 downto 0 do begin fig := TFigure(figures[a]); if (TFigure(fig) is TFigureGrp) and (TFigure(fig).selected) then begin if not TFigureGrp(fig).AlwaysTogether then begin TFigureGrp(fig).UnGroup; if RecordUndo then xAction.List.Add(fig); // Tolik //Fig.deleted := True; if GCadForm.FNotSCSDeletedFiguresList.IndexOf(fig) = -1 then GCadForm.FNotSCSDeletedFiguresList.Add(fig); // figures.Delete(a); //13.03.2012 - не удаляем, так как объект может запоминатся для отката - xAction.List.Add(fig) //13.03.2012 TFigureGrp(fig).InFigures.Clear; //30.05.2011 //13.03.2012 fig.Free; //30.05.2011 end; end; end; if RecordUndo then begin if xAction.List.Count > 0 then begin InsertUndoAction(xAction); end else begin xAction.Free; end; end; refresh; Updated := True; except // on E: Exception do AddExceptionToLog(CPowerCadMessage + 'TPCDrawing.ungroupselection' + E.Message); end; end; *) (* procedure TPCDrawing.ungroupselection; var a: integer; fig: TFigure; xAction: TUndoAction; begin try if RecordUndo then xAction := TUndoAction.Create(uaUnGroup); for a := figures.count - 1 downto 0 do begin fig := TFigure(figures[a]); if (TFigure(fig) is TFigureGrp) and (TFigure(fig).selected) then begin if not TFigureGrp(fig).AlwaysTogether then begin TFigureGrp(fig).UnGroup; if RecordUndo then xAction.List.Add(fig); figures.Delete(a); //13.03.2012 - не удаляем, так как объект может запоминатся для отката - xAction.List.Add(fig) //13.03.2012 TFigureGrp(fig).InFigures.Clear; //30.05.2011 //13.03.2012 fig.Free; //30.05.2011 end; end; end; if RecordUndo then begin if xAction.List.Count > 0 then begin InsertUndoAction(xAction); end else begin xAction.Free; end; end; refresh; Updated := True; except // on E: Exception do AddExceptionToLog(CPowerCadMessage + 'TPCDrawing.ungroupselection' + E.Message); end; end; *) Procedure TPCDrawing.BoundSelectedLine; var BLine: Tfigure; a: integer; begin For a := 0 to Selection.Count-1 do begin BLine := TFigure(Selection[a]); if (BLine is DrawObjects.TLine) or (BLine is TPolyLine) then begin BoundLinePoint(TfigHandle(BLine),1,BLine.ActualPoints[1]); BoundLinePoint(TFigHandle(BLine),BLine.PointCount,BLine.ActualPoints[Bline.PointCount]) end; end; refresh; Updated := True; end; Procedure TPCDrawing.BoundLineToFigures(BLine:TFigHandle; jf1,jf2: TFigHandle); var b,j1,j2: TFigure; begin b := TFigure(BLine); j1 := TFigure(jf1); j2 := TFigure(jf2); if B is DrawObjects.TLine then begin DrawObjects.TLine(B).SetJFigure1(j1); DrawObjects.TLine(B).SetJFigure2(j2); end else if B is TPolyLine then begin TPolyLine(B).SetJFigure1(j1); TPolyLine(B).SetJFigure2(j2); end; refresh; Updated := True; end; Procedure TPCDrawing.BoundLinePoint(BLine:TFigHandle; seqnbr: integer; bPoint: TDoublepoint); var a,i,x: integer; Layer: TLayer; Fig: Tfigure; b: TFigure; begin b := TFigure(BLine); for a := figures.count - 1 downto 0 do begin Fig := Tfigure(figures[a]); if (fig <> B) and (fig.isPointIn(bPoint.x,bPoint.y)) then begin if B is DrawObjects.TLine then begin if seqnbr = 1 then DrawObjects.TLine(B).SetJFigure1(fig) else if seqnbr = 2 then DrawObjects.TLine(B).SetJFigure2(fig); end else if B is TPolyLine then begin if seqnbr = 1 then TPolyLine(B).SetJFigure1(fig) else if seqnbr = B.PointCount then TpolyLine(B).SetJFigure2(fig); end; end; end; refresh; Updated := True; end; Procedure TPCDrawing.UnBoundLine; var a: integer; begin for a := 0 to figures.count - 1 do begin if TFigure(figures[a]).selected then begin if (TFigure(figures[a]) is DrawObjects.TLine) then DrawObjects.TLine(figures[a]).UnBound else if (TFigure(figures[a]) is TPolyLine) then TPolyLine(figures[a]).UnBound; end; end; refresh; Updated := True; end; procedure TPCDrawing.GetLineJoins(var lines: TstringList); var a: integer; jf: Tfigure; begin For a:= 0 to Figures.Count-1 do begin if (TFigure(Figures[a]) is DrawObjects.TLine) then begin jf :=DrawObjects. TLine(Figures[a]).JoinFigure1; if jf <> nil then Lines.Add(' JoinLE1 = '+ DrawObjects.TLine(Figures[a]).Name+','+ TFigure(jf).Name); jf := DrawObjects.TLine(Figures[a]).JoinFigure2; if jf <> nil then Lines.Add(' JoinLE2 = '+ DrawObjects.TLine(Figures[a]).Name+','+TFigure(jf).Name); end; if (TFigure(Figures[a]) is TPolyLine) then begin jf := TPolyLine(Figures[a]).JoinFigure1; if jf <> nil then Lines.Add(' JoinPE1 = '+ TPolyLine(Figures[a]).Name+','+TFigure(jf).Name); jf := TPolyLine(Figures[a]).JoinFigure2; if jf <> nil then Lines.Add(' JoinPE2 = '+ TPolyLine(Figures[a]).Name+','+TFigure(jf).Name); end; end; end; procedure TPCDrawing.OrderSelection(Dest: TOrderStyle); var a, x, fronted, backed: integer; Figure: TFigure; xAction: TUndoAction; i: integer; BackList: TList; UnselectList: TList; LHBack: integer; LHSCSCommon: integer; NeedReOrderSubstr: boolean; begin try NeedReOrderSubstr := False; if not FAnySelected then exit; BackList := TList.Create; UnselectList := TList.Create; LHBack := GetLayerHandle(lnSubstrate); LHSCSCommon := GetLayerHandle(lnSCSCommon); if RecordUndo then xAction := TUndoAction.Create(uaOrder); for a := 0 to figures.count - 1 do begin Figure := TFigure(figures[a]); if Figure.LayerHandle = LHBack then BackList.Add(Figure); if Figure.Selected then begin if (Dest = osBack) and (Figure.LayerHandle = LHSCSCommon) then NeedReOrderSubstr := True; if CheckFigureByClassName(Figure, cTConnectorObject) then begin if TConnectorObject(Figure).ConnectorType <> ct_Clear then begin if TConnectorObject(Figure).DrawFigure <> nil then begin if Not TConnectorObject(Figure).DrawFigure.Selected then UnselectList.Add(TConnectorObject(Figure).DrawFigure); TConnectorObject(Figure).DrawFigure.Selected := True; // в принципе можно без этого //for i := 0 to TConnectorObject(Figure).DrawFigure.InFigures.Count - 1 do //begin // if Not TFigure(TConnectorObject(Figure).DrawFigure.InFigures[i]).Selected then // UnselectList.Add(TConnectorObject(Figure).DrawFigure.InFigures[i]); // TFigure(TConnectorObject(Figure).DrawFigure.InFigures[i]).Selected := true; //end; end; end; end; if CheckFigureByClassName(Figure, cTOrthoLine) then begin if TOrthoLine(Figure).DrawFigure <> nil then begin if Not TOrthoLine(Figure).DrawFigure.Selected then UnselectList.Add(TOrthoLine(Figure).DrawFigure); TOrthoLine(Figure).DrawFigure.Selected := True; end; end; end; end; if (Dest = osFront) or (Dest = osBWard) then begin fronted := 0; for a := 0 to figures.count-1 do begin Figure := TFigure(figures[a-fronted]); if Figure.Selected then Begin if RecordUndo then xAction.List.Add(Figure); if RecordUndo then xAction.Params.Add(Pointer(a)); if Dest = osFront then begin figures.Move(a-fronted,figures.count-1); if RecordUndo then xAction.RedoList.Add(Pointer(figures.count-1)); inc(fronted); if RecordUndo then xAction.FIndex := 0; end else if Dest = osBWard then begin if a > 0 then figures.Exchange(a,a-1); if RecordUndo then xAction.FIndex := 1; if RecordUndo then xAction.RedoList.Add(Pointer(a-1)); end; end; end; end else begin Backed := 0; for a := 0 to figures.count-1 do begin x := figures.count-1-a; Figure := TFigure(figures[x+backed]); if Figure.Selected then Begin if RecordUndo then xAction.List.Add(Figure); if RecordUndo then xAction.Params.Add(Pointer(x)); if Dest = osBack then begin figures.move(x+backed,0); inc(Backed); if RecordUndo then xAction.FIndex := 0; if RecordUndo then xAction.RedoList.Add(Pointer(0)); end else if dest = osFWard then begin if x < figures.count -1 then figures.exchange(x,x+1); if RecordUndo then xAction.FIndex := 1; if RecordUndo then xAction.RedoList.Add(Pointer(x+1)); end; end; end; end; for a := 0 to UnselectList.count-1 do begin Figure := TFigure(UnselectList[a]); Figure.Selected := False; end; UnselectList.Clear; FreeAndNil(UnselectList); if NeedReOrderSubstr then begin Backed := 0; for a := 0 to figures.count-1 do begin x := figures.count-1-a; Figure := TFigure(figures[x+backed]); if BackList.IndexOf(Figure) <> -1 then Begin if RecordUndo then xAction.List.Add(Figure); if RecordUndo then xAction.Params.Add(Pointer(x)); figures.move(x+backed,0); inc(Backed); if RecordUndo then xAction.FIndex := 0; if RecordUndo then xAction.RedoList.Add(Pointer(0)); end; end; end; BackList.Clear; FreeAndNil(BackList); if RecordUndo then begin if xAction.List.Count > 0 then begin InsertUndoAction(xAction); end else xAction.Free; end; refresh; Updated := True; except // on E: Exception do AddExceptionToLog(CPowerCadMessage + 'TPCDrawing.OrderSelection' + E.Message); end; End; procedure TPCDrawing.OrderFigureToFront(aFigure: TFigure); var Index: Integer; begin try Index := Figures.IndexOf(aFigure); // Tolik 13/06/2017 -- if Index <> -1 then // begin figures.Move(Index, figures.count - 1); refresh; Updated := True; end; except on E: Exception do AddExceptionToLog('TPCDrawing.OrderFigureToFront' + E.Message); end; end; procedure TPCDrawing.OrderFigureToBack(aFigure: TFigure); var Index: Integer; begin try Index := Figures.IndexOf(aFigure); figures.move(Index, 0); refresh; Updated := True; except on E: Exception do AddExceptionToLog('TPCDrawing.OrderFigureToBack' + E.Message); end; end; (* procedure TPCDrawing.RemoveSelection; var a,max,k: integer; xAction: TUndoAction; CanDelete:Boolean; fig: TFigure; begin try if not FAnySelected then exit; a := 0; max := figures.count - 1; ResetRemoveSelection := False; if RecordUndo then xAction := TUndoAction.Create(uaRemove); while a <= max do begin if TFigure(figures[a]).selected then begin CanDelete := True; if assigned(FOnFigureDel) then FOnFigureDel(Self,figures[a],CanDelete); if CanDelete then begin {TFigure(figures[a]).deselect; TFigure(figures[a]).Deleted := True;} if not RecordUndo then begin // Tolik // TFigure(figures[a]).ClipFigures.Clear -- выполнится на деструкторе фигуры {for k := 0 to TFigure(figures[a]).ClipFigures.Count - 1 do begin figures.Remove(TFigure(figures[a]).ClipFigures[k]); end;} //Tolik 26/10/2015 //TFigure(figures[a]).destroy; // TFigure(Figures[a]).free; { if CheckFigureByClassName(TFigure(figures[a]), cTOrthoLine) then TOrthoLine(figures[a]).delete else if CheckFigureByClassName(TFigure(figures[a]), cTConnectorObject) then TConnectorObject(figures[a]).Delete(true) else if CheckFigureByClassName(TFigure(figures[a]), cTCabinet) then TCabinet(figures[a]).Delete else if CheckFigureByClassName(TFigure(figures[a]), cTCabinetExt) then TCabinetExt(figures[a]).Delete else if CheckFigureByClassName(TFigure(figures[a]), cTPlanObject) then TPlanObject(figures[a]).Delete else if CheckFigureByClassName(TFigure(figures[a]), cTPlanConnector) then TPlanConnector(figures[a]).Delete else if CheckFigureByClassName(TFigure(figures[a]), cTPlanTrace) then TPlanTrace(figures[a]).Delete else if CheckFigureByClassName(TFigure(figures[a]), cTSCSFigureGrp) then TSCSFigureGrp(figures[a]).Delete else if CheckFigureByClassName(TFigure(figures[a]), cTHouse) then THouse(figures[a]).Delete; } // end; if RecordUndo then begin xAction.List.Add(figures[a]); TFigure(figures[a]).Urc := TFigure(figures[a]).Urc+1; TFigure(figures[a]).DelIndex := a; end; fig := TFigure(figures[a]); if recordundo then begin for k := 0 to fig.ClipFigures.Count-1 do begin TFigure(fig.ClipFigures[k]).inClip := False; end; end; figures.Remove(fig); max := max -1; a := a - 1; if assigned(FOnAfterFigureDel) then FOnAfterFigureDel(Self); end else begin if ResetRemoveSelection then begin a := -1; max := figures.count - 1; ResetRemoveSelection := False; end; end; end; inc (a); end; if RecordUndo then begin InsertUndoAction(xAction); end; refresh; Updated := True; except // on E: Exception do AddExceptionToLog(CPowerCadMessage + 'TPCDrawing.RemoveSelection' + E.Message); end; end; *) procedure TPCDrawing.RemoveSelection; var a,max,k, i: integer; xAction: TUndoAction; CanDelete:Boolean; fig: TFigure; DeletedNotSCSFigureIndex: Integer; FlagChecked: Boolean; //Tolik 21/04/2017 -- CanDeleteFigure: boolean; DelFiguresIDList: TIntList; FigureToDel : TFigure; CurrFigureIndex: Integer; GroupUpdateFlag: Boolean; CanRefreshFlag: Boolean; function GetFiguresToDelList: TIntList; var i: Integer; begin Result := TIntList.Create; (* for i := 0 to Figures.Count - 1 do begin if TFigure(Figures[i]).Selected and (not TFigure(Figures[i]).deleted) and (Result.IndexOf(TFigure(Figures[i]).ID) = -1) then Result.Add(TFigure(Figures[i]).ID); end; *) for i := 0 to Figures.Count - 1 do begin TFigure(Figures[i]).id_for_dellist := -1; if TFigure(Figures[i]).Selected and (not TFigure(Figures[i]).deleted) and (Result.IndexOf(i) = -1) then begin TFigure(Figures[i]).id_for_dellist := i; Result.Add(i); end; end; end; // function GetFigureToDelByID(FigureId: Integer): TFigure; var i: Integer; begin Result := nil; CurrFigureIndex := -1; (* for i := 0 to Figures.Count - 1 do begin if TFigure(Figures[i]).Id = FigureID then begin FigureToDel.id_for_dellist := -1; Result := TFigure(Figures[i]); CurrFigureIndex := i; Break; //// BREAK ////; end; end; *) for i := 0 to Figures.Count - 1 do begin if TFigure(Figures[i]).id_for_dellist = FigureID then begin Result := TFigure(Figures[i]); Result.id_for_dellist := -1; CurrFigureIndex := i; Break; //// BREAK ////; end; end; end; begin try // Tolik -- 12/12/2016 -- FlagChecked := True; CanRefreshFlag := GCanRefreshCad; GCanRefreshCad := False; if GCadForm.FNotSCSDeletedFiguresList = nil then GCadForm.FNotSCSDeletedFiguresList := TList.Create; // if not FAnySelected then begin GCanRefreshCad := CanRefreshFlag; exit; end; a := 0; max := figures.count - 1; ResetRemoveSelection := False; if RecordUndo then xAction := TUndoAction.Create(uaRemove); // Tolik -- 21/04/2017 -- DelFiguresIDList := GetFiguresToDelList; //Tolik 26/06/2017 -- //Selection.clear; //Tolik 22/11/2019 -- если будет отмена удаления, фигуры останутся выбранными а список будет пустой(нехоросо) // try //Tolik 22/04/2017 -- BeginProgress; GroupUpDateFlag := GisGroupUpdate; GisGroupUpdate := True; // for i := 0 to DelFiguresIDList.Count - 1 do begin FigureToDel := GetFigureToDelByID(DelFiguresIDList[i]); if FigureToDel <> nil then begin CanDelete := True; if assigned(FOnFigureDel) then FOnFigureDel(Self,FigureToDel,CanDelete); if CanDelete then begin FigureToDel.deselect; if not RecordUndo then begin for k := 0 to FigureToDel.ClipFigures.Count - 1 do begin figures.Remove(FigureToDel.ClipFigures[k]); end; Figures.Remove(FigureToDel); if Assigned(Self.Owner) then TF_CAD(Self.Owner).FRemFigures.Remove(FigureToDel); FigureToDel.destroy; end else if RecordUndo then begin xAction.List.Add(FigureToDel); FigureToDel.Urc := FigureToDel.Urc + 1; FigureToDel.DelIndex := CurrFigureIndex; fig := FigureToDel; for k := 0 to fig.ClipFigures.Count - 1 do begin TFigure(fig.ClipFigures[k]).inClip := False; end; figures.Remove(fig); // здесь ловим удаленные НЕ СКС фигуры if not Fig.deleted then begin fig.Deleted := True; //Tolik 26/11/2021 -- //DeletedNotSCSFigureIndex := GCadForm.FNotSCSDeletedFiguresList.IndexOf(Fig); //if DeletedNotSCSFigureIndex = -1 then if GCadForm.FNotSCSDeletedFiguresList.IndexOf(Fig) = -1 then // GCadForm.FNotSCSDeletedFiguresList.Add(fig); end; end; if assigned(FOnAfterFigureDel) then FOnAfterFigureDel(Self); end; end; end; GisGroupUpdate := GroupUpDateFlag; EndProgress; // Tolik 22/04/2017 -- except on E: exception do begin GisGroupUpdate := GroupUpDateFlag; EndProgress; AddExceptionToLog('TPCDrawing.RemoveSelection' + E.Message); end; // end; // //Tolik --17/11/2015 // while a <= max do (* while a <= (figures.count - 1) do begin if TFigure(figures[a]).selected then for a := 0 to Figures.Count - 1 do begin if TFigure(figures[a]).selected then begin if assigned(FOnFigureDel) then FOnFigureDel(Self,figures[a],CanDelete); if CanDelete then begin TFigure(figures[a]).deselect; // TFigure(figures[a]).Deleted := True; if not RecordUndo then begin for k := 0 to TFigure(figures[a]).ClipFigures.Count - 1 do begin figures.Remove(TFigure(figures[a]).ClipFigures[k]); end; TFigure(figures[a]).destroy; end; if RecordUndo then begin xAction.List.Add(figures[a]); TFigure(figures[a]).Urc := TFigure(figures[a]).Urc + 1; TFigure(figures[a]).DelIndex := a; end; fig := TFigure(figures[a]); if recordundo then begin for k := 0 to fig.ClipFigures.Count - 1 do begin TFigure(fig.ClipFigures[k]).inClip := False; end; end; figures.Remove(fig); // здесь ловим удаленные НЕ СКС фигуры if not Fig.deleted then begin fig.Deleted := True; DeletedNotSCSFigureIndex := GCadForm.FNotSCSDeletedFiguresList.IndexOf(Fig); if DeletedNotSCSFigureIndex = -1 then GCadForm.FNotSCSDeletedFiguresList.Add(fig); end; // //max := max - 1; //a := a - 1; if assigned(FOnAfterFigureDel) then FOnAfterFigureDel(Self); end else begin if ResetRemoveSelection then begin a := -1; max := figures.count - 1; ResetRemoveSelection := False; end; end; end; // Tolik -- 17/11/2105 if max = (figures.count - 1) then inc(a) else begin a := a - (max - figures.count); if a < 0 then a := 0; end; max := figures.count - 1; // end; end; *) if RecordUndo then begin InsertUndoAction(xAction); end; {BeginProgress; EndProgress;} //FlagChecked := False; //GCanRefreshCad := True; refresh; Updated := True; except on E: Exception do AddExceptionToLog(CPowerCadMessage + 'TPCDrawing.RemoveSelection' + E.Message); end; DelFiguresIDList.Free; //GCanRefreshCad := True; // оно конечно GCanRefreshCad := True; вроде и хорошо бы сделать именно здесь // но есть вероятность что вызов RemoveSelection делается где-то по коду а не только юзером поэтому пока что просто // восстановим флажок GCanRefreshCad := CanRefreshFlag; Refresh; Self.SetFocus; end; Procedure TPCDrawing.ModifySelection(mm : TModifyMode; value: integer); var a: Integer; Begin if not FAnySelected then exit; if RecordUndo then RecordModifyUndo(nil); for a := 0 to figures.count - 1 do begin if TFigure(figures[a]).selected then begin TFigure(figures[a]).modifySelection(mm,value); if assigned(FFigureModify) then FFigureModify(Self,TFigure(figures[a])); end; end; refresh; Updated := True; end; Procedure TPCDrawing.ModifyFontName(value:String); begin ModifyTextAndFont(mmFontName,0,value,[],True); end; Procedure TPCDrawing.ModifyFontBold(value:Boolean); begin ModifyTextandFont(mmFontBold,0,'',[],Value); end; Procedure TPCDrawing.ModifyFontItalic(value:Boolean); begin ModifyTextandFont(mmFontItalic,0,'',[],Value); end; Procedure TPCDrawing.ModifyFontUnderline(value:Boolean); begin ModifyTextandFont(mmFontUnderline,0,'',[],Value); end; Procedure TPCDrawing.ModifyFontStrike(value:Boolean); begin ModifyTextandFont(mmFontStrike,0,'',[],Value); end; Procedure TPCDrawing.ModifyFontSize(value:Double); begin DefaultTextHeight := Value; end; Procedure TPCDrawing.ModifyFontCharset(value:Integer); begin ModifyTextandFont(mmFontCs,csArray[value],'',[],True); end; Procedure TPCDrawing.ModifyFontColor(value:TColor); begin ModifyTextandFont(mmFontColor,value,'',[],True); end; Procedure TPCDrawing.ModifyPenColor(value:TColor); begin DefaultPenColor := Value; end; Procedure TPCDrawing.ModifyBrushColor(value:TColor); begin DefaultBrushColor := Value; end; Procedure TPCDrawing.ModifyPenStyle(value:TPenStyle); begin DefaultPenStyle := Value; end; Procedure TPCDrawing.ModifyBrushStyle(value:TBrushStyle); begin DefaultBrushStyle := Value; end; Procedure TPCDrawing.ModifyRowStyle(value:TRowStyle); begin DefaultRowStyle := Value; end; Procedure TPCDrawing.ModifyPenWidth(value:Integer); begin DefaultPenWidth := Value; end; Procedure TPCDrawing.ModifyTextandFont(mm: TModifyMode; valueI: Double; valueS: string; valueSt: TFontStyles;ValueB:Boolean); var a: Integer; res: Boolean; Begin res := false; if RecordUndo then if Selection.Count > 0 then RecordModifyUndo(nil); for a := 0 to Selection.count - 1 do begin if TFigure(Selection[a]).selected then begin if TFigure(Selection[a]).modifyTextandFont(mm,valueI,valueS,valueSt,ValueB) then res := true; if assigned(FFigureModify) then FFigureModify(Self,TFigure(figures[a])); end; end; if res then begin refresh; SyncEnv; end else begin if mm = mmFontName then Font.Name := valueS else if mm = mmFontCs then Font.Charset := Round(valueI) else if mm = mmFontColor then Font.Color := Round(valueI) else if mm = mmFontStyle then Font.Style := valueSt else if mm = mmFontBold then begin if ValueB then Font.Style := Font.Style + [fsBold] else Font.Style := Font.Style - [fsBold];end else if mm = mmFontItalic then begin if ValueB then Font.Style := Font.Style + [fsItalic] else Font.Style := Font.Style - [fsItalic];end else if mm = mmFontUnderline then begin if ValueB then Font.Style := Font.Style + [fsUnderline] else Font.Style := Font.Style - [fsUnderline];end else if mm = mmFontStrike then begin if ValueB then Font.Style := Font.Style + [fsStrikeOut] else Font.Style := Font.Style - [fsStrikeOut];end; refresh; SyncEnv; Updated := True; end; end; Function TPCDrawing.IsTextSelected:Boolean; var a: Integer; Begin if not FAnySelected then exit; for a := 0 to Selection.count - 1 do begin if TFigure(Selection[a]) is TText then begin result := True; exit; end; end; end; Procedure TPCDrawing.InvertArcsOfSelection; var a: Integer; xAction:TUndoAction; s:TMemoryStream; Begin if not FAnySelected then exit; if RecordUndo then xAction:= TundoAction.Create(uaModify); for a := 0 to Selection.Count-1 do begin if (Tfigure(Selection[a]) is TArc) then begin if RecordUndo then AddFigureToModifyUndo(xAction,Selection[a]); TArc(Selection[a]).Invert; Updated := True; end; end; if RecordUndo then begin if xAction.List.Count >0 then begin InsertUndoAction(xAction); end else xAction.free; end; refresh; end; Procedure TPCDrawing.ArrangeArcStyleOfSelection(value: TarcStyle); var a: Integer; xAction:TUndoAction; s:TMemoryStream; found:Boolean; Begin found := false; if RecordUndo then xAction:= TundoAction.Create(uaModify); for a := 0 to Selection.Count-1 do begin if (Tfigure(Selection[a]) is TArc) or (Tfigure(Selection[a]) is TElpArc) then begin if RecordUndo then AddFigureToModifyUndo(xAction,Selection[a]); if (Tfigure(Selection[a]) is TArc) then TArc(Selection[a]).ArrangeStyle(value) else if (Tfigure(Selection[a]) is TElpArc) then TElpArc(Selection[a]).ArrangeStyle(value); Updated := True; Found:= True; end; end; if not found then fDefArcStyle := value; if RecordUndo then begin if xAction.List.Count > 0 then begin InsertUndoAction(xAction); end else xAction.free; end; refresh; end; Procedure TPCDrawing.CloseSelectedPolyline; var a: integer; xAction: TUndoAction; Found:Boolean; begin Found := False; if RecordUndo then xAction := TUndoAction.Create(uaModify); for a := 0 to Selection.Count-1 do begin if TFigure(Selection[a]) is TpolyLine then begin if RecordUndo then AddFigureToModifyUndo(xAction,Selection[a]); TpolyLine(Selection[a]).Closed := True; Updated := True; Found := True; end; end; if not found then fDefPLineClosed := True; if RecordUndo then begin if xAction.List.Count > 0 then begin InsertUndoAction(xAction); end else begin xAction.Free; end; end; refresh; end; Procedure TPCDrawing.OpenSelectedPolyline; var a: integer; xAction: TUndoAction; found: Boolean; begin Found := False; if RecordUndo then xAction := TUndoAction.Create(uaModify); for a := 0 to Selection.Count-1 do begin if TFigure(Selection[a]) is TpolyLine then begin if RecordUndo then AddFigureToModifyUndo(xAction,Selection[a]); TpolyLine(Selection[a]).Closed := False; Updated := True; Found:= True; end; end; if not found then fDefPLineClosed := False; if RecordUndo then begin if xAction.List.Count > 0 then begin InsertUndoAction(xAction); end else begin xAction.Free; end; end; refresh; end; Procedure TPCDrawing.ConvertPLToBezier; var a: integer; xAction: TUndoAction; begin if RecordUndo then xAction := TUndoAction.Create(uaModify); for a := 0 to Selection.Count-1 do begin if TFigure(Selection[a]) is TpolyLine then begin if RecordUndo then AddFigureToModifyUndo(xAction,Selection[a]); TpolyLine(Selection[a]).ConvertToBezier; Updated := True; end; end; if RecordUndo then begin if xAction.List.Count > 0 then begin InsertUndoAction(xAction); end else begin xAction.Free; end; end; refresh; end; Procedure TPCDrawing.ConvertPlToPolyline; var a: integer; xAction: TUndoAction; begin if RecordUndo then xAction := TUndoAction.Create(uaModify); for a := 0 to Selection.Count-1 do begin if TFigure(Selection[a]) is TpolyLine then begin if RecordUndo then AddFigureToModifyUndo(xAction,Selection[a]); TpolyLine(Selection[a]).ConvertToPolyLine; Updated := True; end; end; if RecordUndo then begin if xAction.List.Count > 0 then begin InsertUndoAction(xAction); end else begin xAction.Free; end; end; refresh; end; Procedure TPCDrawing.FlipImagesOfSelection(FlipMode: TFlipMode); var a: Integer; xAction:TUndoAction; Begin if not FAnySelected then exit; if RecordUndo then xAction := TUndoAction.Create(uaModify); for a := 0 to Selection.count-1 do If (Tfigure(Selection[a]) is TBMPObject) then begin if RecordUndo then AddFigureToModifyUndo(xAction,Selection[a]); If flipMode = fmHorz then TBMPObject(Selection[a]).FlipHorz else TBMPObject(Selection[a]).FlipVert; Updated := True; end; if RecordUndo then begin if xAction.List.Count > 0 then begin InsertUndoAction(xAction); end else begin xAction.Free; end; end; refresh; end; Procedure TPCDrawing.OffSetSelection(Thick:Double); var selecteds : TList; a,x : integer; fig : TFigure; newFig : TFigure; xAction : TUndoAction; begin if VerticalZero = vzBottom then Thick := -Thick; selecteds := TList.create; CollectSelectedFigures(Selecteds); // Tolik 07/02/2017 -- утечка памяти!!! //if selecteds.count = 0 then exit; if selecteds.count = 0 then begin FreeAndNil(Selecteds); exit; end; // deselectall(0); if RecordUndo then xAction := TUndoAction.Create(uaInsert); for x := 0 to selecteds.count - 1 do begin fig := TFigure(selecteds[x]); newFig := fig.Offset(Thick); if assigned(newfig) then begin newFig.Selected := True; Figures.Add(newFig); if RecordUndo then xAction.List.Add(newFig); if assigned(FOnObjectInserted) then FOnObjectInserted(self,irCreate); end; end; FAnySelected := true; Selecteds.Free; if RecordUndo then begin InsertUndoAction(xAction); end; refresh; Updated := True; end; Function TPCDrawing.WeldIntoPolyline:TFigHandle; var f,f1,f2 : TFigure; fline: TFigure; cnt,a,i,k: integer; points: TDoublePointArr; nbrPoint,w,s,c: integer; Row:integer; lHandle: LongInt; first: Boolean; sList,fList: Tlist; done:Boolean; firstP,p1,p2,p,px1,px2:TdoublePoint; pLine: TPolyLine; PIndex : Integer; Closed: Boolean; pCnt: Integer; Segment: TPlSegment; orders: array of Integer; Order,SIndex,SCount,wi,lp: Integer; found: Boolean; firstFig: Integer; undo: TUndoaction; Converts: TList; fb: Tfigure; label ex; begin result := 0; done := false; FList := TList.Create; SList := TList.Create; Converts := TList.Create; nbrPoint := 0; CollectSelectionOrder(Slist); cnt := Slist.Count; for a := cnt-1 downto 0 do begin f := TFigure(Slist[a]); if not ((f is DrawObjects.TLine) or (f is TPolyLine) or (f is TArc) or (f is TElpArc) ) then begin SList.Remove(f); end; if (f is TElpArc) then begin fb := f.DuplicateAsBezier; SList.Insert(a,fb); SList.Remove(f); Converts.Add(fb); end; end; if Slist.Count < 1 then goto ex; i := 0; //find first figure firstfig := 0; while (i < SList.Count) and not done do begin f1 := TFigure(SList[i]); found := false; k := 0; wi := 0; while (k < SList.Count) and not done do begin if (i <> k) then begin f2 := TFigure(SList[k]); wi := wi+f1.IsWelded(f2); end; k := k +1; end; if wi < 3 then begin firstFig := i; done := true; end; i := i+1; end; if wi = 0 then goto ex; fList.Add(SList[firstFig]); SList.Remove(SList[firstFig]); done := false; f1 := Tfigure(fList[0]); repeat found := false; k := 0; repeat f2 := TFigure(sList[k]); wi := f1.IsWelded(f2); if wi > 0 then begin found := true; fList.Add(f2); SList.Remove(f2); f1 := f2; end; k := k+1; until found or (k >= SList.Count); if not found then begin done := true; if fList.Count = 0 then goto ex; end; if SList.Count = 0 then begin done := true; end; until done; SetLength(orders,FList.Count); Closed := False; // Find Chain Start f1 := Tfigure(Flist[0]); p1 := f1.GetStartPoint; p2 := f1.GetEndPoint; f2 := Tfigure(Flist[1]); px1 := f2.GetStartPoint; px2 := f2.GetEndPoint; if EQDP(p1,px1) then begin Orders[0] := 2; Orders[1] := 1; Pindex := 2; FirstP := p2; end else if EQDP(p1,px2) then begin Orders[0] := 2; Orders[1] := 2; Pindex := 1; FirstP := p2; end else if EQDP(p2,px1) then begin Orders[0] := 1; Orders[1] := 1; Pindex := 2; FirstP := p1; end else if EQDP(p2,px2) then begin Orders[0] := 1; Orders[1] := 2; Pindex := 1; FirstP := p1; end else goto ex; for i := 1 to FList.Count-1 do begin f1 := Tfigure(Flist[i]); p1 := f1.GetStartPoint; p2 := f1.GetEndPoint; if pIndex = 1 then p := p1 else p := p2; if i < Flist.Count-1 then begin f2 := Tfigure(Flist[i+1]); px1 := f2.GetStartPoint; px2 := f2.GetEndPoint; if EQDP(p,px1) then begin Pindex := 2; Orders[i+1] := 1; end else if EQDP(p,px2) then begin Pindex := 1; Orders[i+1] := 2; end else begin goto ex; end; end else begin if EQDP(p,firstP) then Closed := True; end; end; //add first point pcnt := 1; SetLength(points,pCnt); Points[0] := firstP; for i := 0 to fList.Count-1 do begin f := TFigure(fList[i]); Order := Orders[i]; if i = 0 then begin LHandle := f.LayerHandle; end; if f is TPolyLine then begin a := pcnt; pCnt := pcnt+f.PointCount-1; lp := 0; if ((i = fList.Count-1) and closed) then lp := 1; pCnt := pCnt-lp; SetLength(Points,pCnt); if Order = 1 then begin for k := 2 to f.PointCount-lp do begin Points[a] := f.FigurePoints[k]; a := a+1; end; end else begin for k := f.PointCount-1 downto 1+lp do begin Points[a] := f.FigurePoints[k]; a := a+1; end; end; end else if f is TArc then begin if not ((i = fList.Count-1) and closed) then begin pCnt := pCnt+1; SetLength(Points,pCnt); if Order = 1 then begin Points[pCnt-1] := f.ap3; end else begin Points[pCnt-1] := f.ap2; end; end; end else if f is DrawObjects.TLine then begin if not ((i = fList.Count-1) and closed) then begin pCnt := pCnt+1; SetLength(Points,pCnt); if Order = 1 then begin Points[pCnt-1] := f.ap2; end else begin Points[pCnt-1] := f.ap1; end; end; end; end; pLine := TPolyLine.create(points,DefaultPenWidth,ord(DefaultPenStyle), DefaultPenColor,ord(DefaultBrushStyle), DefaultBrushColor,ord(DefaultRowStyle),Closed, LHandle,mydsNormal,Self); SIndex := 0; for i := 0 to fList.Count -1 do begin f := TFigure(fList[i]); Order := Orders[i]; if f is TPolyLine then begin sCount:= Tpolyline(f).Segments.Count-1; // last closing segment is ignored if order = 1 then begin for k := 0 to SCount-1 do begin Segment := TPLSegment(Tpolyline(f).Segments[k]); pLine.ArrangeSegment(sIndex+1,segment.SType); TPlSegment(pLine.Segments[sIndex]).cpoint1 := segment.CPoint1; TPlSegment(pLine.Segments[sIndex]).cpoint2 := segment.CPoint2; TPlSegment(pLine.Segments[sIndex]).Inverted := segment.Inverted; TPlSegment(pLine.Segments[sIndex]).TangentKnot := segment.TangentKnot; SIndex := sIndex+1; end; end else begin for k := SCount-1 downto 0 do begin Segment := TPLSegment(Tpolyline(f).Segments[k]); pLine.ArrangeSegment(sIndex+1,segment.SType); TPlSegment(pLine.Segments[sIndex]).cpoint1 := segment.CPoint2; TPlSegment(pLine.Segments[sIndex]).cpoint2 := segment.CPoint1; TPlSegment(pLine.Segments[sIndex]).Inverted := segment.Inverted; TPlSegment(pLine.Segments[sIndex]).TangentKnot := segment.TangentKnot; SIndex := sIndex+1; end; end; end else if f is TArc then begin pLine.ArrangeSegment(SIndex+1,sArc); if orders[i] = 2 then TPlSegment(pLine.Segments[SIndex]).Inverted := True; TPlSegment(pLine.Segments[SIndex]).cpoint1 := f.ap1; TPlSegment(pLine.Segments[SIndex]).cpoint2 := f.ap1; Sindex := sIndex +1; end else if f is DrawObjects.TLine then begin SIndex := sIndex+1; end; end; RemoveSelection; if RecordUndo then TundoAction(FUndoList[0]).Tag:= 2; figures.add(pLine); pLine.Select; result := pLine.Handle; if RecordUndo then RecordInsertUndo(pLine,1); if assigned(FOnObjectInserted) then FOnObjectInserted(self,irCreate); FAnySelected := true; Updated := True; Refresh; ex: FList.Free; Slist.Free; for i := 0 to Converts.Count -1 do begin TFigure(Converts[i]).Free; end; Converts.Free; end; Function TPCDrawing.MakeSelectedLinesPolyline:TFigHandle; var f : TFigure; fline: TFigure; cnt,a: integer; points: TDoublePointArr; nbrPoint,w,s,c: integer; Row:integer; lHandle: LongInt; first: Boolean; begin result := 0; cnt := Selection.Count; nbrPoint := 0; first := true; for a := 0 to cnt-1 do begin fline := TFigure(Selection[a]); if (fline is DrawObjects.TLine) and (fline.selected) then begin if first then begin inc(nbrPoint); SetLength(Points,nbrPoint); points[nbrPoint-1] := fline.FigurePoints[1]; inc(nbrPoint); SetLength(Points,nbrPoint); points[nbrPoint-1] := fline.FigurePoints[2]; lHandle := fline.LayerHandle; w := fLine.width; s := fLine.Style; c := fline.Color; row := fLine.RowStyle; first := false; end else begin if (fline.FigurePoints[1].x <> points[nbrPoint-1].x) and (fline.FigurePoints[1].y <> points[nbrPoint-1].y) then begin inc(nbrPoint); SetLength(Points,nbrPoint); points[nbrPoint-1] := fline.FigurePoints[1]; end; inc(nbrPoint); SetLength(Points,nbrPoint); points[nbrPoint-1] := fline.FigurePoints[2]; end; end; end; if nbrPoint > 1 then begin for a := 0 to cnt-1 do begin fline := TFigure(Selection[a]); if (fline is DrawObjects.TLine) and (fline.selected) then begin figures.remove(fLine); fLine.destroy; end; end; f := TPolyLine.create(points,w,s,c,ord(fDefBrsStyle),fDefbrsColor,row,false,LHandle,mydsNormal,self); figures.add(f); f.Select; result := f.Handle; if assigned(FOnObjectInserted) then FOnObjectInserted(self,irCreate); FAnySelected := true; Updated := True; Refresh; end; end; Procedure TPCDrawing.UnClipSelBitmap; var a: Integer; xBmp: TBmpObject; xFig: TFigure; xAction : TUndoAction; Begin if RecordUndo then xAction := TUndoAction.Create(uaUnClip); for a := 0 to Selection.count-1 do begin If (Tfigure(Selection[a]) is TBMPObject) then begin xBmp := TBMpObject(Selection[a]); if assigned(xBmp.ClipFigure) then begin xFig := xBmp.ClipFigure; if RecordUndo then begin xAction.List.Add(xbmp); xAction.Params.Add(xfig); end; Figures.Add(xfig); xFig.SelecT; xBmp.ClipFigure := nil; Updated := True; end; end; end; if RecordUndo then begin if xAction.List.Count > 0 then begin InsertUndoAction(xAction); end else xAction.Free; end; refresh; end; Procedure TPCDrawing.ClipSelBitmapToSelFigure; var a: Integer; xBmp: TBmpObject; xFig: TFigure; xAction: TUndoAction; Begin if Selection.Count <> 2 then begin MessageDlg( emClipErr,mtError,[mbOk],0); exit; end; for a := 0 to Selection.count-1 do begin If (Tfigure(Selection[a]) is TBMPObject) then begin xBmp := TBMpObject(Selection[a]); end else begin xFig := TFigure(Selection[a]); end; end; if not assigned(xbmp) or (xFig.RegHandle = 0) then begin MessageDlg( emClipErr,mtError,[mbOk],0); exit; end; if RecordUndo then begin xAction := TUndoAction.Create(uaClip); xAction.List.Add(xbmp); xAction.Params.Add(xfig); InsertUndoAction(xAction); end; xBmp.ClipFigure := xFig; Figures.Remove(xFig); refresh; Updated := True; end; Procedure TPCDrawing.SetTransparentOfSelection(Transparent:Boolean); var a: Integer; xAction:TUndoAction; Begin if not FAnySelected then exit; if RecordUndo then xAction := TUndoAction.Create(uaModify); for a := 0 to Selection.count-1 do If (Tfigure(Selection[a]) is TBMPObject) then begin if RecordUndo then AddFigureToModifyUndo(xAction,Selection[a]); TBMPObject(Selection[a]).Transparent := Transparent ; Updated := True; end; if RecordUndo then begin if xAction.List.Count > 0 then begin InsertUndoAction(xAction); end else begin xAction.Free; end; end; refresh; end; function TPCDrawing.GetSelectionBlock: TBlock; var a,x,sx: integer; FilelInes : TStringList; fStream: TFileStream; block:TBlock; fig:TFigure; figGrp:TfigureGrp; cnt: integer; bName: string; begin sx := 0; if Selection.count>1 then begin GroupSelection; end; if (Selection.count=0) then exit; fig := TFigure(Selection[0]); Block := TBlock.create(0,Self); if ((fig is TFigureGrp) or (fig is TBlock)) then begin figGrp := TFigureGrp(fig); cnt := figGrp.InFigures.Count; for a := 0 to cnt-1 do begin Block.AddToGrp(figGrp.InFigures[a]); //28.04.2011 Block.InFigures.Add(figGrp.InFigures[a]); end; Block.Combined := figGrp.Combined; end else begin Block.AddToGrp(fig); //28.04.2011 Block.InFigures.Add(fig); end; //bName := ExtractFileName(FileName); //bName := Copy(bName,1,Length(bName)-4); //Block.Blockname := bName; Result := Block; end; function TPCDrawing.GetSelectionBlockDuplicate: TBlock; var Block: TBlock; begin Block := GetSelectionBlock; Result := TBlock(Block.duplicate); Block.InFigures.Clear; Block.Free; end; Procedure TPCDrawing.MakeSelectionBlock(FileName : string); var a,x,sx: integer; FilelInes : TStringList; //fStream: TFileStream; block:TBlock; fig:TFigure; figGrp:TfigureGrp; cnt: integer; bName: string; begin sx := 0; if Selection.count>1 then begin GroupSelection; end; if (Selection.count=0) then exit; fig := TFigure(Selection[0]); Block := TBlock.create(0,Self); if ((fig is TFigureGrp) or (fig is TBlock)) then begin figGrp := TFigureGrp(fig); cnt := figGrp.InFigures.Count; for a := 0 to cnt-1 do begin Block.AddToGrp(figGrp.InFigures[a]); //28.04.2011 Block.InFigures.Add(figGrp.InFigures[a]); end; Block.Combined := figGrp.Combined; end else begin Block.AddToGrp(fig); //28.04.2011 Block.InFigures.Add(fig); end; bName := ExtractFileName(FileName); bName := Copy(bName,1,Length(bName)-4); Block.Blockname := bName; //fStream := TFileStream.Create(FileName,fmCreate); //Block.WriteToStream(fStream); //fStream.free; Block.SaveToFile(FileName); //27.08.2010 FileLines := TStringList.Create; Block.InFigures.Clear; Block.Free; end; Procedure TPCDrawing.SetBlockInfo(FigHandle:Integer;Info: String); begin TBlock(FigHandle).Info := Info; end; Function TPCDrawing.InsertBlockWithFileName(LayerNbr:integer;FileName: string; x,y: Double):TFigHandle; var xStream: Tstream; xByte: Byte; sign: string; a: integer; Begin sign := ''; // Tolik 05/04/2019 -- If (LayerNbr < 0) or (LayerNbr > Layers.Count - 1) then LayerNbr := 0; DeselectAll(0); xStream := TFileStream.Create(FileName,fmOpenRead or fmShareDenyNone); for a := 1 to 6 do begin xStream.Read(xByte,1); //Tolik 05/04/2019 -- //sign := sign + chr(xByte); sign := sign + Ansichar(xByte); // end; if Sign = 'TBlock' then begin xStream.Position := 0; result := InsertBlockFromStream(LayerNbr,xStream,x,y); end; xStream.free; Updated := True; Refresh; End; Function TPCDrawing.InsertBlockFromStream(LayerNbr: integer; Stream: TStream; x, y: Double): TFigHandle; var Block: TBlock; i: Integer; mx, my, ax, ay, lx, ly: Double; lHandle, xhandle: LongInt; fig: Tfigure; DistedLayer: Boolean; Center: Boolean; scMult: Double; begin DeselectAll(0); Result := 0; If (LayerNbr < 0) or (LayerNbr > Layers.Count - 1) then LayerNbr := 0; lHandle := LongInt(Layers[LayerNbr]); Block := TBlock(TFigure.CreateFromStream(Stream, lHandle, mydsNormal, Self)); if (x = -1) and (y = -1) then begin x := WorkWidth / 2; y := Workheight / 2; end; if assigned(Block) then begin Block.VerifyZeroPoints(Block.orgVz,Block.OrgHz); // Tolik 22/06/2021 -- mx := 0; my := 0; ax := 0; ay := 0; // Block.getbounds(mx,my,ax,ay); lx := (mx+ax) / 2; ly := (my+ay) / 2; Block.move(x-lx,y-ly); Figures.Add(Block); Block.Name := Block.BlockName + inttostr(Block.Handle); Block.Select; Block.DiagonalScale := true; FAnySelected := True; xhandle := 0; Distedlayer := false; for i := 0 to Block.Infigures.Count-1 do begin fig := Tfigure(Block.Infigures[i]); if i = 0 then xhandle := fig.LayerHandle else begin if xHandle <> fig.LayerHandle then DistedLayer := true; end; end; if not distedlayer then begin for i := 0 to Block.Infigures.Count-1 do begin fig := Tfigure(Block.Infigures[i]); fig.LayerHandle := lHandle; end; end; if (Block.MapScale <> MapScale) and ((FRescale = rsAlways) or ((FReScale = rsAskUser) and (MessageDlg(ReScaleBlockMessage,mtConfirmation,[mbYes,mbNo],0) = mrYes) )) then begin scMult := Block.MapScale / MapScale; BLock.scale(scMult,scMult,Block.ap1); end; result := TFigHandle(Block); if assigned(FOnObjectInserted) then FOnObjectInserted(self,irCreate); RecordInsertUndo(Block); Updated := True; end; end; function TPCDrawing.LoadFromFile(const FileName : string): Boolean; Var a : integer; Lines : TStringList; DocLines : TStringList; xStream:TFileStream; i: integer; Begin Result := false; Clear(0); // xStream := TFileStream.Create(FileName, fmOpenRead or fmShareExclusive); xStream := SafeOpenFileStream(FileName, fmOpenRead or fmShareExclusive, 'TPCDrawing.LoadFromFile', cSCSComponent_Msg22_10+' '+FileName+'. '+cCauseFailFileAccess); if xStream <> nil then begin LoadFromStream(xStream); xStream.Free; Updated := False; Refresh; Result := true; if GReadOnlyMode then begin for i := 0 to Figures.Count - 1 do begin TFigure(Figures[i]).LockModify := True; TFigure(Figures[i]).LockMove := True; TFigure(Figures[i]).LockSelect := True; end; end; end; End; function TPCDrawing.SaveToFile(LayerNbr:integer; FileName:string): Boolean; var Lines : TStringlist; xStream: TFileStream; begin Result := false; //08.09.2011 try ClearUndoList; // xStream := TFileStream.Create(FileName, fmCreate or fmShareExclusive); xStream := SafeOpenFileStream(FileName, fmCreate or fmShareExclusive, 'TPCDrawing.SaveFromFile', cSCSComponent_Msg22_11+' '+FileName+'. '+cCauseFailFileAccess); if xStream <> nil then begin try SaveToStream(xStream); except on E: Exception do AddExceptionToLog('TPCDrawing.SaveToFile' + E.Message); end; Updated := False; xStream.Free; Result := true; end; //08.09.2011 finally //08.09.2011 xStream.Free; //08.09.2011 end; end; Procedure TPCDrawing.LoadFromStream(Stream: TStream); var sBytes: array [1..8] of Byte; a,i: integer; Version: Word; SecCount: Byte; xSize: integer; SecStr: TMemoryStream; SecName: String; aFigure: TFigure; SCSCatalog: TSCSCatalog; begin DisableAlign; //02.11.2011 try //02.11.2011 for a := 1 to 8 do Stream.Read(sBytes[a],1); for a := 1 to 8 do if sBytes[a] <> signBytes[a] then begin AddExceptionToLog('TPCDrawing.LoadFromStream'); // ShowMessage(emInvalidStream); Exit; end; try For a := 0 to Layers.Count - 1 do begin TLayer(Layers[a]).destroy; end; Layers.Clear; except // on E: Exception do AddExceptionToLog(CPowerCadMessage + 'TPCDrawing.LoadFromStream' + E.Message); end; Stream.Read(Version,2); Stream.Read(SecCount,1); for a := 1 to SecCount do begin Stream.Read(xSize,4); SecName := ReadStringFromStream(Stream); SecStr:= TMemoryStream.Create; StreamToStream(Stream,SecStr,xSize); SecStr.Seek(0,soFromBeginning); if SecName = 'Document' then SetDocumentProperties(SecStr) else if SecName = 'Layers' then SetLayerData(SecStr) else if SecName = 'Figures' then SetFiguresData(SecStr) else if SecName = 'Joins' then SetJoinsData(SecStr) else if SecName = 'Guides' then SetGuidesData(SecStr) else if SecName = 'Custom Stream' then begin if assigned(CustomStream) then CustomStream.free; CustomStream := TMemoryStream.Create; StreamToStream(SecStr,CustomStream,xSize); CustomStream.Position := 0; if assigned(FCustomStreamLoaded) then FCustomStreamLoaded(Self); CustomStream.Free; end; SecStr.Free; end; Updated := False; finally //Tolik -- 25/10/2017 -- Self.FLastFigureID := 1000000; if Self.FLastFigureIDOnLoad > 1000000 then Self.FLastFigureID := Self.FLastFigureIDOnLoad; // try if CheckAssignedPCAD(Self) then begin TF_Cad(self.Owner).UpdateCheckedFigures(False); NotExistInCatalog := 0; for i := 0 to TF_Cad(self.Owner).FCheckedFigures.Count - 1 do begin aFigure := TFigure(TF_Cad(self.Owner).FCheckedFigures[i]); NotExistInCatalog := NotExistInCatalog or CheckFigureInsideCabinet(TF_Cad(self.Owner).FCheckedFigures, aFigure, true); end; end; except end; EnableAlign; //02.11.2011 if GReadOnlyMode then begin for i := 0 to Figures.Count - 1 do begin TFigure(Figures[i]).LockModify := True; TFigure(Figures[i]).LockMove := True; TFigure(Figures[i]).LockSelect := True; end; end; end; end; Procedure TPCDrawing.SaveToStream(Stream: TStream); var a: integer; Version: Word; SecCount: Byte; xSize: Integer; SecStr: TMemoryStream; xBmp: Tbitmap; //Tolik -- 25/07/2017 -- RefreshFlag: boolean; // begin RefreshFlag := GCanRefreshCad; GCanRefreshCad := True; try refresh; except on E: Exception do begin AddExceptionToLog('TPCDrawing.SaveToStream.RefreshCAD' + E.Message); //GCanRefreshCad := RefreshFlag; end; end; GCanRefreshCad := RefreshFlag; try xSize := 0; for a := 1 to 8 do Stream.Write(SignBytes[a],1); Version := GetVersion; SecCount := 5; if fSavePrev then SecCount := SecCount+1; if assigned(CustomStream) then SecCount := SecCount+1; Stream.Write(Version,2); Stream.Write(SecCount,1); if fSavePrev then begin // Section 0: Preview Image SecStr:= TMemoryStream.Create; xBmp := CreatePreviewBitmap; xBmp.SaveToStream(SecStr); xSize := SecStr.Size; SecStr.Seek(0,soFromBeginning); Stream.Write(xSize,4); WriteString(Stream,'Preview'); StreamToStream(SecStr,Stream,xSize); SecStr.free; xbmp.free; end; // Section 1: Document Properties SecStr:= TMemoryStream.Create; GetDocumentProperties(SecStr); xSize := SecStr.Size; SecStr.Seek(0,soFromBeginning ); Stream.Write(xSize,4); WriteString(Stream,'Document'); StreamToStream(SecStr,Stream,xSize); SecStr.free; // Section 2: Layer Data SecStr:= TMemoryStream.Create; GetLayerData(SecStr); xSize := SecStr.Size; SecStr.Seek(0,soFromBeginning ); Stream.Write(xSize,4); WriteString(Stream,'Layers'); StreamToStream(SecStr,Stream,xSize); SecStr.free; // Section 3: Figures SecStr:= TMemoryStream.Create; GetFiguresData(SecStr); xSize := SecStr.Size; SecStr.Seek(0,soFromBeginning ); Stream.Write(xSize,4); WriteString(Stream,'Figures'); StreamToStream(SecStr,Stream,xSize); SecStr.free; // Section 4: Line Joins SecStr:= TMemoryStream.Create; GetJoinsData(SecStr); xSize := SecStr.Size; SecStr.Seek(0,soFromBeginning ); Stream.Write(xSize,4); WriteString(Stream,'Joins'); StreamToStream(SecStr,Stream,xSize); SecStr.free; // Section 5: Custom Stream if assigned(CustomStream) then CustomStream.Position := 0; if assigned(FCustomStreamUpdate) then FCustomStreamUpdate(Self); if assigned(CustomStream) then begin xSize := CustomStream.Size; CustomStream.Seek(0,soFromBeginning); Stream.Write(xSize,4); WriteString(Stream,'Custom Stream'); StreamToStream(CustomStream,Stream,xSize); end; // Section 6: Guides Data SecStr := TMemoryStream.Create; GetGuidesData(SecStr); xSize := SecStr.Size; SecStr.Seek(0, soFromBeginning); Stream.Write(xSize, 4); WriteString(Stream, 'Guides'); StreamToStream(SecStr, Stream, xSize); SecStr.free; Updated := False; except on E: Exception do AddExceptionToLog('TPCDrawing.SaveToStream' + E.Message); end; end; Procedure TPCDrawing.GetDocumentProperties(Stream:TStream); var xInt: Integer; xByte: Byte; xWord: Word; xSize: integer; pGuides: pByte; a: integer; xDbl: Double; begin xInt:= BackGround; WriteField(21,Stream,xInt,4); xInt:= GridColor; WriteField(22,Stream,xInt,4); xDbl:= GridStep; WriteField(220,Stream,xDbl,8); xInt:= GuideColor; WriteField(24,Stream,xInt,4); xDbl:= WorkWidth; WriteField(221,Stream,xDbl,8); xDbl:= WorkHeight; WriteField(222,Stream,xDbl,8); xInt:= ZoomScale; WriteField(27,Stream,xInt,4); xInt := Round(MapScale); WriteField(28,Stream,xInt,4); xInt:= PageColor; WriteField(29,Stream,xInt,4); xByte:= ord(PageLayout); WriteField(90,Stream,xByte,1); xByte:= ord(PageOrient); WriteField(91,Stream,xByte,1); xByte:= ord(VerticalZero); WriteField(92,Stream,xByte,1); xByte:= ord(HorizontalZero); WriteField(93,Stream,xByte,1); xByte:= ord(RulerSystem); WriteField(94,Stream,xByte,1); xDbl:= MapScale; WriteField(239, Stream, xDbl, sizeof(xDbl)); if Guides.count > 0 then begin xSize := Guides.count * 9; GetMem(pGuides,xSize); for a := 0 to Guides.count -1 do begin pByte(pAnsiChar(pGuides) + a*9 )^ := ord(TGuideLine(Guides[a]).gType); pDouble(pAnsiChar(pGuides) + a*9 + 1)^ := TGuideLine(Guides[a]).coord; end; WriteBinField(151,Stream,pGuides,xSize); // the old format was 150 FreeMem(pGuides, xSize); // Tolik 03/05/2019 - - end; end; Procedure TPCDrawing.SetDocumentProperties(Stream:TStream); var xSize,bSize: Integer; xCode: Byte; intVal: integer; byteVal: Byte; strVal: string; dblval: Double; bytes: pByte; begin xSize:= Stream.Size; Repeat Stream.Read(xCode,1); if (xCode >= 20) and (xCode < 90) then begin Stream.Read(intVal,4); SetDocumentPropertyInt(xCode,intVal); end else if (xCode >= 90) and (xCode < 120) then begin Stream.Read(byteVal,1); SetDocumentPropertyInt(xCode,byteVal); end else if (xCode >= 150) and (xCode < 180) then begin Stream.Read(bSize,4); GetMem(Bytes,bSize); Stream.Read(Bytes^,bSize); SetDocumentPropertyBin(xCode,bytes,bSize); FreeMem(Bytes, bSize); // Tolik 03/05/2109 -- end else if (xCode >= 180) and (xCode < 220) then begin strval := ReadStringFromStream(Stream); SetDocumentPropertyStr(xCode,strval); end else if (xCode >= 220) and (xCode < 240) then begin Stream.Read(dblVal,8); if CompareValue(dblVal, 0, 0.0000001) = 0 then // Tolik 23/06/2021 -- dblVal := 0; SetDocumentPropertyDbl(xCode,dblVal); end; until Stream.Position = xSize; end; Procedure TPCDrawing.SetDocumentPropertyInt(xCode:Byte; Value:Integer); begin case XCode of 21: BackGround := Value; 22: GridColor := Value; 23: GridStep := Value/10; 24: GuideColor := Value; 25: WorkWidth := Value/10; 26: WorkHeight := Value/10; 27: ZoomScale := Value; 28: MapScale := Value; 29: PageColor := Value; 90: PageLayout := TPageLayout(Value); 91: PageOrient := TPageOrient(Value); 92: VerticalZero := TVertZero(Value); 93: HorizontalZero := THorzZero(Value); 94: RulerSystem := TRulerSystem(Value); end; end; Procedure TPCDrawing.SetDocumentPropertyStr(xCode:Byte; Value:String); begin end; Procedure TPCDrawing.SetDocumentPropertyDbl(xCode:Byte; Value:Double); begin case XCode of 220: GridStep := Value; 221: WorkWidth := Value; 222: WorkHeight := Value; 239: MapScale := Value; end; end; Procedure TPCDrawing.SetDocumentPropertyBin(xCode:Byte;Value:pByte; xSize:integer); var xStream: TMemoryStream; gType: byte; gCoord: integer; gCoordD: Double; Guide: TGuideLine; begin case xCode of 150: begin xStream := TMemoryStream.Create; xStream.Write(Value^,xSize); xStream.Position := 0; repeat xStream.Read(gType,1); xStream.Read(gCoord,4); Guide := TGuideLine.create(TGuideType(gType),gCoord/10); Guides.Add(Guide); until xStream.Position = xStream.Size; // === xStream.Free; end; 151: begin xStream := TMemoryStream.Create; xStream.Write(Value^,xSize); xStream.Position := 0; repeat xStream.Read(gType,1); xStream.Read(gCoord,8); if CompareValue(gCoord, 0, 0.0000001) = 0 then // Tolik 23/06/2021 -- gCoord := 0; Guide := TGuideLine.create(TGuideType(gType),gCoord); Guides.Add(Guide); until xStream.Position = xStream.Size; // === xStream.Free; end; end; end; Procedure TPCDrawing.SetLayerData(Stream:TStream); var xSize : Integer; a,lCount: integer; Layer : Tlayer; lyStream:TMemoryStream; begin Stream.Read(lCount,4); for a := 1 to lCount do begin Stream.Read(xSize,4); lyStream := TMemoryStream.Create; StreamToStream(Stream,lyStream,xSize); lyStream.Seek(0,soFromBeginning); Layer := Tlayer.CreateFromStream(lyStream,DEngine,Self); lyStream.free; if layer <> nil then begin Layer.vertZero := ord(VerticalZero); Layer.horzZero := ord(HorizontalZero); Layers.Add(Layer); end; end; end; Procedure TPCDrawing.GetLayerData(Stream:TStream); var a,lCount: integer; Layer : Tlayer; xSize: Integer; lyStream:TMemoryStream; begin lCount := Layers.Count; Stream.Write(lCount,4); For a := 0 to lCount-1 do begin Layer := TLayer(Layers[a]); lyStream := TMemoryStream.Create; Layer.WriteToStream(lyStream,Self); xSize := lyStream.Size; lyStream.Seek(0,soFromBeginning); Stream.Write(xSize,4); StreamToStream(lyStream,Stream,xSize); lyStream.Free; end; end; // считать со Stream - создать на КАД Procedure TPCDrawing.SetGuidesData(Stream: TStream); var xSize: Integer; a, LCount: integer; Guide: TGuideLine; gStream: TMemoryStream; begin try For a := 0 to Guides.Count - 1 do begin TGuideLine(Guides[a]).Destroy; end; Guides.Clear; except // on E: Exception do AddExceptionToLog(CPowerCadMessage + 'TPCDrawing.SetGuidesData' + E.Message); end; Stream.Read(LCount, 4); for a := 1 to LCount do begin Stream.Read(xSize, 4); gStream := TMemoryStream.Create; StreamToStream(Stream, gStream, xSize); gStream.Seek(0, soFromBeginning); Guide := TGuideLine.CreateFromStream(gStream); gStream.Free; if Guide <> nil then begin Guides.Add(Guide); end; end; end; // записать в Stream - считать с КАД Procedure TPCDrawing.GetGuidesData(Stream: TStream); var a, LCount: integer; Guide: TGuideLine; xSize: Integer; gStream: TMemoryStream; begin LCount := Guides.Count; Stream.Write(LCount, 4); For a := 0 to LCount - 1 do begin Guide := TGuideLine(Guides[a]); gStream := TMemoryStream.Create; Guide.WriteToStream(gStream); xSize := gStream.Size; gStream.Seek(0, soFromBeginning); Stream.Write(xSize, 4); StreamToStream(gStream, Stream, xSize); gStream.Free; end; end; // Tolik -- 21/02/2017 -- Старая закомменчена -- смотри ниже Procedure TPCDrawing.SetFiguresData(Stream:TStream); var a,fCount: integer; Figure : TFigure; xSize: Integer; figStream:TMemoryStream; CheckCounter, CurrentUserQuota, UserObjectsQuota: integer; UserQuotaReached: string; ee: Integer; begin ee := 0; //времено для посмотреть if ee = 1 then begin Self.FBreakedOnQuota := True; //ShowMessage(UserQuotaReached); Exit; end; // UserQuotaReached := ''; UserQuotaReached := GetQuotaMessage(CheckUserObjQuotaReached(1), cMess_Quota_OpenProj); if UserQuotaReached <> '' then begin //ShowMessage(UserQuotaReached); exit; end; CheckCounter := 0; Stream.Read(fCount,4); For a := 1 to fCount do begin if CheckCounter = 200 then begin CheckCounter := 0; UserQuotaReached := GetQuotaMessage(CheckUserObjQuotaReached(1), cMess_Quota_OpenProj); if UserQuotaReached <> '' then begin Self.FBreakedOnQuota := True; //ShowMessage(UserQuotaReached); Exit; end; end else Inc(CheckCounter); Stream.Read(xSize,4); figStream := TMemoryStream.Create; StreamToStream(Stream,figStream,xSize); figStream.Seek(0,soFromBeginning); Figure := nil; Figure := TFigure.CreateFromStream(figStream,0,mydsNormal,self); //Tolik 25/01/2021 -- if Figure is TBMPObject then TBMPObject(Figure).ImageEdited := True; // if Figure.LayerHandle = 0 then Figure.LayerHandle := LongInt(Layers[1]); figStream.Free; if Figure <> nil then begin Figures.Add(Figure); if assigned(FOnObjectInserted) then FOnObjectInserted(Self,irLoad); end; end; end; { Procedure TPCDrawing.SetFiguresData(Stream:TStream); var a,fCount: integer; Figure : TFigure; xSize: Integer; figStream:TMemoryStream; begin UserObjectsQuota := GetUserObjectsQuota; Stream.Read(fCount,4); For a := 1 to fCount do begin Stream.Read(xSize,4); figStream := TMemoryStream.Create; StreamToStream(Stream,figStream,xSize); figStream.Seek(0,soFromBeginning); Figure := nil; Figure := TFigure.CreateFromStream(figStream,0,mydsNormal,self); if Figure.LayerHandle = 0 then Figure.LayerHandle := LongInt(Layers[1]); figStream.Free; if Figure <> nil then begin Figures.Add(Figure); if assigned(FOnObjectInserted) then FOnObjectInserted(Self,irLoad); end; end; end; } Procedure TPCDrawing.GetJoinsData(Stream:TStream); var a: integer; jf: Tfigure; jStr: string; begin For a:= 0 to Figures.Count-1 do begin if (TFigure(Figures[a]) is DrawObjects.TLine) then begin jf := DrawObjects.TLine(Figures[a]).JoinFigure1; if jf <> nil then begin jStr := DrawObjects.TLine(Figures[a]).Name+','+ TFigure(jf).Name; WriteStrField(180,Stream,jStr); end; jf := DrawObjects.TLine(Figures[a]).JoinFigure2; if jf <> nil then begin jStr := DrawObjects.TLine(Figures[a]).Name+','+ TFigure(jf).Name; WriteStrField(181,Stream,jStr); end; end; if (TFigure(Figures[a]) is TPolyLine) then begin jf := TPolyLine(Figures[a]).JoinFigure1; if jf <> nil then begin jStr := TPolyLine(Figures[a]).Name+','+ TFigure(jf).Name; WriteStrField(182,Stream,jStr); end; jf := TPolyLine(Figures[a]).JoinFigure2; if jf <> nil then begin jStr := TPolyLine(Figures[a]).Name+','+ TFigure(jf).Name; WriteStrField(183,Stream,jStr); end; end; end; end; Procedure TPCDrawing.SetJoinsData(Stream:TStream); var xCode:Byte; strVal:string; begin repeat Stream.read(xCode,1); StrVal := ReadStringFromStream(Stream); case xCode of 180: BoundLineByText(StrVal,1); 181: BoundLineByText(StrVal,2); 182: BoundPLineByText(StrVal,1); 183: BoundPLineByText(StrVal,2); end; until Stream.Position = Stream.Size; end; Procedure TPCDrawing.GetFiguresData(Stream:TStream); var a, fCount: integer; Figure : TFigure; xSize: Integer; figStream:TMemoryStream; isExistShadow: boolean; begin try Figure := nil; //#From Oleg# //20.09.2010 if GCadForm <> nil then GCadForm.FCreateObjectOnClick := False; RestoreCadGridStatus; // Tolik 04/03/2021 -- if GShadowObject <> nil then begin if Figures.IndexOf(GShadowObject) >= 0 then begin DestroyShadowObject; end; end; isExistShadow := True; while isExistShadow do begin isExistShadow := False; For a := 0 to Figures.Count - 1 do begin if TFigure(Figures[a]) is TFigureGrpNotMod then if TFigureGrpNotMod(Figures[a]).InFigures.Count = 1 then begin Figure := TFigureGrpNotMod(Figures[a]).InFigures[0]; if Figure.ClassName = 'TLine' then begin isExistShadow := True; GIsDrawShadow := False; RemoveInFigureGrp(TFigureGrpNotMod(Figures[a])); Figures.Remove(Figures[a]); break; end; end; end; end; Figure := nil; //#From Oleg# //20.09.2010 fCount := Figures.Count; Stream.Write(fCount, 4); For a := 0 to fCount - 1 do begin Figure := TFigure(Figures[a]); figStream := TMemoryStream.Create; Figure.WriteToStream(figStream); xSize := figStream.Size; figStream.Seek(0,soFromBeginning); Stream.Write(xSize,4); StreamToStream(figStream,Stream,xSize); if assigned(FOnObjectSaved) then FOnObjectSaved(Self,Figure); figStream.Free; end; except on E: Exception do begin AddExceptionToLogExt(ClassName, 'GetFiguresData', E.Message); //if Figure <> nil then // ShowMessage('GetFiguresData ' + IntToStr(a) + ' name=' + Figure.Name + ' Classname=' + Figure.ClassName) //else // ShowMessage('GetFiguresData ' + IntToStr(a)); if Figure <> nil then AddExceptionToLogExt(ClassName, 'GetFiguresData ' + IntToStr(a) + ' name=' + Figure.Name + ' Classname=' + Figure.ClassName, '') else AddExceptionToLogExt(ClassName, 'GetFiguresData ' + IntToStr(a), ''); end; end; end; Procedure TPCDrawing.BoundLineByText(Line:String;ptIndex:integer); var fName1,fName2: string; s: TStringArray; myLine: DrawObjects.TLine; myFigure: Tfigure; Begin myLine:= nil; myFigure := nil; if SplitStr(Line,s) = 2 then begin fName1 := s[0];fName2 := s[1]; MyLine := DrawObjects.TLine(FindFigureByName(fname1)); MyFigure := Tfigure(FindFigureByName(fName2)); if (MyLine <> nil) and (MyFigure <> nil) then begin if ptIndex = 1 then MyLine.SetJFigure1(MyFigure); if ptIndex = 2 then MyLine.SetJFigure2(MyFigure); end; end; End; Procedure TPCDrawing.BoundPLineByText(Line:String;ptIndex:integer); var fName1,fName2: string; s: TStringArray; myLine: TPolyLine; myFigure: Tfigure; Begin myLine:= nil; myFigure := nil; if SplitStr(Line,s) = 2 then begin fName1 := s[0];fName2 := s[1]; MyLine := TPolyLine(FindFigureByName(fname1)); MyFigure := Tfigure(FindFigureByName(fName2)); if (MyLine <> nil) and (MyFigure <> nil) then begin if ptIndex = 1 then MyLine.SetJFigure1(MyFigure); if ptIndex = 2 then MyLine.SetJFigure2(MyFigure); end; end; End; Function TPCDrawing.FindFigureByName(figName:String):TFigHandle; var a,b: integer; Layer: TLayer; begin result := 0; For a := 0 to Figures.count-1 do begin if TFigure(Figures[a]).Name = figName then begin result := LongInt(TFigure(figures[a])); exit; end; end; end; Procedure TPCDrawing.ExportAsWmf(FileName: string); var mf : TMetafile; mc : TMetafileCanvas; a : integer; Layer: TLayer; Begin mf := DrawingAsWmf; mf.SaveToFile(FileName); mf.Free; exit; { что бы не сбивало с толку - вверху екзит стоит! mf := TMetafile.Create; prDpm := DotsPerMilOrig; mf.Width := Round(WorkWidth * prDpm); mf.Height := round(WorkHeight * prDpm); mc := TMetafileCanvas.Create(mf,0); SetEngine(mc,prConvertXY,prDeConvertXY,prConvertDim,prDeConvertDim,false,nil); DrawFigures; mc.Free; mf.SaveToFile(FileName); mf.Free; } end; Function TPCDrawing.SelectionAsMetaFile:Integer; var xwmf:TMetafile; begin xWmf := nil; xWmf := SelectionAsWmf; if assigned(xWmf) then result := xWmf.Handle else result := 0; end; Function TPCDrawing.SelectionAsWmf:TMetafile; var mf : TMetafile; mc : TMetafileCanvas; r: TDoubleRect; w,h: Double; dx,dy: Double; Begin mf := TMetafile.Create; dcDpm := DotsPerMilOrig; r := GetSelectionRect; w := abs(r.right-r.Left); h := abs(r.top-r.bottom); mf.Width := Round(w * dcDpm)+1; mf.Height := round(h * dcDpm)+1; mc := TMetafileCanvas.Create(mf,0); if VerticalZero = vzBottom then dy := workheight-r.bottom else dy := r.top; if HorizontalZero = vzLeft then dx := r.left else dx := workwidth-r.right; dcConvertDim(dx); dcConvertDim(dy); dcCoordX := Round(-1*dx); dcCoordy := Round(-1*dy); SetEngine(mc,dcConvertXY,prDeConvertXY,dcConvertDim,prDeConvertDim,false,nil); DrawSelectedFigures; mc.Free; result := mf; end; Function TPCDrawing.CreatePreviewBitmap: TBitmap; var Bitmap: TBitmap; sc,scx,scy,w,h: Double; Begin Bitmap := TBitmap.Create; w := WorkWidth; h := WorkHeight; scx := 85/w; scy := 100/h; if scx > scy then sc := scy else sc := scx; prDpm := sc; Bitmap.Width := Round((WorkWidth) * prDpm); Bitmap.Height := round((WorkHeight) * prDpm); SetEngine(Bitmap.canvas,prConvertXY,prDeConvertXY,prConvertDim,prDeConvertDim,false,nil); DrawFigures; result := Bitmap; End; Procedure TPCDrawing.SaveAsBitmap(Filename:string); var Bitmap: TBitmap; OldH: integer; Begin {//29.02.2012 prDpm := DotsPerMilOrig; Bitmap := TBitmap.Create; Bitmap.Width := Round((WorkWidth) * prDpm); Bitmap.Height := round((WorkHeight) * prDpm); SetEngine(Bitmap.canvas,prConvertXY,prDeConvertXY,prConvertDim,prDeConvertDim,false,nil);} try Bitmap := PrepareBitmap; //29.02.2012 Bitmap.Canvas.Brush.Color := PageColor; Bitmap.Canvas.Brush.Style := bsSolid; Bitmap.Canvas.FillRect(Rect(0, 0, Bitmap.Width, Bitmap.Height)); //SetEngine(Bitmap.Canvas,prConvertXY,prDeConvertXY,prConvertDim,prDeConvertDim,false,nil); DrawFigures; Bitmap.SaveToFile(filename); Bitmap.Free; except end; End; //function TPCDrawing.SaveToBitmap: TBitmap; function TPCDrawing.SaveToBitmap(aPdfSave: Boolean = False): TBitmap; begin Result := PrepareBitmap(aPdfSave); Result.Canvas.Brush.Color := PageColor; Result.Canvas.Brush.Style := bsSolid; Result.Canvas.FillRect(Rect(0, 0, Result.Width, Result.Height)); DrawFigures; end; Procedure TPCDrawing.SaveSubstrateAsBitmap(FileName: string);(*vb*) var Bitmap: TBitmap; Begin {//29.02.2012 prDpm := DotsPerMilOrig; Bitmap := TBitmap.Create; Bitmap.Width := Round((WorkWidth) * prDpm); Bitmap.Height := round((WorkHeight) * prDpm); SetEngine(Bitmap.canvas,prConvertXY,prDeConvertXY,prConvertDim,prDeConvertDim,false,nil);} Bitmap := PrepareBitmap; //29.02.2012 DrawSubstrateFigures(False); Bitmap.SaveToFile(filename); Bitmap.Free; End; // Tolik 24/09/2019 -- function TPCDrawing.SaveSubstrateToBitmap(aPdfSave: Boolean = False): TBitmap; //function TPCDrawing.SaveSubstrateToBitmap: TBitmap; begin Result := PrepareBitmap(aPdfSave); DrawSubstrateFigures(False); end; Procedure TPCDrawing.DrawToCanvas(xCanvas:TCanvas;x,y:Integer;DScale:Double); begin dcDpm := DotsPerMilOrig * (dScale); dcCoordx := x; dcCoordy := y; SetEngine(xCanvas,dcConvertXY,prDeConvertXY,dcConvertDim,dcDeConvertDim,false,nil); DrawFigures; end; Procedure TPCDrawing.DrawRectToCanvas(ARect: TDoubleRect; xCanvas:TCanvas;x,y:Integer;DScale:Double); var PrinterBmp: TBitmap; OldTileX, OldTileY: Double; begin OldTileX := TileX; OldTileY := TileY; PrinterBmp := TBitmap.Create; dcDpm := DotsPerMilOrig * (dScale); dcCoordx := x; dcCoordy := y; tileX := Min(ARect.Left, ARect.Right); tileY := Min(ARect.Top, ARect.Bottom); SetEngine(xCanvas,dcConvertXYTile,prDeConvertXY,dcConvertDim,dcDeConvertDim,false,nil); //SetEngine(xCanvas,prConvertXY,prDeConvertXY,prConvertDim,prDeConvertDim, true, PrinterBmp); DrawFigures; ClearNoRect(ARect); PrinterBmp.Free; TileX := OldTileX; TileY := OldTileY; end; Procedure TPCDrawing.DrawToDC(dc,x,y:integer;DScale:Double); var xCanvas:TCanvas; begin dcDpm := DotsPerMilOrig * (dScale); xCanvas:= TCanvas.Create; xCanvas.Handle := dc; dcCoordx := x; dcCoordy := y; SetEngine(xCanvas,dcConvertXY,prDeConvertXY,dcConvertDim,prDeConvertDim,false,nil); DrawFigures; xCanvas.Handle := 0; xCanvas.Free; end; Procedure TPCDrawing.StretchToDC(dc,aLeft,aTop,aRight,aBottom:Integer); var xCanvas:TCanvas; Bitmap: TBitmap; Begin prDpm := DotsPerMilOrig; Bitmap := TBitmap.Create; Bitmap.Width := Round((WorkWidth / 10) * prDpm); Bitmap.Height := round((WorkHeight / 10) * prDpm); SetEngine(Bitmap.canvas,prConvertXY,prDeConvertXY,prConvertDim,prDeConvertDim,false,nil); DrawFigures; xCanvas:= TCanvas.Create; xCanvas.Handle := dc; xCanvas.StretchDraw(Rect(aLeft,aTop,aRight,aBottom),Bitmap); Bitmap.Free; xCanvas.Handle := 0; xCanvas.Free; end; Procedure TPCDrawing.prDeConvertXY(var X,Y,Z:Double); Begin x := x; End; Procedure TPCDrawing.prDeConvertDim(var Dim: Double); Begin Dim := Dim / (prDpm * ConvertRatio * prnScale); End; Procedure TPCDrawing.prConvertXY(var X,Y,Z: Double); Begin if VerticalZero = vzBottom then y := WorkHeight - y; if HorizontalZero = vzRight then x := WorkWidth - x; x := x - OFFMMX; y := y - OFFMMY; x := x - TileX; y := y - TileY; prConvertDim(x); prConvertDim(y); x := x + ConvertDx; y := y + ConvertDy; y := y - MCopyDelta; End; Procedure TPCDrawing.prConvertDim(var Dim: Double); Begin Dim := Dim * (prDpm * ConvertRatio * prnScale); End; Procedure TPCDrawing.blkConvertXY(var X,Y,Z: Double); begin if blkVZ = ord(vzBottom) then y := blkTopy - y else y := y-blkDistY; if blkHZ = ord(vzRight) then x := blkTopx - x else x := x-blkDistx; blkConvertDim(x); blkConvertDim(y); x := x+ConvertDx; y := y+ConvertDy; end; Procedure TPCDrawing.blkConvertDim(var Dim: Double); begin Dim := Dim * (dcDpm*ConvertRatio); end; Procedure TPCDrawing.dcConvertXY(var X,Y,Z:Double); Begin if VerticalZero = vzBottom then y := WorkHeight - y; if HorizontalZero = vzRight then x := WorkWidth - x; dcConvertDim(x); dcConvertDim(y); x := x + dcCoordx; y := y + dcCoordy; x := x+ConvertDx; y := y+ConvertDy; End; Procedure TPCDrawing.dcConvertXYTile(var X,Y,Z: Double); begin if VerticalZero = vzBottom then y := WorkHeight - y; if HorizontalZero = vzRight then x := WorkWidth - x; x := x - TileX; y := y - TileY; dcConvertDim(x); dcConvertDim(y); x := x + dcCoordx; y := y + dcCoordy; x := x+ConvertDx; y := y+ConvertDy; end; Procedure TPCDrawing.dcConvertDim(var Dim: Double); begin Dim := Dim * (dcDpm*ConvertRatio); end; Procedure TPCDrawing.prTileConvertXY(var X,Y,Z: Double); Begin if VerticalZero = vzBottom then y := WorkHeight - y; if HorizontalZero = vzRight then x := WorkWidth - x; x := x-TileX; y := y-TileY; prConvertDim(x); prConvertDim(y); x := x+ConvertDx; y := y+ConvertDy; y := y-MCopyDelta; End; Procedure TPCDrawing.bmpConvertXY(var X,Y,Z: Double); var minx,miny,maxx,maxy: Double; wHeight,wWidth: Double; Begin if prBmpRect.Left > prBmpRect.Right then begin minX := prBmpRect.Right; maxX := prBmpRect.Left; end else begin maxX := prBmpRect.Right; minX := prBmpRect.Left; end; if prBmpRect.Top > prBmpRect.bottom then begin minY := prBmpRect.Bottom; maxY := prBmpRect.Top; end else begin maxY := prBmpRect.Bottom; minY := prBmpRect.Top; end; y := y-minY; x := x-minX; wWidth := abs(prBmpRect.Right-prBmpRect.Left); wHeight := abs(prBmpRect.Top-prBmpRect.Bottom); if VerticalZero = vzBottom then y := wHeight - y; if HorizontalZero = vzRight then x := wWidth - x; bmpConvertDim(x); bmpConvertDim(y); x := x+ConvertDx; y := y+ConvertDy; End; Procedure TPCDrawing.bmpConvertDim(var Dim: Double); Begin Dim := Dim * (bmpDpm*ConvertRatio); End; Procedure TPCDrawing.PrnStartJob(TitleinStatusBox: String); begin Printer.BeginDoc; Printer.Title := TitleinStatusBox; end; Procedure TPCDrawing.PrnDoJob(NewPage: Boolean); begin if NewPage then Printer.NewPage; if FWmfPrint then PrintPageAsWmf else PrintPage; end; Procedure TPCDrawing.PrnAbortJob; begin Printer.Abort; end; Procedure TPCDrawing.PrnEndJob; begin Printer.EndDoc; end; Procedure TPCDrawing.PrintDrawing(TitleinStatusBox: String); var prW, prH: Double; resW, resH, mW, mH: Integer; begin tileY := 0; tileX := 0; MCopyDelta := 0; OFFMMX := 0; //29.11.2011 OFFMMY := 0; //29.11.2011 if FAutoTile and (not FWmfPrint) then begin prW := GetDeviceCaps(Printer.Handle, PHYSICALWIDTH); prH := GetDeviceCaps(Printer.Handle, PHYSICALHEIGHT); resW := GetDeviceCaps(Printer.Handle, LOGPIXELSX); resH := GetDeviceCaps(Printer.Handle, LOGPIXELSY); mW := GetDeviceCaps(Printer.Handle, PHYSICALOFFSETX); mH := GetDeviceCaps(Printer.Handle, PHYSICALOFFSETY); {//29.11.2011 OFFX := mW; if OFFX > 0 then begin OFFX := OFFX + 12.7; end; OFFY := mH; if OFFY > 0 then begin if PageOrient = PCTypesUtils.poLandscape then OFFY := OFFY + 25.4; if PageOrient = PCTypesUtils.poPortrait then OFFY := OFFY - 25.4; end; DPIX := resW; DPIY := resH; OFFMMX := (OFFX / DPIX) * 25.4; OFFMMY := (OFFY / DPIY) * 25.4; OFFMMX := 0; //28.11.2011 OFFMMX := (OFFX / DPIX) * 25.4; OFFMMY := 0; //28.11.2011 OFFMMY := (OFFY / DPIY) * 25.4;} mw := round((mw / resw) * 25.4 * 2) + 6; mh := round((mh / resh) * 25.4 * 2) + 6; prW := round((prW / resw) * 25.4); prH := round((prH / resw) * 25.4); if (((prW + prnReservTiling) < (WorkWidth*prnScale)) or ((prh + prnReservTiling) < (WorkHeight*prnScale))) then begin PrintByTiling(TitleinStatusBox, prW, prH); exit; end; end; {//28.11.2011 - непечатываемые поля принтера в мм DPIX := GetDeviceCaps(Printer.Handle, LOGPIXELSX); DPIY := GetDeviceCaps(Printer.Handle, LOGPIXELSY); OFFX := GetDeviceCaps(Printer.Handle, PHYSICALOFFSETX); OFFY := GetDeviceCaps(Printer.Handle, PHYSICALOFFSETY); OFFMMX := (OFFX / DPIX) * 25.4; OFFMMY := (OFFY / DPIY) * 25.4;} if (Abs(prnScale-1) < 0.1) and Assigned(FCheckPrnWithOffset) and FCheckPrnWithOffset(Self) then begin prW := GetDeviceCaps(Printer.Handle, PHYSICALWIDTH); prH := GetDeviceCaps(Printer.Handle, PHYSICALHEIGHT); resW := GetDeviceCaps(Printer.Handle, LOGPIXELSX); resH := GetDeviceCaps(Printer.Handle, LOGPIXELSY); mW := GetDeviceCaps(Printer.Handle, PHYSICALOFFSETX); mH := GetDeviceCaps(Printer.Handle, PHYSICALOFFSETY); OFFX := mW; if OFFX > 0 then begin //OFFX := OFFX + 12.7; end; OFFY := mH; {if OFFY > 0 then begin if PageOrient = PCTypesUtils.poLandscape then OFFY := OFFY + 25.4; if PageOrient = PCTypesUtils.poPortrait then OFFY := OFFY - 25.4; end;} DPIX := resW; DPIY := resH; OFFMMX := (OFFX / DPIX) * 25.4; OFFMMY := (OFFY / DPIY) * 25.4; //02.12.2011 - смещения OFFMMX := OFFMMX + 0.5; if PageOrient = PCTypesUtils.poLandscape then begin OFFMMY := OFFMMY + 0.5; end else if PageOrient = PCTypesUtils.poPortrait then begin OFFMMY := OFFMMY - 0.5; if OFFMMY < 0 then OFFMMY := 0; end; end; Printer.BeginDoc; Printer.Title := TitleinStatusBox; if FWmfPrint then begin PrintPageAsWmf; end else begin PrintPage; end; Printer.EndDoc; end; Procedure TPCDrawing.PrintPage; var a,b: integer; Layer: TLayer; PrinterBmp, tBmp: TBitmap; Figure, xFigure: TFigure; isDraw, isFlue: boolean; bH, bW: double; xFigures: TList; // Test X, Y, Z, Dim: Double; Rect: TRect; begin {$ifndef betatest} ResetRegions; xFigures := TList.Create; // сформировать лист всех фигур For a := 0 to Figures.count - 1 do begin Figure := TFigure(Figures[a]); if (figure is TFigureGrp) then begin if TFigureGrp(figure).Visible then TFigureGrp(figure).GetFigures(xFigures); end else begin xFigures.Add(Figure); end; end; prDpm := (GetDeviceCaps(Printer.Handle, LOGPIXELSX) / 25.4); prDpm := (GetDeviceCaps(Printer.Handle, LOGPIXELSY) / 25.4); // перебор всех фигур For a := 0 to xFigures.count - 1 do begin Figure := TFigure(xFigures[a]); isDraw := True; if Figure.LayerHandle > 0 then begin Layer := TLayer(Figure.LayerHandle); isDraw := (Layer.visible <> lost); isFlue := (Layer.visible = Grayed); end; // MY if not Figure.Visible then isDraw := False; // // для BMP фигур if (isDraw and (Figure is TBmpObject) and (TBMPObject(Figure).Transparent)) then begin tBmp := TBitmap.Create; prBmpRect := Figure.getboundRect; bW := abs(prBmpRect.Left - prBmpRect.Right); bH := abs(prBmpRect.Top - prBmpRect.Bottom); tBmp.Width := 5; tBmp.Height := 5; SetEngine(tBmp.Canvas, prConvertXY, prDeConvertXY, prConvertDim, prDeConvertDim, true, tBmp); Dengine.DefinePrinting; //24.11.2011 Figure.draw(Dengine, isFlue); Figure.DrawDimLines(Dengine, isFlue); PrinterBmp := TBitmap.Create; if Figure.ap1.y = Figure.ap2.y then begin PrinterBmp.Width := TBMPObject(Figure).Picture.Width; PrinterBmp.Height := TBMPObject(Figure).Picture.Height; end else begin // rotated PrinterBmp.Width := TBMPObject(Figure).Image.Width; PrinterBmp.Height := TBMPObject(Figure).Image.Height; end; bmpDpm := PrinterBmp.Width / bw; SetEngine(PrinterBmp.Canvas, bmpConvertXY, prDeConvertXY, bmpConvertDim, prDeConvertDim, false, nil); Dengine.DefinePrinting; //24.11.2011 For b := 0 to a - 1 do begin xFigure := TFigure(xFigures[b]); isDraw := True; isFlue := False; if Figure.LayerHandle > 0 then begin Layer := TLayer(Figure.LayerHandle); isDraw := (Layer.visible <> lost); isFlue := (Layer.visible = Grayed); end; if (isDraw or (Figure is TFigureGrp)) then begin xFigure.draw(Dengine, isflue); xFigure.DrawDimLines(Dengine, isFlue); end; end; SetEngine(Printer.Canvas, prConvertXY, prDeConvertXY, prConvertDim, prDeConvertDim, true, PrinterBmp); Dengine.DefinePrinting; //24.11.2011 Figure.draw(Dengine, isFlue); Figure.DrawDimLines(Dengine, isFlue); PrinterBmp.free; tBmp.free; end else // для не BMP if isDraw then begin PrinterBmp := TBitmap.Create; // Rect := Printer.Canvas.ClipRect; // Rect.Left := Rect.Left + 35; // Rect.Right := Rect.Right + 35; // Rect.Top := Rect.Top + 35; // Rect.Bottom := Rect.Bottom + 35; // Printer.Canvas.DrawFocusRect(Rect); SetEngine(Printer.Canvas, prConvertXY, prDeConvertXY, prConvertDim, prDeConvertDim, true, PrinterBmp); Dengine.DefinePrinting; //24.11.2011 if IsDraw then begin // Printer.Canvas.MoveTo(-6, -6); // Printer.Canvas.LineTo(100, 100); Figure.draw(Dengine, isFlue); Figure.DrawDimLines(Dengine, isFlue); end; end; end; // if assigned(PrinterBmp) then // PrinterBmp.SaveToFile('c:\11111111111.bmp'); xFigures.Free; ResetRegions; {$endif betatest} end; Procedure TPCDrawing.PrintByTiling(TitleinStatusBox: String; prWmm,prHmm: Double); var pi,pk : integer; prow, pcol : integer; r: trect; bm: Tbitmap; OldTileX, OldTileY: Double; Begin OldTileX := TileX; OldTileY := TileY; DefinePrnDivIndent; //29.11.2011 prDpm := (GetDeviceCaps(Printer.Handle,LOGPIXELSX)/25.4); {//05.12.2011 if prHmm >= WorkHeight then prow := 1 else begin prHmm := prHmm - prnDivIndentX; prow := Trunc((WorkHeight+(prHmm)-1) / prHmm); end; if prWmm >= WorkWidth then pcol := 1 else begin prWmm := prWmm - prnDivIndentY; pcol := Trunc((WorkWidth+(prWmm)-1) / (prWmm)); end;} CalcPrDims(prWmm, prHmm, prow, pcol, WorkWidth, WorkHeight, prnScale); Printer.Title := TitleinStatusBox; Printer.BeginDoc; //04.01.2012 bm := GCadForm.PCad.CreatePreviewBitmap; //04.01.2012 bm.SaveToFile('111.bmp'); // GCadForm.PCad.DrawToCanvas(Printer.Canvas, 0, 0, 2.95 / 1.41); for pi := 1 to prow do begin tileY := (pi-1) * prHmm / prnScale; for pk := 1 to pcol do begin tileX := (pk-1) * prWmm / prnScale; if FWmfPrint then PrintPageAsWmf else PrintPage; if not ((pi = prow) and (pk = pcol)) then Printer.NewPage; end; end; Printer.EndDoc; TileX := OldTileX; TileY := OldTileY; end; procedure TPCDrawing.PrintRect(aRect: TDoubleRect); var pRect: TDoubleRect; rWidth, rHeight: Double; prW, prH: Double; resW, resH, mW, mH: Integer; Procedure PrintRectByTiling(prWmm,prHmm: Double); var pi,pk : integer; prow, pcol : integer; r: trect; bm: Tbitmap; Begin DefinePrnDivIndent; //29.11.2011 prDpm := (GetDeviceCaps(Printer.Handle,LOGPIXELSX)/25.4); {if prHmm >= rHeight then prow := 1 else begin prHmm := prHmm - prnDivIndentX; prow := Trunc((rHeight+(prHmm)-1) / prHmm); end; if prWmm >= rWidth then pcol := 1 else begin prWmm := prWmm - prnDivIndentY; pcol := Trunc((rWidth+(prWmm)-1) / (prWmm)); end;} CalcPrDims(prWmm, prHmm, prow, pcol, rWidth, rHeight, prnScale); Printer.BeginDoc; For pi := 1 to prow do begin tileY := pRect.Top + (pi-1) * prHmm / prnScale; for pk := 1 to pcol do begin tileX := pRect.Left + (pk-1) * prWmm / prnScale; if FWmfPrint then PrintPageAsWmf else PrintPage; ClearNoRect(pRect); if not ((pi = prow) and (pk = pcol)) then Printer.NewPage; end; end; Printer.EndDoc; end; Begin Printer.Title := 'Drawing rect'; tileY := 0; tileX := 0; //02.10.2013 pRect.Left := Min(aRect.Left, aRect.Right); pRect.Top := Min(aRect.Top, aRect.Bottom); pRect.Right := Max(aRect.Left, aRect.Right); pRect.Bottom := Max(aRect.Top, aRect.Bottom); rWidth := pRect.Right - pRect.Left; rHeight := pRect.Bottom - pRect.Top; MCopyDelta := 0; prW := GetDeviceCaps(Printer.Handle, PHYSICALWIDTH); prH := GetDeviceCaps(Printer.Handle, PHYSICALHEIGHT); resW := GetDeviceCaps(Printer.Handle, LOGPIXELSX); resH := GetDeviceCaps(Printer.Handle, LOGPIXELSY); mW := GetDeviceCaps(Printer.Handle, PHYSICALOFFSETX); mH := GetDeviceCaps(Printer.Handle, PHYSICALOFFSETY); OFFMMX := 0; //3; OFFMMY := 0; //3; mw := round((mw / resw) * 25.4 * 2) + 6; mh := round((mh / resh) * 25.4 * 2) + 6; prw := round((prW / resw) * 25.4); prH := round((prH / resw) * 25.4); if (((prW + prnReservTiling) < (rWidth*prnScale)) or ((prh + prnReservTiling) < (rHeight*prnScale))) then begin PrintRectByTiling(prW, prH); exit; end; Printer.BeginDoc; try tileX := pRect.Left; tileY := pRect.Top; PrintPage; ClearNoRect(aRect); finally Printer.EndDoc; end; tileY := 0; tileX := 0; end; procedure TPCDrawing.CalcPrDims(var prWmm, prHmm: Double; var prow, pcol: Integer; AWorkW, AWorkH, AprnScale: Double); begin AWorkW := AWorkW * AprnScale; AWorkH := AWorkH * AprnScale; prDpm := (GetDeviceCaps(Printer.Handle,LOGPIXELSX)/25.4); if prHmm >= AWorkH then prow := 1 else begin prHmm := prHmm - prnDivIndentX; prow := {RoundUp(AWorkH / prHmm); //28.11.2011} Trunc((AWorkH+(prHmm)-1) / prHmm); end; if prWmm >= AWorkW then pcol := 1 else begin prWmm := prWmm - prnDivIndentY; pcol := {RoundUp(AWorkW / prWmm); //28.11.2011} Trunc((AWorkW+(prWmm)-1) / (prWmm)); end; end; procedure TPCDrawing.DefinePrnDivIndent; //29.11.2011 var DPIX, DPIY: double; OFFX, OFFY: double; begin PrnDivIndentX := PrnDivIndent; PrnDivIndentY := PrnDivIndent; DPIX := GetDeviceCaps(Printer.Handle, LOGPIXELSX); DPIY := GetDeviceCaps(Printer.Handle, LOGPIXELSY); OFFX := GetDeviceCaps(Printer.Handle, PHYSICALOFFSETX); OFFY := GetDeviceCaps(Printer.Handle, PHYSICALOFFSETY); PrnDivIndentX := (OFFX / DPIX) * 25.4; if PrnDivIndentX < PrnDivIndent then PrnDivIndentX := PrnDivIndent; PrnDivIndentX := PrnDivIndentX + prnDivOverlay; PrnDivIndentY := (OFFY / DPIY) * 25.4; if PrnDivIndentY < PrnDivIndent then PrnDivIndentY := PrnDivIndent; PrnDivIndentY := PrnDivIndentY + prnDivOverlay; end; procedure TPCDrawing.MirrorSelection(Point1,Point2: TDoublePoint; dupl: boolean); var a: integer; begin if RecordUndo then if not dupl then RecordModifyUndo(nil); if dupl then duplicateselection(0,0); for a := 0 to Figures.count - 1 do begin if TFigure(Figures[a]).selected then begin TFigure(Figures[a]).mirror(Point1,Point2); end; end; refresh; Updated := True; end; Procedure TPCDrawing.InterBreakSelection; var i,bCnt,k: Integer; Selecteds: TList; breaker: TFigure; bp1,bp2: TDoublePoint; fig: TFigure; bList: TList; bArr,bPoints: TDoublePointArr; fList: TList; rList: TList; NewFigures: TList; TrashFigures: TList; found,done: boolean; Nonbreaks: TList; xAction: TUndoAction; begin Selecteds := TList.Create; // Tolik -- 07/02/2017 -- это -- после проверки -- а вдруг вывалится нах, зачем лишнее создавать/удалять? {bList := TList.Create; rList := TList.Create; fList := TList.Create; NewFigures := TList.Create; TrashFigures := TList.Create; NonBreaks := TList.Create;} done := false; found := false; CollectSelectedFigures(Selecteds); // Tolik -- 07/02/2017 -- утечка памяти !!! //if selecteds.count = 0 then exit; if selecteds.count = 0 then begin FreeAndNil(Selecteds); exit; end; bList := TList.Create; rList := TList.Create; fList := TList.Create; NewFigures := TList.Create; TrashFigures := TList.Create; NonBreaks := TList.Create; // if RecordUndo then xAction := TUndoAction.Create(uaReplace); repeat i := 0; found := false; repeat breaker := TFigure(Selecteds[i]); if (breaker is DrawObjects.TLine) and not (breaker is TPolyline) and (nonbreaks.IndexOf(breaker) = -1) then found := true; i := i + 1; until found or (i = Selecteds.Count); if not found then begin done := true; end else begin bp1 := breaker.ap1; bp2 := breaker.ap2; SetLength(bPoints,0); bCnt := 0; for i := 0 to Selecteds.Count - 1 do begin fig := TFigure(Selecteds[i]); bList.Clear; if (fig <> breaker) and fig.Knife(bp1,bp2,bList) then begin for k := 0 to bList.Count - 1 do fList.Add(bList[k]); rList.Add(fig); SetLength(bArr,0); if fig.GetLinearInterSections(bp1,bp2,bArr) then begin bCnt := bCnt+Length(bArr); SetLength(bPoints,bCnt); for k := 0 to Length(bArr)- 1 do bPoints[bcnt - k - 1] := bArr[k]; end; end; end; if bCnt > 0 then begin bList.Clear; if breaker.BreakbyPoints(bPoints,bList) then begin rList.Add(breaker); for k := 0 to bList.Count - 1 do fList.Add(bList[k]); for k := 0 to bList.Count - 1 do NonBreaks.Add(bList[k]); end; end; NonBreaks.Add(breaker); for k := 0 to rList.Count - 1 do begin Selecteds.Remove(rList[k]); TrashFigures.Add(rList[k]); end; rList.Clear; for k := 0 to fList.Count - 1 do begin fig := TFigure(fList[k]); Selecteds.Add(fig); NewFigures.Add(fig); end; fList.Clear; end; until done; for i := TrashFigures.Count - 1 downto 0 do begin fig := TFigure(TrashFigures[i]); fig.Deselect; fig.Deleted := True; fig.delIndex := Figures.IndexOf(fig); if (RecordUndo) and (fig.delIndex > -1) then begin xAction.Params.Add(fig); fig.Urc := fig.Urc + 1; end else begin fig.destroy; end; Figures.Remove(fig); Newfigures.Remove(fig); end; for i := 0 to NewFigures.Count - 1 do begin fig := TFigure(NewFigures[i]); Figures.Add(fig); fig.select; if RecordUndo then xAction.List.Add(fig); end; if RecordUndo then begin if xAction.List.Count > 0 then InsertUndoAction(xAction) else xAction.Free; end; Selecteds.free; bList.free; rList.free; fList.free; NewFigures.free; TrashFigures.Free; NonBreaks.Free; refresh; Updated := True; end; Procedure TPCDrawing.KnifeSelection(Point1,Point2: TDoublePoint); var a,i: integer; xList,yList: TList; bfig,fig :Tfigure; xAction : TUndoAction; begin xList := TList.Create; yList := TList.Create; if RecordUndo then xAction := TUndoAction.Create(uaReplace); a := Figures.count; repeat a := a - 1; bFig := TFigure(Figures[a]); if bfig.selected then begin if bFig.Knife(Point1,Point2,yList) then begin for i := 0 to yList.Count - 1 do xList.Add(yList[i]); bFig.Deselect; bFig.Deleted := True; if RecordUndo then begin xAction.Params.Add(bfig); bFig.Urc := bfig.Urc + 1; bFig.delIndex := Figures.IndexOf(bFig); end else begin bFig.destroy; end; Figures.Delete(a); end; end; yList.Clear; until a = 0; for a := 0 to xList.Count - 1 do begin fig := TFigure(xList[a]); fig.Select; Figures.Add(fig); if RecordUndo then xAction.List.Add(fig); end; if RecordUndo then begin if xAction.list.Count > 0 then InsertUndoAction(xAction) else xAction.Free; end; refresh; Updated := True; xList.free; yList.Free; end; Procedure TPCDrawing.LockSelectionToMove(Locked:Boolean); var a: integer; begin for a := 0 to Figures.count - 1 do begin if TFigure(Figures[a]).selected then begin TFigure(Figures[a]).LockMove:= Locked; end; end; end; Procedure TPCDrawing.LockSelectionToModify(Locked:Boolean); var a: integer; begin for a := 0 to Figures.count - 1 do begin if TFigure(Figures[a]).selected then begin TFigure(Figures[a]).LockModify:= Locked; end; end; end; procedure TPCDrawing.RotateSelection(Angle:Double;rPoint: TDoublePoint); var a: integer; begin if RecordUndo then RecordModifyUndo(nil); for a := 0 to Figures.count - 1 do begin if TFigure(Figures[a]).selected then begin TFigure(Figures[a]).Rotate(angle,rPoint); end; end; refresh; Updated := True; end; Procedure TPCDrawing.ScaleDrawing(percentx,percenty:Double); var a: integer; rPoint:TDoublePoint; dRect: TDoubleRect; begin dRect := GetDrawingRect; //rPoint := DoublePoint((drect.left+drect.right)/2,(drect.top+drect.bottom)/2); rPoint := DoublePoint(drect.left,drect.bottom); for a := 0 to Figures.count-1 do Tfigure(Figures[a]).scale(percentx,percenty,rPoint); refresh; Updated := True; end; procedure TPCDrawing.scaleSelection(percentx,percenty:Double;rPoint: TDoublePoint); var a: integer; begin for a := 0 to Selection.count-1 do if TFigure(Selection[a]).selected then Tfigure(Selection[a]).scale(percentx,percenty,rPoint); refresh; Updated := True; end; Function TPCDrawing.GetDrawingRect: TDoubleRect; Var Resrect : TDoublerect; a: Integer; MaxX, MaxY, MinX, MinY : Double; figMaxX, figMaxY, figMinX, figMinY: Double; // Tolik 22/8/2019 -- function CheckCorrectBounds: Boolean; begin Result := True; //abs(figMinY) > 10e+11 //abs(figMinY) < 10e-11 //if Pos('E', FloatTostr(figMinX)) > 0 then //if ((abs(figMinX) > 10e+11) or (abs(figMinX) < 10e-11)) then if (abs(figMinX) > 10e+11) then //or ((abs(figMinX) < 10e-11) and (abs(figMinX) > 0.0000001 )) then begin Result := False; exit; end else if (abs(figMinX) < 10e-11) then figMinX := 0; //if Pos('E', FloatTostr(figMaxX)) > 0 then //if ((abs(figMaxX) > 10e+11) or (abs(figMaxX) < 10e-11)) then if (abs(figMaxX) > 10e+11) then //or (figMaxX < -10e-11)) then begin Result := False; exit; end else if (abs(figMaxX) < 10e-11) then figMaxX := 0; //if Pos('E', FloatTostr(figMaxY)) > 0 then //if ((abs(figMaxY) > 10e+11) or (abs(figMaxY) < 10e-11)) then if (abs(figMaxY) > 10e+11) then//or (figMaxY < -10e-11)) then begin Result := False; exit; end else if (abs(figMaxY) < 10e-11) then figMaxY := 0; //if Pos('E', FloatTostr(figMinY)) > 0 then //if ((abs(figMinY) > 10e+11) or (abs(figMinY) < 10e-11)) then if (abs(figMinY) > 10e+11) then//or (figMinY < -10e-11)) then begin Result := False; exit; end else if (abs(figMinY) < 10e-11) then figMinY := 0; end; // begin if Figures.count = 0 then begin Result := DoubleRect(0, 0, 0, 0); exit; end; figMaxX := 0; figMaxY := 0; figMinX := 0; figMinY := 0; TFigure(Figures[0]).GetBounds(figMaxX, figMaxY, figMinX, figMinY); // Tolik 22/08/2019 -- //MaxX := figMaxX; //MinX := figMinX; //MaxY := figMaxY; //MinY := figMinY; MaxX := 0; MinX := 0; MaxY := 0; MinY := 0; if CheckCorrectBounds then begin MaxX := figMaxX; MinX := figMinX; MaxY := figMaxY; MinY := figMinY; end; // for a := 1 to Figures.Count - 1 do begin TFigure(Figures[a]).GetBounds(figMaxX, figMaxY, figMinX, figMinY); // Tolik 22/08/2019 if CheckCorrectBounds then begin // if figMaxX > MaxX then MaxX := figMaxX; if figMaxY > MaxY then MaxY := figMaxY; if figMinX < MinX then if minX > 0 then MinX := figMinX; if figMinY < MinY then if MinY > 0 then MinY := figMinY; end; end; ResRect.left := MinX; ResRect.right := MaxX; ResRect.Top := MinY; ResRect.Bottom := MaxY; Result := ResRect; end; function TPCDrawing.GetFigureListRect(AFigures: TList): TDoubleRect; Var a: Integer; MaxX,MaxY,MinX,MinY : Double; figMaxX,figMaxY,figMinX,figMinY: Double; begin if AFigures.count = 0 then begin Result := DoubleRect(0,0,0,0); exit; end; TFigure(AFigures[0]).GetSelBounds(figMaxX,figMaxY,figMinX,figMinY); MaxX := figMaxX; MinX := figMinX; MaxY := figMaxY; MinY := figMinY; for a := 1 to AFigures.Count - 1 do begin TFigure(AFigures[a]).GetSelBounds(figMaxX,figMaxY,figMinX,figMinY); if figMaxX > MaxX then MaxX := figMaxX; if figMinX < MinX then MinX := figMinX; if figMaxY > MaxY then MaxY := figMaxY; if figMinY < MinY then MinY := figMinY; end; Result.left := MinX; Result.right := MaxX; Result.Top := MinY; Result.Bottom := MaxY; end; Procedure TPCDrawing.GetDrawingBounds(var MaxX,MaxY,MinX,MinY: Double); Var a:Integer; figMaxX,figMaxY,figMinX,figMinY: Double; begin MaxX := 0; MaxY := 0; MinX := 0; MinY := 0; if Figures.count = 0 then exit; TFigure(Figures[0]).GetBounds(figMaxX,figMaxY,figMinX,figMinY); MaxX := figMaxX; MinX := figMinX; MaxY := figMaxY; MinY := figMinY; for a := 1 to Figures.Count - 1 do begin TFigure(Figures[a]).GetBounds(figMaxX,figMaxY,figMinX,figMinY); if figMaxX > MaxX then MaxX := figMaxX; if figMinX < MinX then MinX := figMinX; if figMaxY > MaxY then MaxY := figMaxY; if figMinY < MinY then MinY := figMinY; end; end; Function TPCDrawing.getSelectionRect: TDoubleRect; Var Resrect : TDoublerect; a: Integer; MaxX,MaxY,MinX,MinY : Double; figMaxX,figMaxY,figMinX,figMinY: Double; begin if Selection.count = 0 then begin Result := DoubleRect(0,0,0,0); exit; end; TFigure(Selection[0]).GetSelBounds(figMaxX,figMaxY,figMinX,figMinY); MaxX := figMaxX; MinX := figMinX; MaxY := figMaxY; MinY := figMinY; for a := 1 to Selection.Count - 1 do begin TFigure(Selection[a]).GetSelBounds(figMaxX,figMaxY,figMinX,figMinY); if figMaxX > MaxX then MaxX := figMaxX; if figMinX < MinX then MinX := figMinX; if figMaxY > MaxY then MaxY := figMaxY; if figMinY < MinY then MinY := figMinY; end; ResRect.left := MinX; ResRect.right := MaxX; ResRect.Top := MinY; ResRect.Bottom := MaxY; Result := ResRect; end; Procedure TPCDrawing.GetSelectionBoundS(var MaxX,MaxY,MinX,MinY: Double); Var Selecteds : TList; Resrect : TDoublerect; a: integer; figMaxX,figMaxY,figMinX,figMinY: Double; begin Selecteds := TList.Create; CollectSelectedFigures(Selecteds); if selecteds.count = 0 then begin figMaxX := 0;figMaxY := 0;figMinX := 0;figMinY := 0; // Tolik -- 07/02/2017 -- утечка памяти!!! FreeAndNil(Selecteds); // exit; end; TFigure(Selecteds[0]).GetBounds(figMaxX,figMaxY,figMinX,figMinY); MaxX := figMaxX; MinX := figMinX; MaxY := figMaxY; MinY := figMinY; for a := 1 to Selecteds.Count - 1 do begin TFigure(Selecteds[a]).GetBounds(figMaxX,figMaxY,figMinX,figMinY); if figMaxX > MaxX then MaxX := figMaxX; if figMinX < MinX then MinX := figMinX; if figMaxY > MaxY then MaxY := figMaxY; if figMinY < MinY then MinY := figMinY; end; Selecteds.Free; end; Procedure TPCDrawing.ArrayRectSelection(distanceX,distanceY: Double;col,row: integer); var selecteds : TList; a,b,x : integer; newFig,Fig : TFigure; xAction: TUndoAction; begin selecteds := TList.create; CollectSelectedFigures(selecteds); if RecordUndo then xAction := TUndoAction.Create(uaInsert); for a := 0 to row-1 do begin for b := 0 to col-1 do begin if not((a = 0) and (b = 0)) then begin for x := 0 to selecteds.count - 1 do begin fig := TFigure(selecteds[x]); newFig := fig.duplicate; newFig.move(distanceX*b,distanceY*a); Figures.Add(newFig); if RecordUndo then xAction.List.Add(newFig); end; end; end; end; Selecteds.Free; if RecordUndo then begin InsertUndoAction(xAction); end; if assigned(FOnObjectInserted) then FOnObjectInserted(self,irCreate); refresh; Updated := True; end; Procedure TPCDrawing.ArrayPolarSelection(cpoint: TDoublePoint; angle: Double); var selecteds : TList; a,b,x : integer; fig : TFigure; newFig : TFigure; bounds : TRect; MaxY,MinY, MaxX, MinX, distanceX,distanceY: Double; nbrofDups: Integer; centerSelecteds, NewPoint : TDoublePoint; xAction:TUndoAction; xAngle: Double; neg : Integer; begin selecteds := TList.create; CollectSelectedFigures(selecteds); neg := 1; if angle < 0 then neg := -1; //angle := angle*neg; nbrOfDups := Round((2*pi) / abs(angle)) -1; GetselectionBounds(MaxX,MaxY, MinX, MinY); centerSelecteds.x := MinX+ (MaxX-MinX)/2; centerSelecteds.y := MinY+ (MaxY-MinY)/2; if RecordUndo then xAction := TUndoAction.Create(uaInsert); for a := 1 to nbrOfDups do begin //xAngle := (abs(angle))*a; //xAngle := xAngle * neg; xAngle := angle*a; for x := 0 to selecteds.count - 1 do begin NewPoint := RotatePoint(cPoint,CenterSelecteds, xAngle); distanceX := NewPoint.x - centerSelecteds.x; distanceY := NewPoint.y - centerSelecteds.y; fig := TFigure(selecteds[x]); newFig := fig.duplicate; //newFig.Move(distanceX,distanceY); //newfig.Rotate(xAngle , NewPoint); newfig.Rotate(xAngle , cPoint); Figures.Add(newFig); if RecordUndo then xAction.List.Add(newFig); end; end; if assigned(FOnObjectInserted) then FOnObjectInserted(self,irCreate); Selecteds.Free; if RecordUndo then begin InsertUndoAction(xAction); end; refresh; Updated := True; End; Procedure TPCDrawing.DuplicateSelectionAsBezier(deltax,deltay: Double); var selecteds : TList; a,x,i : integer; fig : TFigure; newFig : TFigure; xAction : TUndoAction; begin selecteds := TList.create; CollectSelectedFigures(Selecteds); // Tolik -- 07/02/2017 -- утечка памяти!!! //if selecteds.count = 0 then exit; if selecteds.count = 0 then begin freeAndNil(Selecteds); exit; end; // deselectall(0); if RecordUndo then xAction := TUndoAction.Create(uaInsert); for x := 0 to selecteds.count - 1 do begin fig := TFigure(selecteds[x]); newFig := fig.duplicateAsBezier; if assigned(newfig) then begin newFig.move(deltaX,deltaY); if (fig is TTExt) and (newFig is TFigureGrp) then begin for i :=0 to TFigureGrp(newFig).InFigures.Count-1 do begin TFigure(TFigureGrp(newFig).InFigures[i]).Select; Figures.Add(TFigureGrp(newFig).InFigures[i]); if RecordUndo then xAction.List.Add(TFigureGrp(newFig).InFigures[i]); if assigned(FOnObjectInserted) then FOnObjectInserted(self,irCreate); end; newfig.Destroy; end else begin newFig.Selected := True; Figures.Add(newFig); if RecordUndo then xAction.List.Add(newFig); if assigned(FOnObjectInserted) then FOnObjectInserted(self,irCreate); end; end; end; FAnySelected := true; Selecteds.Free; if RecordUndo then begin if xAction.List.Count > 0 then InsertUndoAction(xAction) else begin xAction.Free; end; end; refresh; Updated := True; end; Procedure TPCDrawing.ConvertSelectionToBezier; var selecteds : TList; a,x,i : integer; fig : TFigure; newFig : TFigure; xAction : TUndoAction; begin selecteds := TList.create; CollectSelectedFigures(Selecteds); // Tolik -- 07/02/2017 -- утечка памяти!!! //if selecteds.count = 0 then exit; if selecteds.count = 0 then begin freeAndNil(Selecteds); exit; end; // if RecordUndo then xAction := TUndoAction.Create(uaReplace); for x := 0 to selecteds.count - 1 do begin fig := TFigure(selecteds[x]); newFig := fig.duplicateAsBezier; //newFig := fig.duplicateAsStroke; if assigned(newfig) then begin fig.Deselect; fig.Deleted := True; if (not (fig is TFigureGrp)) and (newFig is TFigureGrp) then begin for i :=0 to TFigureGrp(newFig).InFigures.Count-1 do begin TFigure(TFigureGrp(newFig).InFigures[i]).Select; Figures.Add(TFigureGrp(newFig).InFigures[i]); if RecordUndo then xAction.List.Add(TFigureGrp(newFig).InFigures[i]); end; TFigureGrp(newFig).Infigures.Clear; newfig.Destroy; end else begin newFig.Select; Figures.Add(newFig); if RecordUndo then xAction.List.Add(newFig); end; if RecordUndo then begin xAction.Params.Add(fig); fig.Urc := fig.Urc+1; fig.delIndex := Figures.IndexOf(fig); end else begin fig.destroy; end; Figures.Remove(fig); end; end; FAnySelected := true; Selecteds.Free; if RecordUndo then begin if xAction.List.Count > 0 then begin InsertUndoAction(xAction); end else xAction.Free; end; refresh; Updated := True; end; Procedure TPCDrawing.DuplicateSelection(deltaX,deltaY:Double); var selecteds : TList; a,x : integer; fig : TFigure; newFig : TFigure; xAction : TUndoAction; begin selecteds := TList.create; CollectSelectedFigures(Selecteds); // Tolik -- 07/02/2017 -- утечка памяти!!! //if selecteds.count = 0 then exit; if selecteds.count = 0 then begin freeAndNil(Selecteds); exit; end; // deselectall(0); if RecordUndo then xAction := TUndoAction.Create(uaInsert); for x := 0 to selecteds.count - 1 do begin fig := TFigure(selecteds[x]); newFig := fig.duplicate; if assigned(newfig) then begin newFig.move(deltaX,deltaY); newFig.Selected := True; Figures.Add(newFig); if RecordUndo then xAction.List.Add(newFig); if assigned(FOnObjectInserted) then FOnObjectInserted(self,irCreate); end; end; FAnySelected := true; Selecteds.Free; if RecordUndo then begin InsertUndoAction(xAction); end; refresh; Updated := True; end; Function TPCDrawing.CountBlock(BlockName:String):integer; var f:TFigure; a,cnt,i: integer; fg: TFigureGrp; begin cnt := 0; for a := 0 to Figures.Count-1 do begin f := TFigure(Figures[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 TPCDrawing.CountBlocks(list:TStrings); var f:TFigure; a: integer; counts: array of Integer; fg: TFigureGrp; bName: String; idx: Integer; begin if not assigned(list) then exit; list.Clear; for a := 0 to Figures.Count-1 do begin f := TFigure(Figures[a]); if f is TBlock then begin bName := TBlock(f).BlockName; idx := list.IndexOf(bName); if idx = -1 then begin list.Add(bName); SetLength(Counts,list.Count); Counts[List.Count-1] := 1; end else begin Counts[idx] := Counts[idx]+1; end; end; end; For a := 0 to list.Count-1 do begin list[a] := List[a] +' '+ inttostr(Counts[a]); end; end; Procedure TPCDrawing.CountBlocksByInfo(list:TStrings); var f:TFigure; a: integer; counts: array of Integer; fg: TFigureGrp; bName: String; idx: Integer; begin if not assigned(list) then exit; list.Clear; for a := 0 to Figures.Count-1 do begin f := TFigure(Figures[a]); if (f is TBlock) and (TBlock(f).Info <> '') then begin bName := TBlock(f).Info; idx := list.IndexOf(bName); if idx = -1 then begin list.Add(bName); SetLength(Counts,list.Count); Counts[List.Count-1] := 1; end else begin Counts[idx] := Counts[idx]+1; end; end; end; For a := 0 to list.Count-1 do begin list[a] := List[a] +' '+ inttostr(Counts[a]); end; end; //////////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////////// /// Figure Commands Function TPCDrawing.AddCustomFigure(LayerNbr:integer;CustomFig: TFigure;Selected:Boolean): TFigHandle; var i: Integer; vLayer: TLayer; figLayerNbr: Integer; begin if (layerNbr < 0) or (layerNbr > layers.count) then layerNbr := 0; CustomFig.LayerHandle := Integer(Layers[LayerNbr]); CustomFig.Owner := self; if CustomFig is TfigureGrp then begin for i := 0 to TFigureGrp(CustomFig).InFigures.Count - 1 do begin vLayer := Tlayer(TFigure(TFigureGrp(CustomFig).InFigures[i]).LayerHandle); if (vLayer = nil) or (not vLayer.IsDxf) then TFigure(TFigureGrp(CustomFig).InFigures[i]).LayerHandle := Integer(Layers[LayerNbr]); if vLayer = nil then AddExceptionToLogEx('TPCDrawing.AddCustomFigure', 'Not defined Layer for Object'); TFigure(TFigureGrp(CustomFig).InFigures[i]).Owner := Self; end; end; figures.add(Customfig); if selected then CustomFig.Select; result := Customfig.Handle; if selected then FAnySelected := true; if assigned(FOnObjectInserted) then FOnObjectInserted(self,irCreate); Updated := True; if CheckAssignedPCAD(Self) then begin if (LayerNbr = 2)or(LayerNbr = 9) then begin TF_CAD(Self.Owner).FNeedUpdateCheckedFigures := True; //GCadForm.FNeedUpdateCheckedFigures := True; end; end; end; Function TPCDrawing.GetCustomStream(var size:Integer):Integer; var buf:pByte; begin result := 0; size := 0; if assigned(CustomStream) then begin size := CustomStream.Size; GetMem(buf,size); CustomStream.Position := 0; CustomStream.Read(buf^,size); result := Integer(buf); end; end; Procedure TPCDrawing.SetCustomStream(size:Integer;var data:Byte); begin if assigned(CustomStream) then CustomStream.Free; if (size > 0) then begin CustomStream := TMemoryStream.Create; CustomStream.Write(data,size); CustomStream.Position := 0; // WARNING CustomStream.Free; end; end; Function TPCDrawing.GetFigureCustomStream(f:Integer; var size:Integer):Integer; var figure:TFigure; buf:pByte; begin figure := TFigure(f); result := 0; size := 0; if assigned(figure.CustomStream) then begin size := figure.CustomStream.Size; GetMem(buf,size); figure.CustomStream.Position := 0; figure.CustomStream.Read(buf^,size); result := Integer(buf); end; end; Procedure TPCDrawing.SetFigureCustomStream(f:Integer;size:Integer;var data:Byte); var figure: TFigure; begin figure := TFigure(f); if assigned(figure.CustomStream) then figure.CustomStream.Free; if (size > 0) then begin figure.CustomStream := TMemoryStream.Create; figure.CustomStream.Write(data,size); figure.CustomStream.Position := 0; // WARNING figure.CustomStream.Free; end; end; Function TPCDrawing.line(LayerNbr:Integer;x1,y1,x2,y2:Double;w,s,c:integer; row:integer; Selected: Boolean):TFigHandle; var f : TFigure; begin if (layerNbr<0) or (layerNbr>layers.count) then LayerNbr := 0; f := DrawObjects.TLine.create(x1,y1,x2,y2,w,s,c,row,LongInt(Layers[LayerNbr]),mydsNormal,self); figures.add(f); if selected then f.select; result := f.Handle; if assigned(FOnObjectInserted) then FOnObjectInserted(self,irCreate); if selected then FAnySelected := true; if RecordUndo then RecordInsertUndo(f); Updated := True; end; Function TPCDrawing.Vertex(LayerNbr:INteger;x,y:Double;Selected: Boolean):TFigHandle; var f : TFigure; Begin if (layerNbr<0) or (layerNbr>layers.count) then LayerNbr := 0; f := TVertex.create(x,y,LongInt(Layers[LayerNbr]),mydsNormal,self); figures.add(f); if selected then f.Select; result := f.Handle; if assigned(FOnObjectInserted) then FOnObjectInserted(self,irCreate); if selected then FAnySelected := true; Updated := True; End; Function TPCDrawing.PolyLine(LayerNbr:integer;var points: TDoublePoint; pCount,w,s,c: integer; Row:integer; brs,brc: integer; Closed,Selected: Boolean):TFigHandle; var p:TDoublePointArr; a: Integer; x,y: Double; begin SetLength(p,pCount); for a := 0 to pCount-1 do begin x := pDouble(pAnsiChar(@points)+(a)*16+0)^; y := pDouble(pAnsiChar(@points)+(a)*16+8)^; //x := pDouble(pChar(@points)+(a)*16+0)^; //y := pDouble(pChar(@points)+(a)*16+8)^; p[a] := DoublePoint(x,y); end; result := PolyLine(LayerNbr,p,w,s,c,Row,brs,brc,Closed,Selected); end; Function TPCDrawing.PolyLine(LayerNbr: integer; points: TDoublePointArr; w, s, c: integer; Row: integer; brs, brc: integer; Closed, Selected: Boolean): TFigHandle; var f : TFigure; begin if Length(points) < 2 then begin result := -1; exit; end; if (layerNbr<0) or (layerNbr>layers.count) then LayerNbr := 0; f := TPolyLine.create(points, w, s, c, brs, brc, row, Closed, LongInt(Layers[LayerNbr]), mydsNormal, self); figures.add(f); if selected then f.Select; result := f.Handle; if assigned(FOnObjectInserted) then FOnObjectInserted(self,irCreate); if selected then FAnySelected := true; Updated := True; end; //** For backwards compatibilty Function TPCDrawing.Polygon(LayerNbr:integer; points:TDoublePointArr;w,s,c,brs,brc:integer;Selected: Boolean):TFigHandle; begin result := PolyLine(LayerNbr,points,w,s,c,0,brs,brc,true,selected); end; Function TPCDrawing.Ellipse(LayerNbr:Integer;cx,cy,lenax,lenbx,angle:Double;w,s,c,brs,brc:integer;Selected: Boolean):TFigHandle; var f: TFigure; begin if (layerNbr<0) or (layerNbr>layers.count) then LayerNbr := 0; f := TEllipse.create(cx,cy,lenax,lenbx,angle,w,s,c,brs,brc,LongInt(Layers[LayerNbr]),mydsNormal,self); figures.add(f); if selected then f.Select; result := f.Handle; if assigned(FOnObjectInserted) then FOnObjectInserted(self,irCreate); if selected then FAnySelected := true; Updated := True; end; Function TPCDrawing.Circle(LayerNbr:Integer;cx,cy,radius:Double;w,s,c,brs,brc:integer;Selected: Boolean):TFigHandle; var f: TFigure; begin if (layerNbr<0) or (layerNbr>layers.count) then LayerNbr := 0; f := TCircle.create(cx,cy,radius,w,s,c,brs,brc,LongInt(Layers[LayerNbr]),mydsNormal,self); figures.add(f); if selected then f.Select; result := f.Handle; if assigned(FOnObjectInserted) then FOnObjectInserted(self,irCreate); if selected then FAnySelected := true; Updated := True; end; Function TPCDrawing.DrawCircle(LayerNbr:Integer;cx,cy,radius:Double;w,s,c,brs,brc:integer;Selected: Boolean):TFigHandle; begin // Used for VBExport ... Circle is already reserved in VB result := Circle(LayerNbr,cx,cy,radius,w,s,c,brs,brc,Selected); end; Function TPCDrawing.Arc(LayerNbr:Integer;cx,cy,radius,a1,a2: Double; w,s,c,brs,brc,ArcStyle:Integer;Selected: Boolean):TFigHandle; var f: TFigure; begin if (layerNbr<0) or (layerNbr>layers.count) then LayerNbr := 0; f := TArc.create(cx,cy,radius,a1,a2,w,s,c,brs,brc,arcStyle,LongInt(Layers[LayerNbr]),mydsNormal,self); figures.add(f); if selected then f.Select; result := f.Handle; if assigned(FOnObjectInserted) then FOnObjectInserted(self,irCreate); if selected then FAnySelected := true; Updated := True; end; Function TPCDrawing.ElpArc(LayerNbr:Integer; cx,cy,lenax,lenbx,angle,a1,a2:Double; w,s,c,brs,brc,ArcStyle:Integer;selected: boolean):TFigHandle; var f: TFigure; begin if (layerNbr<0) or (layerNbr>layers.count) then LayerNbr := 0; f := TElpArc.create(cx,cy,lenax,lenbx,a1,a2,angle,w,s,c,brs,brc,arcStyle,LongInt(Layers[LayerNbr]),mydsNormal,self); figures.add(f); if selected then f.Select; result := f.Handle; if assigned(FOnObjectInserted) then FOnObjectInserted(self,irCreate); if selected then FAnySelected := true; Updated := True; end; Function TPCDrawing.Rectangle(LayerNbr:Integer;x1,y1,x2,y2:Double;w,s,c,brs,brc:integer;Selected: Boolean):TFigHandle; var f: TFigure; begin if (layerNbr<0) or (layerNbr>layers.count) then LayerNbr := 0; f := DrawObjects.TRectangle.create(x1, y1, x2,y2,w,s,c,brs,brc,LongInt(Layers[LayerNbr]),mydsNormal,self); figures.add(f); if selected then f.Select; result := f.Handle; if assigned(FOnObjectInserted) then FOnObjectInserted(self,irCreate); if selected then FAnySelected := true; Updated := True; end; Function TPCDrawing.InsertBitmap(LayerNbr:Integer;x,y:Double; fName: string; Transparent,Selected: Boolean; JPEGBounds: Boolean = False):TFigHandle; var f: TBMPObject; begin GImageScale := 0;// Tolik 30/01/2020 if (layerNbr<0) or (layerNbr>layers.count) then LayerNbr := 0; f := TBMPObject.create(x,y,fName,LongInt(Layers[LayerNbr]),mydsNormal,self, JPEGBounds); // Tolik 09/08/2019 -- если вдруг пустой файл if ((f.Picture.Width = 0) or (f.Picture.Height = 0)) then begin f.Free; Result := -1; exit; end; f.Transparent := TransParent; figures.add(f); if selected then f.Select; result := f.Handle; if assigned(FOnObjectInserted) then FOnObjectInserted(self,irCreate); if selected then FAnySelected := true; try if GImageScale <> 0 then begin f.Scale(GImageScale, GImageScale, f.ap1); GImageScale := 0; end; Except on E: Exception do GImageScale := 0; end; refresh; Updated := True; end; Function TPCDrawing.InsertBitmapHandle(LayerNbr:Integer; x,y:Double; xBitmap:TBitmap;transparent,selected: boolean):TFigHandle; var f: TBMPObject; begin if (layerNbr<0) or (layerNbr>layers.count) then LayerNbr := 0; f := TBMPObject.createEx(x,y,xBitmap,LongInt(Layers[LayerNbr]),mydsNormal,self); f.Transparent := TransParent; figures.add(f); if selected then f.Select; result := f.Handle; if assigned(FOnObjectInserted) then FOnObjectInserted(self,irCreate); if selected then FAnySelected := true; refresh; Updated := True; end; Function TPCDrawing.TextOut(LayerNbr:Integer; x1,y1,angle,height,ratio: double; atext,aFontName: string;FontCharset:Byte;Color: Integer; Selected: Boolean):TFigHandle; var TextFig: TText; begin if (layerNbr<0) or (layerNbr>layers.count) then LayerNbr := 0; TextFig := TText.create(x1, y1,Height, ratio, atext,aFontName,FontCharset,Color, LongInt(Layers[LayerNbr]),mydsNormal,self); TextFig.angle := Angle; figures.add(TextFig); if selected then TextFig.Select; result := TextFig.Handle; if assigned(FOnObjectInserted) then FOnObjectInserted(self,irCreate); if selected then FAnySelected := true; Updated := True; end; Procedure TPCDrawing.SyncEnv; Begin inherited; End; (* Procedure TPCDrawing.RunMacroByFileName(MacroName:String); var macro: TStringList; Begin SetInterfaceHandle; macro := TStringlist.Create; if fileexists(MacroName) then begin Macro.LoadFromFile(Macroname); MacroEngine.script := Macro; MacroEngine.Compile('Self',MacroEngine); MacroEngine.Run; Updated := True; end; End; Procedure TPCDrawing.RunMacro(Macro:TStringlist); Begin SetInterfaceHandle; MacroEngine.script := Macro; MacroEngine.Compile('Self',MacroEngine); MacroEngine.Run; Updated := True; End; Procedure TPCDrawing.RunMacroText(Macro:String); var list:Tstringlist; begin SetInterfaceHandle; list := TStringList.Create; list.text := Macro; MacroEngine.script := list; MacroEngine.Compile('Self',MacroEngine); MacroEngine.Run; Updated := True; List.Free; end; Procedure TPCDrawing.AddPSCLConstant(ConstName:String;Value:Variant); begin AddConst(ConstName,Value); end; Procedure TPCDrawing.AddPSCLProcedure(ProcName:String;ProcAddr:TProcType;const Params:array of byte); begin AddProc(ProcName,ProcAddr,params); end; Procedure TPCDrawing.AddPSCLFunction(ProcName:String;ProcAddr:TProcType;const Params:array of byte); begin AddFun(ProcName,ProcAddr,params); end; *) Function TPCDrawing.InsertWMF(LayerNbr:Integer;x,y: Double; fName: string;Selected: Boolean):TFigHandle; var f: TWMFObject; begin result := 0; if (layerNbr<0) or (layerNbr>layers.count) then LayerNbr := 0; f := TWMFObject.create(x,y,fName,LongInt(Layers[LayerNbr]),mydsNormal,self); figures.add(f); if selected then f.Select; result := f.Handle; if assigned(FOnObjectInserted) then FOnObjectInserted(self,irCreate); if selected then FAnySelected := true; if autorefresh then refresh; Updated := True; end; Function TPCDrawing.InsertMetafile(LayerNbr:Integer; x,y:Double; mf: TMetafile;selected: boolean): TFigHandle; var f: TWMFObject; begin result := 0; if (layerNbr<0) or (layerNbr>layers.count) then LayerNbr := 0; f := TWMFObject.createEx(x,y,mf,LongInt(Layers[LayerNbr]),mydsNormal,self); figures.add(f); if selected then f.Select; result := f.Handle; if assigned(FOnObjectInserted) then FOnObjectInserted(self,irCreate); if selected then FAnySelected := true; if autorefresh then refresh; Updated := True; end; Function TPCDrawing.ImportWMF(LayerNbr: integer; fName: string;Selected: Boolean):TFigHandle; var mf: TMetafile; x,y: Double; begin result := 0; if (layerNbr<0) or (layerNbr>layers.count) then LayerNbr := 0; mf := TMetafile.create; mf.LoadFromFile(fName); x := -1;y := -1; result := ImportMetafile(LayerNbr,x,y,mf,Selected); mf.Free; Updated := True; if Result = -1 then GisUserDimLine := false; end; var WmfPoints: TDOublePointArr; wmfPoCount: Integer; Function TPCDrawing.ImportMetafile(LayerNbr:Integer;x,y:Double; mf: TMetafile;Selected: Boolean):TFigHandle; var ptr: Pointer; mfwidthmm,mfwidth: extended; EnhMetaHeader: PEnhMetaHeader; mmRect,mfRect : TRect; selrect: TDoubleRect; res: integer; begin BufferObj := Self; WmfLayer := LayerNbr; pw := 1; pc := clBlack; ps := ord(psClear); bs:= ord(bsClear); bc := clWhite; GetMem(EnhMetaHeader,100); mfdpmm := mf.Inch; GetEnhMetaFileHeader(mf.handle,100,EnhMetaHeader); mfRect := EnhMetaHeader.rclBounds; mmRect := EnhMetaHeader.rclFrame; mfwidthmm := (abs(mmRect.left/100 - mmRect.right/100)); mfwidth := (abs(mfRect.left - mfRect.right)); mfdpmm := mfwidth/mfwidthmm; wmfx := WorkWidth; wmfy := WorkHeight; wmfVz := VerticalZero; wmfHz := HorizontalZero; wmfMapMode:= MM_TEXT; wmfwpx := 1; wmfwex := 1; wmfwpy := 1; wmfwey := 1; DeselectAll(0); RecCount := 0; wmfLogCnt := 0; SaveCnt := 0; xForm.eM11 := 1; xForm.eM22 := 1; xForm.eM12 := 0; xForm.eM21 := 0; xForm.eDx := 0; xForm.eDy := 0; SetLength(wmfPoints,0); wmfPoCount := 0; EnumEnhMetafile(0,mf.handle,@ProcessMFRecord,ptr,Rect(0,0,0,0)); result := GroupSelection; FreeMem(EnhMetaHeader,100); // Tolik 03/05/2019 -- if result = 0 then exit; TFigure(result).DiagonalScale := True; SelRect := TFigure(result).GetBoundrect; wmfx := (SelRect.left+SelRect.right) / 2; wmfy := (SelRect.top+SelRect.bottom) / 2; if (x = -1) and (y = -1) then //center begin wmfx := ((SelRect.left+SelRect.Right)/ 2); wmfx := (WorkWidth /2) - wmfx; wmfy := ((SelRect.Top+SelRect.Bottom)/ 2); wmfy := (WorkHeight /2) - wmfy; end else begin wmfx := x - SelRect.left; wmfy := y - SelRect.Top; end; MoveSelection(wmfx,wmfy); FAnySelected := true; refresh; Updated := True; if assigned(FOnObjectInserted) then FOnObjectInserted(self,irCreate); end; Function TPCDrawing.SnapToFigures(var x,y: double):Boolean; var Figure:TFigure; i,dx,dy : integer; R: TDoubleRect; begin result := false; For i := 0 to Figures.Count-1 do begin Figure := Tfigure(Figures[i]); if figure.isVisible then begin R := Figure.GetBoundRect; r := DoubleRect(r.left - 10,r.top-10,r.right+10,r.Bottom+10); if (PointInRect(DoublePoint(x,y),r)) and (not result) then begin result := Figure.SnapPoints(x,y,DotsPerMil); if (not result) and assigned (FSnapToFigure) then begin result := FSnapToFigure(Self,Figure,x,y); if result then exit; end; end; end; end; end; Procedure TPCDrawing.setPenColor(value: TColor); Begin if Selection.Count > 0 then Modifyselection(mmPenColor,value) else begin fDefPenColor := value; if assigned(evPenColor) and not (csDesigning in ComponentState) and not (csReading in ComponentState)then begin evPenColor.RaiseEvent(fDefPenColor,'',0); end; end; Updated := True; SyncEnv; end; Procedure TPCDrawing.setBrushColor(value: TColor); Begin if Selection.Count > 0 then Modifyselection(mmBrushColor,value) else begin fDefBrsColor := value; if assigned(evBrushColor) and not (csDesigning in ComponentState) and not (csReading in ComponentState)then begin evBrushColor.RaiseEvent(fDefBrsColor,'',0); end; end; Updated := True; SyncEnv; end; Procedure TPCDrawing.setPenWidth(value: integer); var pw: Byte; Begin if Selection.Count > 0 then Modifyselection(mmPenWidth,value) else begin fDefPenWidth := value; if assigned(evPenWidth) and not (csDesigning in ComponentState) and not (csReading in ComponentState) then begin pw := value -1; evPenWidth.RaiseEvent(pw,'',0); end; end; Updated := True; SyncEnv; end; Procedure TPCDrawing.setPenStyle(value: TPenStyle); Begin if Selection.Count > 0 then Modifyselection(mmPenStyle,ord(value)) else begin fDefPenStyle := value; if assigned(evPenStyle) and not (csDesigning in ComponentState) and not (csReading in ComponentState)then evPenStyle.RaiseEvent(ord(fDefPenStyle),'',0); end; Updated := True; SyncEnv; end; Procedure TPCDrawing.setBrushStyle(value: TBrushStyle); Begin if Selection.Count > 0 then Modifyselection(mmBrushStyle,ord(value)) else begin fDefBrsStyle := value; if assigned(evBrushStyle) and not (csDesigning in ComponentState) and not (csReading in ComponentState)then evBrushStyle.RaiseEvent(ord(fDefBrsStyle),'',0); end; Updated := True; SyncEnv; end; Procedure TPCDrawing.setRowStyle(value: TRowStyle); Begin if Selection.Count > 0 then Modifyselection(mmRowStyle,ord(value)) else begin fDefRowStyle := value; if assigned(evPenStyle) and not (csDesigning in ComponentState) and not (csReading in ComponentState)then evRowStyle.RaiseEvent(ord(fDefRowStyle),'',0); end; Updated := True; SyncEnv; end; Procedure TPCDrawing.setTextHeight(value: Double); begin if Selection.Count > 0 then begin ModifyTextandFont(mmFontSize,Value,'',[],False); fDefTextheight := value; end else begin fDefTextheight := value; end; Updated := True; end; Procedure TPCDrawing.setTextRatio(value: Double); begin fDefTextratio := value; Updated := True; end; Procedure TPCDrawing.SetPLineClosed(value:Boolean); begin if value then CloseSelectedPolyLine else OpenSelectedPolyLine; end; Procedure TPCDrawing.SetArcStyle(value:TArcStyle); begin ArrangeArcStyleOfSelection(value); end; Function TPCDrawing.GetSlcPenStyle : Integer; var a: integer; MultiStyle,Based : Boolean; Begin result := ord(FDefPenStyle); Based := False; for a := 0 to Selection.Count -1 do Begin if TFigure(Selection[a]).Style <> -1 then begin if not Based then begin result := TFigure(Selection[a]).Style; Based := True; end else begin if TFigure(Selection[a]).Style <> result then MultiStyle := true; end; end; end; if MultiStyle then result := ord(FDefPenStyle); End; Function TPCDrawing.GetSlcPenWidth : Integer; var a: integer; MultiStyle,Based : Boolean; Begin result := FDefPenWidth; MultiStyle := False; Based := False; for a := 0 to Selection.Count -1 do Begin if TFigure(Selection[a]).Width <> -1 then begin if not Based then begin result := TFigure(Selection[a]).Width; Based := True; end else begin if TFigure(Selection[a]).Width <> result then MultiStyle := true; end; end; end; if MultiStyle then result := FDefPenWidth; End; Function TPCDrawing.GetSlcPenColor : Integer; var a: integer; MultiStyle,Based : Boolean; Begin result := FDefPenColor; MultiStyle := False; Based := False; for a := 0 to Selection.Count -1 do Begin if TFigure(Selection[a]).Color <> -1 then begin if not Based then begin result := TFigure(Selection[a]).Color; Based := True; end else begin if TFigure(Selection[a]).Color <> result then MultiStyle := true; end; end; end; if MultiStyle then result := FDefPenColor; End; Function TPCDrawing.GetSlcRowStyle : Integer; var a: integer; MultiStyle,Based : Boolean; Begin result := ord(FDefRowStyle); MultiStyle := False; Based := False; for a := 0 to Selection.Count -1 do Begin if TFigure(Selection[a]).RowStyle <> -1 then begin if not Based then begin result := TFigure(Selection[a]).RowStyle; Based := True; end else begin if TFigure(Selection[a]).RowStyle <> result then MultiStyle := true; end; end; end; if MultiStyle then result := ord(FDefRowStyle); End; Function TPCDrawing.GetSlcBrushStyle : Integer; var a: integer; MultiStyle,Based : Boolean; Begin result := ord(FDefBrsStyle); MultiStyle := False; Based := False; for a := 0 to Selection.Count -1 do Begin if TFigure(Selection[a]).Brs <> -1 then begin if not Based then begin result := TFigure(Selection[a]).Brs; Based := True; end else begin if TFigure(Selection[a]).Brs <> result then MultiStyle := true; end; end; end; if MultiStyle then result := ord(FDefBrsStyle); End; Function TPCDrawing.GetSlcBrushColor : Integer; var a: integer; MultiStyle,Based : Boolean; Begin result := FDefBrsColor; MultiStyle := False; Based := False; for a := 0 to Selection.Count -1 do Begin if TFigure(Selection[a]).Brc <> -1 then begin if not Based then begin result := TFigure(Selection[a]).Brc; Based := True; end else begin if TFigure(Selection[a]).Brc <> result then MultiStyle := true; end; end; end; if MultiStyle then result := FDefBrsColor; End; Function TPCDrawing.GetSlcFontSize :Double; var a: integer; MultiStyle,Based : Boolean; Begin result := fDefTextHeight; MultiStyle := False; Based := False; for a := 0 to Selection.Count -1 do Begin if TFigure(Selection[a]) is TText then begin if not Based then begin result := (TFigure(Selection[a]) as TText).Height; Based := True; end else begin if (TFigure(Selection[a]) as TText).Height <> result then MultiStyle := true; end; end; if TFigure(Selection[a]) is TTextPanel then begin if not Based then begin result := (TFigure(Selection[a]) as TTextPanel).Height; Based := True; end else begin if (TFigure(Selection[a]) as TTextPanel).Height <> result then MultiStyle := true; end; end; end; if MultiStyle then result := fDefTextHeight; End; Function TPCDrawing.GetSlcPolylineClosed: Boolean; var a: integer; MultiStyle,Based : Boolean; Begin result := fDefPLineClosed; MultiStyle := False; Based := False; for a := 0 to Selection.Count -1 do Begin if TFigure(Selection[a]) is TPolyLine then begin if not Based then begin result := (TFigure(Selection[a]) as TPolyLine).Closed; Based := True; end else begin if (TFigure(Selection[a]) as TPolyLine).Closed <> result then MultiStyle := true; end; end; end; if MultiStyle then result := fDefPLineClosed; End; Function TPCDrawing.GetSlcImageTransparent: Boolean; var a: integer; MultiStyle,Based : Boolean; found:Boolean; Begin result := False; MultiStyle := False; Based := False; for a := 0 to Selection.Count -1 do Begin if TFigure(Selection[a]) is TBmpObject then begin if not Based then begin result := (TFigure(Selection[a]) as TBmpObject).Transparent; Based := True; Found := True; end else begin if (TFigure(Selection[a]) as TBmpObject).Transparent <> result then MultiStyle := true; end; end; end; if MultiStyle then result := False; End; Function TPCDrawing.GetSlcImageClipped: Boolean; var a: integer; MultiStyle,Based : Boolean; Begin result := False; MultiStyle := False; Based := False; for a := 0 to Selection.Count -1 do Begin if TFigure(Selection[a]) is TBmpObject then begin if not Based then begin result := ((TFigure(Selection[a]) as TBmpObject).ClipFigure <> nil); Based := True; end else begin if ((TFigure(Selection[a]) as TBmpObject).ClipFigure <> nil) <> result then MultiStyle := true; end; end; end; if MultiStyle then result := False; End; Function TPCDrawing.GetSlcLineBounded: Boolean; var a: integer; MultiStyle,Based,res : Boolean; f:Tfigure; Begin result := False; MultiStyle := False; Based := False; for a := 0 to Selection.Count -1 do Begin f := TFigure(Selection[a]); if (f is DrawObjects.TLine) or (f is TPolyline) then begin if f is DrawObjects.Tline then res := ((f as DrawObjects.Tline).JoinFigure1 <> nil) or ((f as DrawObjects.Tline).JoinFigure2 <> nil) else if f is TPolyLine then res := ((f as TPolyLine).JoinFigure1 <> nil) or ((f as TPolyLine).JoinFigure2 <> nil); if not Based then begin result := res; Based := True; end else begin if res <> result then MultiStyle := true; end; end; end; if MultiStyle then result := False; End; Function TPCDrawing.GetSlcArcStyle:TArcStyle; var a: integer; MultiStyle,Based : Boolean; Begin result := fDefArcStyle; MultiStyle := False; Based := False; for a := 0 to Selection.Count -1 do Begin if TFigure(Selection[a]) is TArc then begin if not Based then begin result := (TFigure(Selection[a]) as Tarc).ArcStyle; Based := True; end else begin if (TFigure(Selection[a]) as Tarc).ArcStyle <> result then MultiStyle := true; end; end; end; if MultiStyle then result := fDefArcStyle; End; Function TPCDrawing.GetSlcFontName:String; begin result := GetSlcFont.Name; end; Function TPCDrawing.GetSlcFontBold:Boolean; begin result := (fsBold in GetSlcFont.Style); end; Function TPCDrawing.GetSlcFontItalic:Boolean; begin result := (fsItalic in GetSlcFont.Style); end; Function TPCDrawing.GetSlcFontUnderline:Boolean; begin result := (fsUnderline in GetSlcFont.Style); end; Function TPCDrawing.GetSlcFontStrike:Boolean; begin result := (fsStrikeOut in GetSlcFont.Style); end; Function TPCDrawing.GetSlcFontCharset:Integer; begin result := GetSlcFont.Charset; end; Function TPCDrawing.GetSlcFontColor:TColor; begin result := GetSlcFont.Color; end; Function TPCDrawing.GetSlcFont : TFont; var a: integer; MultiStyle,Based : Boolean; Begin result := Font; MultiStyle := False; Based := False; for a := 0 to Selection.Count -1 do Begin if TFigure(Selection[a]) is TText then begin if not Based then begin result := (TFigure(Selection[a]) as TText).Font; Based := True; end else begin if (TFigure(Selection[a]) as TText).Font <> result then MultiStyle := true; end; end; if TFigure(Selection[a]) is TTextPanel then begin if not Based then begin result := (TFigure(Selection[a]) as TTextPanel).Font; Based := True; end else begin if (TFigure(Selection[a]) as TTextPanel).Font <> result then MultiStyle := true; end; end; end; if MultiStyle then result := Self.Font; End; Function TPCDrawing.GetSelectedHandle(index:Integer):TFigHandle; begin result := 0; if (index > -1) and (index < Selection.Count) then result := TFigHandle(Selection[index]); end; Function TPCDrawing.GetSelectionHandles(var Handles: Array of TFigHandle): Integer; var a: integer; begin for a := 0 to Selection.Count -1 do Begin Handles[a] := TFigure(Selection[a]).Handle; end; result := Selection.Count; end; Procedure TPCDrawing.SetAutoSelect(value: Boolean); Begin FAutoSelect := value; End; Function TPCDrawing.GetPenPatCount:Integer; begin result := FPenPatList.Count; end; Function TPCDrawing.GetPenPattern(Index:Integer):TPattern; begin result := nil; if (Index > FPenPatList.Count-1) or (Index < 0) then exit; Result := TPattern(FPenpatList[Index]); end; Procedure TPCDrawing.NewPattern(pat:TPattern); begin FPenPatList.Add(Pat); end; Procedure TPCDrawing.SetRulerMode(Value:TRulerMode); begin FRulerMode := Value; //if Value = rmWorld then begin //if RulerSystem = rsWhitworth then RulerSystem := rsMetric; //end; SetRulerValues(FMapScale,ord(FRulerMode)); evRulerMode.RaiseEvent(ord(Value)); end; Function TPCDrawing.BlockAsMetafile(bPath: String):Integer; begin result := BlockAsWmf(bpath).Handle; end; Function TPCDrawing.BlockAsWmf(bPath: String):TMetafile; var xStream: Tstream; sign:string; a: integer; xByte: Byte; FigGrp: TFigureGrp; mf : TMetafile; mc : TMetafileCanvas; r: TDoubleRect; w,h: Double; dx,dy,x1,y1,x2,y2,t: Double; Begin result := nil; try xStream := TFileStream.Create(bPath,fmOpenRead or fmShareDenyNone); except exit; end; sign := ''; // Tolik 05/04/2019 -- for a := 1 to 6 do begin xStream.Read(xByte,1); // Tolik 05/04/2019 -- //sign := sign + chr(xByte); sign := sign + Ansichar(xByte); // end; FigGrp := nil; if Sign = 'TBlock' then begin xStream.Position := 0; FigGrp := TFigureGrp(TFigure.CreateFromStream(xStream,-1,mydsNormal,nil)); xStream.free; xStream := nil; end; // === if assigned(xStream) then xStream.Free; //if FigGrp = nil then // exit; // // blkVz := FigGrp.VertZero; // blkHz := FigGrp.HorzZero; // // dcDpm := DotsPerMilOrig; // mf := TMetafile.Create; // mf.Width := 100;; // mf.Height := 100; // mc := TMetafileCanvas.Create(mf,0); // SetEngine(mc,blkConvertXY,prDeConvertXY,blkConvertDim,prDeConvertDim,false,nil); // FigGrp.Draw(Dengine,false); // FigGrp.DrawDimLines(Dengine,false); // // mc.Free; // mf.Free; // // r := FigGrp.GetBoundRect; // w := abs(r.right-r.Left); // h := abs(r.top-r.bottom); // // mf := TMetafile.Create; // mf.Width := Round(w * dcDpm)+1; // mf.Height := round(h * dcDpm)+1; // mc := TMetafileCanvas.Create(mf,0); // SetEngine(mc,blkConvertXY,prDeConvertXY,blkConvertDim,prDeConvertDim,false,nil); // // if r.top < r.bottom then blkDisty := r.top else blkDisty := r.bottom; // if r.left < r.right then blkDistx := r.left else blkDistx := r.right; // if r.top > r.bottom then blkTopy := r.top else blkTopy := r.bottom; // if r.left > r.right then blkTopx := r.left else blkTopx := r.right; // // blkH := mf.Height; blkW := mf.Width; // FigGrp.Draw(Dengine,false); // FigGrp.DrawDimlines(Dengine,false); // mc.Free; // result := mf; Result := BlockObjAsWmf(FigGrp); //FigGrp.InFigures.Clear; FigGrp.Free; end; Function TPCDrawing.BlockObjAsWmf(ABlock: TFigureGrp):TMetafile; var FigGrp: TFigureGrp; mf : TMetafile; mc : TMetafileCanvas; r: TDoubleRect; w,h: Double; dx,dy,x1,y1,x2,y2,t: Double; Begin result := nil; FigGrp := ABlock; if FigGrp = nil then exit; blkVz := FigGrp.VertZero; blkHz := FigGrp.HorzZero; dcDpm := DotsPerMilOrig; mf := TMetafile.Create; mf.Width := 100;; mf.Height := 100; mc := TMetafileCanvas.Create(mf,0); SetEngine(mc,blkConvertXY,prDeConvertXY,blkConvertDim,prDeConvertDim,false,nil); FigGrp.Draw(Dengine,false); FigGrp.DrawDimLines(Dengine,false); mc.Free; mf.Free; r := FigGrp.GetBoundRect; w := abs(r.right-r.Left); h := abs(r.top-r.bottom); mf := TMetafile.Create; mf.Width := Round(w * dcDpm)+1; mf.Height := round(h * dcDpm)+1; mc := TMetafileCanvas.Create(mf,0); ResetRegions; SetEngine(mc,blkConvertXY,prDeConvertXY,blkConvertDim,prDeConvertDim,false,nil); if r.top < r.bottom then blkDisty := r.top else blkDisty := r.bottom; if r.left < r.right then blkDistx := r.left else blkDistx := r.right; if r.top > r.bottom then blkTopy := r.top else blkTopy := r.bottom; if r.left > r.right then blkTopx := r.left else blkTopx := r.right; blkH := mf.Height; blkW := mf.Width; FigGrp.Draw(Dengine,false); FigGrp.DrawDimlines(Dengine,false); mc.Free; ResetRegions; result := mf; Refresh; end; ///////////////////////////////////////////////////// Function ProcessMFRecord(DC:HDC; HT:PHandleTable; rec:PEnhMetaRecord; count: integer; param: pointer): integer; var cx,cy,rad,lena,lenb,a1,a2: Double; x1,y1,x2,y2,xx,yy: Double; pcnt: integer; arcs: Integer; nbrPoints,a,i,b,k,brush,pen: integer; nbrobjects : integer; pl: TPolyline; points: TDoublePointArr; expoints: TDOublePointArr; Segment: TPLSegment; wc: WideChar; Closed: Boolean; xText: String; ap1,ap2: TDoublePoint; RecPolyGon: PEMRPOLYGON; RecPolyGon16: PEMRPOLYGON16; RecMoveToEx: PEMRMOVETOEX; RecLineTo: PEMRLINETO; RecArc: PEMRARC; RecEllipse: PEMRELLIPSE; RecRectangle: PEMRRECTANGLE; RecPolyline: PEMRPOLYLINE; RecPolyLine16:PEMRPOLYLINE; RecPolyPGon:PEMRPolyPolygon; RecPolyPLine:PEMRPolyPolyLine; RecPolyPGon16:PEMRPolyPolygon16; RecPolyPLine16:PEMRPolyPolyLine16; RecPolyBezier16: PEMRPOLYBEZIER16; RecBrush: PEMRCREATEBRUSHINDIRECT; RecPen: PEMRCreatePen; RecExtPen: PEMRExtCreatePen; RecMBrush: PEMRCREATEMONOBRUSH; RecmapMode : PEMRSetMapMode; RecPortExt : PEMRSETVIEWPORTEXTEX; RecPortOrg : PEMRSETVIEWPORTORGEX; RecSelect: PEMRSELECTOBJECT; RecText:PEMRExtTextOut; RecFont: PEMRExtCreateFontIndirect; Recrestore : PEMRRestoreDC; RecModifyWT: PEMRModifyWorldTransform; RecSetWT: PEMRSetWorldTransform; mForm: TXForm; RDC: TSavedDc; dcIdx: Integer; mr: Array [0..8] of Double; ml: Array [0..8] of Double; ms: Array [0..8] of Double; sz: TSize; Function ConvertX(pointx:double):double; var res,dp: double; hz: THorzZero; begin dp := mfdpmm; hz := vzLeft; pointx := pointx * xForm.eM11 + xform.eDx; if wmfmapMode = MM_TEXT then begin res := (pointx / mfdpmm); end else if wmfmapMode = MM_ISOTROPIC then begin dp := abs(wmfwpx/wmfwex); pointx := pointx*dp; if (wmfwpx*wmfwex) < 0 then hz := vzRight else hz := vzLeft; res := (pointx / mfdpmm); end else if wmfmapMode = MM_ANISOTROPIC then begin dp := abs(wmfwpx/wmfwex); pointx := pointx*dp; if (wmfwpx*wmfwex) < 0 then hz := vzRight else hz := vzLeft; res := (pointx / mfdpmm); end else if wmfmapMode = MM_HIMETRIC then begin pointx := pointx/100; res := (pointx / 1); end else if wmfmapMode = MM_LOMETRIC then begin pointx := pointx/10; res := (pointx / 1); end else if wmfmapMode = MM_HIENGLISH then begin pointx := (pointx/1000)*25.4; res := (pointx / 1); end else if wmfmapMode = MM_LOENGLISH then begin pointx := (pointx/100)*25.4; res := (pointx / 1); end else if wmfmapMode = MM_TWIPS then begin pointx := (pointx/12); res := (pointx / mfdpmm); end; if wmfHz <> hz then res := wmfx - res; result := res; end; Function ConvertY(pointy:double):double; var res: double; vz: TVertZero; dp: Double; begin pointy := pointy * xForm.eM22 + xform.eDy; if wmfmapMode = MM_TEXT then begin vz := vzTop; res := (pointy / mfdpmm); end else if wmfmapMode = MM_ISOTROPIC then begin dp := abs(wmfwpy/wmfwey); pointy := pointy*dp; if (wmfwpy*wmfwey) < 0 then vz := vzBottom else vz := vzTop; res := (pointy / mfdpmm); end else if wmfmapMode = MM_ANISOTROPIC then begin dp := abs(wmfwpy/wmfwey); pointy := pointy*dp; if (wmfwpy*wmfwey) < 0 then vz := vzBottom else vz := vzTop; res := (pointy / mfdpmm); end else if wmfmapMode = MM_HIMETRIC then begin vz := vzBottom; pointy := pointy/100; end else if wmfmapMode = MM_LOMETRIC then begin vz := vzBottom; pointy := pointy/10; res := (pointy / 1); end else if wmfmapMode = MM_HIENGLISH then begin vz := vzBottom; pointy := (pointy/1000)*25.4; res := (pointy / 1); end else if wmfmapMode = MM_LOENGLISH then begin vz := vzBottom; pointy := (pointy/100)*25.4; res := (pointy / 1); end else if wmfmapMode = MM_TWIPS then begin vz := vzBottom; pointy := (pointy/12); res := (pointy / mfdpmm); end else vz := vzBottom; if wmfVz <> vz then res := wmfy - res; result := res; end; Begin reccount := reccount + 1; Case rec.iType of EMR_SETVIEWPORTEXTEX: begin RecPortExt := PEMRSETVIEWPORTEXTEX(rec); cx := recPortExt.szlExtent.cx; cy := recPortExt.szlExtent.cy; wmfwpx := cx; wmfwpy := cy; end; EMR_SETWINDOWEXTEX: begin GetViewportExtEx(BufferObj.GetActiveCanvas.Handle,sz); RecPortExt := PEMRSETVIEWPORTEXTEX(rec); cx := recPortExt.szlExtent.cx; cy := recPortExt.szlExtent.cy; wmfwex := cx; wmfwey := cy; end; EMR_SETVIEWPORTORGEX: begin RecPortOrg := PEMRSETVIEWPORTORGEX(rec); cx := recPortOrg.ptlOrigin.x; cy := recPortOrg.ptlOrigin.y; end; EMR_SETWINDOWORGEX: begin RecPortOrg := PEMRSETVIEWPORTORGEX(rec); cx := recPortOrg.ptlOrigin.x; cy := recPortOrg.ptlOrigin.y; end; EMR_SETMAPMODE: begin RecMapMode := PEMRSETMAPMODE(rec); wmfMapMode := RecmapMode.iMode; end; EMR_MOVETOEX: Begin if wmfPoCount > 1 then begin BufferObj.PolyLine(wmfLayer,wmfPoints,pw,ps,pc,0,0,0,EQDP(wmfPoints[0],wmfPoints[wmfPoCount-1]),True); end; SetLength(wmfPoints,1); wmfPoCount := 1; RecMoveToEx := PEMRMOVETOEX(rec); MoveToX := Convertx(RecMoveToEx.ptl.x); MoveTOY := Converty(RecMoveToEx.ptl.y); wmfPoints[0] := DoublePoint(MoveToX,MoveTOY); End; EMR_LINETO: Begin RecLIneTo := PEMRLINETO(rec); XX := Convertx(RecLineTo.ptl.x); YY := Converty(RecLineTo.ptl.y); //BufferObj.Line(wmflayer,MoveToX,MoveToY,xx,yy,pw,ps,pc,0,True); MoveToX := XX; MoveToY := YY; wmfPoCount := wmfPoCount+1; SetLength(wmfPoints,wmfPoCount); wmfPoints[wmfPoCount-1] := DoublePoint(MoveToX,MoveTOY); End; EMR_ARC,EMR_PIE,EMR_CHORD: Begin RecArc := PEMRARC(rec); cx := Convertx((RecArc.rclBox.Right + RecArc.rclBox.Left) / 2); cy := Converty((RecArc.rclBox.Top + RecArc.rclBox.Bottom) / 2); rad := Convertx(RecArc.rclBox.Right) - ConvertX(RecArc.rclBox.Left); xx := ConvertX(RecArc.ptlStart.x); yy := ConvertY(RecArc.ptlStart.y); a1 := GetradOfLine(DoublePoint(cx,cy),DoublePOint(xx,yy)); xx := ConvertX(RecArc.ptlEnd.x); yy := ConvertY(RecArc.ptlEnd.y); a2 := GetradOfLine(DoublePoint(cx,cy),DoublePOint(xx,yy)); if rec.iType = EMR_ARC then arcs := ord(asOpen) else if rec.iType = EMR_PIE then arcs := ord(asPie) else if rec.iType = EMR_CHORD then arcs := ord(asChord); BufferObj.Arc(wmflayer,cx,cy,rad,a1,a2,pw,ps,pc,bs,bc,ord(arcs),True); End; EMR_ELLIPSE: Begin RecEllipse := PEMRELLIPSE(rec); cx := Convertx((RecEllipse.rclBox.left+RecEllipse.rclBox.right) / 2); cy := Converty((RecEllipse.rclBox.top+RecEllipse.rclBox.bottom) / 2); lena := abs(Convertx(RecEllipse.rclBox.right) - Convertx(RecEllipse.rclBox.left)) / 2; lenb := abs(Converty(RecEllipse.rclBox.bottom) - ConvertY(RecEllipse.rclBox.top)) / 2; BufferObj.Ellipse(wmflayer,cx,cy,lena,lenb,0,pw,ps,pc,bs,bc,True); End; EMR_RECTANGLE: Begin RecRectangle := PEMRRECTANGLE(rec); x1 := Convertx(RecRectangle.rclBox.right); y1 := Converty(RecRectangle.rclBox.top); x2 := Convertx(RecRectangle.rclBox.left); y2 := Converty(RecRectangle.rclBox.bottom); BufferObj.Rectangle(wmflayer,x1,y1,x2,y2,pw,ps,pc,bs,bc,True); End; EMR_POLYLINE,EMR_POLYGON: Begin RecPolyLine := PEMRPOLYLINE(rec); nbrPoints := RecPolyLine.cptl; Setlength(Points,nbrPoints); For a := 0 to nbrPoints-1 do begin Points[a].x := Convertx(RecPolyLine.aptl[a].y); Points[a].y := Converty(RecPolyLine.aptl[a].y); end; BufferObj.PolyLine(wmfLayer,points,pw,ps,pc,0,0,0,(rec.iType =EMR_POLYGON ),True); End; EMR_POLYBEZIER: Begin RecPolyLine := PEMRPOLYLINE(rec); nbrPoints := RecPolyLine.cptl; Setlength(Points,nbrPoints); Setlength(exPoints,nbrPoints); i := 0; k := 0; For a := 0 to nbrPoints-1 do begin if a mod 3 = 0 then begin exPoints[i].x := ConVertX(RecPolyLine.aptl[a].x); exPoints[i].y := ConVertX(RecPolyLine.aptl[a].y); i := i+1; end else begin Points[k].x := ConVertX(RecPolyLine.aptl[a].x); Points[k].y := ConVertY(RecPolyLine.aptl[a].y); k := k+1; end; end; Setlength(exPoints,i); wmfpl := TPolyLine(BufferObj.Polyline(wmfLayer,expoints,pw,ps,pc,0,bs,bc,false,True)); For a := 0 to i-2 do begin Segment := TPLSegment(wmfpl.Segments[a]); Segment.SType := sCurve; Segment.TangentKnot := True; Segment.CPoint1 := Points[a*2]; Segment.CPoint2 := Points[a*2+1]; end; End; EMR_POLYGON16,EMR_POLYLINE16: Begin recPolyGon16 := PEMRPOLYGON16(Rec); nbrPoints := recPolyGon16.cpts; Setlength(Points,nbrPoints); For a := 0 to nbrPoints-1 do begin Points[a].x := ConVertX(recPolyGon16.apts[a].x); Points[a].y := ConVertY(recPolyGon16.apts[a].y); end; BufferObj.Polyline(wmfLayer,points,pw,ps,pc,0,bs,bc,(rec.iType =EMR_POLYGON16 ),True); End; EMR_POLYBEZIERTO16: Begin recPolyBezier16 := PEMRPOLYBEZIER16(Rec); nbrPoints := recPolyBezier16.cpts; Setlength(Points,nbrPoints+1); Setlength(exPoints,nbrPoints+1); exPoints[0].x := MoveToX; exPoints[0].y := MoveToY; i := 1; k := 0; For a := 0 to nbrPoints-1 do begin if (a+1) mod 3 = 0 then begin exPoints[i].x := ConVertX(recPolyBezier16.apts[a].x); exPoints[i].y := ConVertX(recPolyBezier16.apts[a].y); i := i+1; end else begin Points[k].x := ConVertX(recPolyBezier16.apts[a].x); Points[k].y := ConVertY(recPolyBezier16.apts[a].y); k := k+1; end; end; Closed := false; if (exPoints[0].x = exPoints[i-1].x) and (exPoints[0].y = exPoints[i-1].y) then begin i := i-1; Closed := True; end; Setlength(exPoints,i); wmfpl := TPolyLine(BufferObj.Polyline(wmfLayer,expoints,pw,ps,pc,0,bs,bc,Closed,True)); For a := 0 to i-1 do begin Segment := TPLSegment(wmfpl.Segments[a]); Segment.SType := sCurve; Segment.TangentKnot := True; Segment.CPoint1 := Points[a*2]; Segment.CPoint2 := Points[a*2+1]; ap1 := wmfPl.ActualPoints[a+1]; if a = i-1 then begin ap2 := wmfPl.ActualPoints[1]; end else begin ap2 := wmfPl.ActualPoints[a+2]; end; if (Segment.CPoint1.x = ap1.x) and (Segment.CPoint1.y = ap1.y) and (Segment.CPoint2.x = ap2.x) and (Segment.CPoint2.y = ap2.y) then Segment.SType := sLine; end; End; EMR_POLYBEZIER16: Begin recPolyBezier16 := PEMRPOLYBEZIER16(Rec); nbrPoints := recPolyBezier16.cpts; Setlength(Points,nbrPoints); Setlength(exPoints,nbrPoints); i := 0; k := 0; For a := 0 to nbrPoints-1 do begin if a mod 3 = 0 then begin exPoints[i].x := ConVertX(recPolyBezier16.apts[a].x); exPoints[i].y := ConVertX(recPolyBezier16.apts[a].y); i := i+1; end else begin Points[k].x := ConVertX(recPolyBezier16.apts[a].x); Points[k].y := ConVertY(recPolyBezier16.apts[a].y); k := k+1; end; end; Closed := false; if (exPoints[0].x = exPoints[i-1].x) and (exPoints[0].y = exPoints[i-1].y) then begin i := i-1; Closed := True; end; Setlength(exPoints,i); wmfpl := TPolyLine(BufferObj.Polyline(wmfLayer,expoints,pw,ps,pc,0,bs,bc,Closed,True)); For a := 0 to i-1 do begin Segment := TPLSegment(wmfpl.Segments[a]); Segment.SType := sCurve; Segment.TangentKnot := True; Segment.CPoint1 := Points[a*2]; Segment.CPoint2 := Points[a*2+1]; ap1 := wmfPl.ActualPoints[a+1]; if a = i-1 then begin ap2 := wmfPl.ActualPoints[1]; end else begin ap2 := wmfPl.ActualPoints[a+2]; end; if (Segment.CPoint1.x = ap1.x) and (Segment.CPoint1.y = ap1.y) and (Segment.CPoint2.x = ap2.x) and (Segment.CPoint2.y = ap2.y) then Segment.SType := sLine; end; End; EMR_CLOSEFIGURE: begin if assigned(wmfpl) then wmfpl.Closed := True; end; EMR_POLYPOLYGON16,EMR_POLYPOLYLINE16: Begin RecPolyPGon16 := PEMRPOLYPOLYGON16(Rec); nbrobjects := RecPolyPGon16.nPolys; i := nbrobjects-1; For b := 0 to nbrObjects-1 do begin pcnt := RecPolyPGon16.aPolyCounts[b]; Setlength(Points,pcnt); For a := 0 to pcnt-1 do begin Points[a].x := Convertx(RecPolyPGon16.apts[i].x); Points[a].y := Converty(RecPolyPGon16.apts[i].y); inc(i); end; BufferObj.PolyLine(wmfLayer,points,pw,ps,pc,0,bs,bc,(rec.iType = EMR_POLYPOLYGON16),True); end; End; EMR_CREATEBRUSHINDIRECT: Begin WmfLogCnt := WmfLogCnt +1; RecBrush := PEMRCREATEBRUSHINDIRECT(rec); WmfPenBrush[WmfLogCnt].BrushLog.lbColor := RecBrush.lb.lbColor; WmfPenBrush[WmfLogCnt].BrushLog.lbStyle := RecBrush.lb.lbStyle; WmfPenBrush[WmfLogCnt].BrushLog.lbHatch := RecBrush.lb.lbHatch; WmfPenBrush[WmfLogCnt].index := RecBrush.ihBrush; WmfPenBrush[WmfLogCnt].isPen := false; End; EMR_SAVEDC: Begin SaveCnt := Savecnt+1; SavedDc[SaveCnt].Pen := ActivePen; SavedDc[SaveCnt].Brush := ActiveBrush; End; EMR_RESTOREDC: Begin Recrestore := PEMRRestoreDC(rec); dcIdx := SaveCnt+recrestore.iRelative+1; rDc := SavedDc[dcidx]; if rdc.Pen > 0 then begin pc := wmfPenBrush[rDc.Pen].PenLog.lopnColor; ps := wmfPenBrush[rDc.Pen].PenLog.lopnStyle; pw := wmfPenBrush[rDc.Pen].PenLog.lopnWidth.x; ActivePen := rDc.Pen; end; if rdc.brush > 0 then begin bc := wmfPenBrush[rDc.Brush].BrushLog.lbColor; bs := wmfPenBrush[rDc.Brush].BrushLog.lbStyle; Activebrush := rdc.brush; end; End; EMR_CREATEMONOBRUSH: Begin End; EMR_SELECTOBJECT: Begin RecSelect := PEMRSELECTOBJECT(rec); for a := WmfLogCnt downto 1 do begin if wmfPenBrush[a].index = RecSelect.ihObject then begin if wmfPenBrush[a].isPen then begin pc := wmfPenBrush[a].PenLog.lopnColor; ps := wmfPenBrush[a].PenLog.lopnStyle; pw := wmfPenBrush[a].PenLog.lopnWidth.x; ActivePen := a; end else begin bc := wmfPenBrush[a].BrushLog.lbColor; bs := wmfPenBrush[a].BrushLog.lbStyle; ActiveBrush := a; end; if rec.itype <> EMR_EOF then result := 1 else result := 0; exit; end; end; End; EMR_DELETEOBJECT: Begin End; EMR_CREATEPEN: Begin WmfLogCnt := WmfLogCnt +1; RecPen := PEMRCREATEPEN(rec); WmfPenBrush[WmfLogCnt].PenLog.lopnColor := recPen.lopn.lopnColor; WmfPenBrush[WmfLogCnt].PenLog.lopnStyle := recPen.lopn.lopnStyle; WmfPenBrush[WmfLogCnt].PenLog.lopnWidth.x := recPen.lopn.lopnWidth.x; if recPen.lopn.lopnWidth.x = 0 then WmfPenBrush[WmfLogCnt].PenLog.lopnStyle := ord(psClear); WmfPenBrush[WmfLogCnt].index := recpen.ihPen; WmfPenBrush[WmfLogCnt].isPen := true; End; EMR_EXTCREATEPEN: Begin WmfLogCnt := WmfLogCnt +1; RecExtPen := PEMREXTCREATEPEN(rec); WmfPenBrush[WmfLogCnt].PenLog.lopnColor := RecExtPen.elp.elpColor; WmfPenBrush[WmfLogCnt].PenLog.lopnStyle := ord(psSolid); WmfPenBrush[WmfLogCnt].index := RecExtPen.ihPen; WmfPenBrush[WmfLogCnt].isPen := true; End; EMR_EXTTEXTOUTW: Begin RecText := PEMRExtTextOut(Rec); xx := Convertx(RecText.emrtext.ptlReference.x); yy := Converty(RecText.emrtext.ptlReference.y); xText := Copy(String(PWideChar(DWORD(Rec)+RecText.emrtext.offString)),1,RecText.emrtext.nChars); if Trim(xText) <> '' then begin lenA := (PInt(DWORD(Rec)+RecText.emrtext.offDx)^)/mfdpmm; TextObj := TText(BufferObj.TextOut(WmfLayer,xx,yy,0,FontH/mfdpmm,1,xText,FontName,162,clBlack,True)); //TextObj.CSpace := lenA; end; end; EMR_EXTCREATEFONTINDIRECTW: Begin recFont := PEMRExtCreateFontIndirect(Rec); FontName := RecFont.elfw.elfLogFont.lfFaceName; FontH := RecFont.elfw.elfLogFont.lfHeight; FontCs := RecFont.elfw.elfLogFont.lfCharSet; end; EMR_EXTTEXTOUTA: Begin end; EMR_SETWORLDTRANSFORM: Begin RecSetWT := PEMRSetWorldTransform(Rec); xForm := RecSetWT.xform; end; EMR_MODIFYWORLDTRANSFORM: Begin RecModifyWT := PEMRModifyWorldTransform(Rec); mForm := RecModifyWT.xForm; xFormId := RecModifyWT.iMode; case xFormId of MWT_IDENTITY: begin xForm.eM11 := 1; xForm.eM22 := 1; xForm.eM12 := 0; xForm.eM21 := 0; xForm.eDx := 0; xForm.eDy := 0; end; MWT_LEFTMULTIPLY: begin ml[0] := mForm.eM11;ml[1] := mForm.eM12; ml[2] := 0; ml[3] := mForm.eM21;ml[4] := mForm.eM22; ml[5] := 0; ml[6] := mForm.eDX;ml[7] := mForm.eDy; ml[8] := 1; mr[0] := xForm.eM11;mr[1] := xForm.eM12; mr[2] := 0; mr[3] := xForm.eM21;mr[4] := xForm.eM22; mr[5] := 0; mr[6] := xForm.eDX;mr[7] := xForm.eDy; mr[8] := 1; for i := 0 to 8 do ms[i] := ml[i]; PCTypesUtils.MatrixMultiply(3,ml,mr,ms); xForm.eM11 := ms[0]; xForm.eM22 := ms[4]; xForm.eM12 := ms[1]; xForm.eM21 := ms[3]; xForm.eDx := ms[6]; xForm.eDy := ms[7]; end; MWT_RIGHTMULTIPLY: begin ml[0] := mForm.eM11;ml[1] := mForm.eM12; ml[2] := 0; ml[3] := mForm.eM21;ml[4] := mForm.eM22; ml[5] := 0; ml[6] := mForm.eDX;ml[7] := mForm.eDy; ml[8] := 1; mr[0] := xForm.eM11;mr[1] := xForm.eM12; mr[2] := 0; mr[3] := xForm.eM21;mr[4] := xForm.eM22; mr[5] := 0; mr[6] := xForm.eDX;mr[7] := xForm.eDy; mr[8] := 1; for i := 0 to 8 do ms[i] := mr[i]; PCTypesUtils.MatrixMultiply(3,mr,ml,ms); xForm.eM11 := ms[0]; xForm.eM22 := ms[4]; xForm.eM12 := ms[1]; xForm.eM21 := ms[3]; xForm.eDx := ms[6]; xForm.eDy := ms[7]; end; end; end; else Begin End; end; if rec.itype = EMR_EOF then begin if wmfPoCount > 1 then begin BufferObj.PolyLine(wmfLayer,wmfPoints,pw,ps,pc,0,0,0,EQDP(wmfPoints[0],wmfPoints[wmfPoCount-1]),True); end; end; if rec.itype <> EMR_EOF then result := 1 else result := 0; end; procedure TPCDrawing.ImportDXF(fileName: string; Layered, IncVertex: Boolean); var DXFObj : DXF_Object; begin try DXFObj := DXF_Object.Create_from_file(FileName, nil); AutoRefresh := False; DXFObj.ExportToPowerCad(self, layered, IncVertex); if assigned(FOnObjectInserted) then FOnObjectInserted(self, irCreate); ManualRefresh; AutoRefresh := True; except AutoRefresh := True; end; end; // ИМПОРТ СКС ДХФ procedure TPCDrawing.SCSImportDXF(fileName: string; Layered, IncVertex: Boolean); var DXFObj : DXF_ObjectSCS; begin try DXFObj := DXF_ObjectSCS.Create_from_file(FileName, nil); AutoRefresh := False; DXFObj.ExportToPowerCad(self, layered, IncVertex); if assigned(FOnObjectInserted) then FOnObjectInserted(self, irCreate); AutoRefresh := True; except on E: Exception do AddExceptionToLog('TPCDrawing.SCSImportDXF' + E.Message); end; end; // ЭКСПОРТ СКС ДХФ Procedure TPCDrawing.SCSExportDXF(FileName: string); var DXFObj : DXF_ObjectSCS; begin try DXFObj := DXF_ObjectSCS.Create_from_file(FileName, nil); DXFObj.save_to_file('C:\Projects\СКС\DXF\!Export\123.dxf'); except on E: Exception do AddExceptionToLogEx('TPCDrawing.SCSExportDXF', E.Message); end; end; procedure TPCDrawing.ExportAsDxf(FileName: string); // this procedure uses the demo version DXFExport.dcu unit of cadsoftools. // If you want the nag message disapper, please purchase the unit from www.cadsoftttols.com var E: TsgDXFExport; begin E := TsgDXFExport.Create; E.IsParseWhite := True; E.Use01MM := True; E.PenWidthRatio := 0.3; DrawToCanvas(E.Canvas,0,0,25); E.EndDraw; E.SaveToFile(FileName); end; Procedure TPCDrawing.ExecuteTBCommand(CommandId:integer); begin end; Procedure TPCDrawing.RegisterFigureClass(Fig: TFigureClass); begin if FigureClasses.IndexOf(fig) = -1 then begin FigureClasses.Add(fig); FigureClassesSL.Addobject(Fig.ClassName, TObject(Fig)); //01.11.2011 end; end; Procedure TPCDrawing.ROChanged; var a,b: integer; begin for a := 0 to layers.count-1 do begin TLayer(Layers[a]).VertZero := ord(verticalzero); TLayer(Layers[a]).HorzZero := ord(horizontalzero); end; end; procedure TPCDrawing.PrintPreview; begin // Printer.Printers[Printer.PrinterIndex]; // Printer.BeginDoc; // Printer.Canvas.MoveTo(0, 0); // Printer.Canvas.LineTo(110, 110); // Printer.EndDoc; prevForm.FIsRect := false; prevForm.CadControl := Self; prevForm.Init(true); prevForm.ShowModal; end; Procedure TPCDrawing.PrintRectPreview(ARect: TDoubleRect); //24.11.2011 begin prevForm.FPrRect := ARect; prevForm.FIsRect := true; prevForm.CadControl := Self; prevForm.Init(true); prevForm.ShowModal; end; Procedure TPCDrawing.View3D(const AFileStream: String); var fig1: TFigure; fig2: TFigure; begin {$ifdef 3D} // Tolik -- 01/02/2017 -- fig1 := Nil; fig2 := nil; try if not Assigned(frm3D) then Application.CreateForm(Tfrm3D, frm3d); frm3d.FCAD := TF_CAD(Owner); // чистятся в procedure Tfrm3D.FormCloseQuery(Sender: TObject; var CanClose: Boolean); // и на всяк случай перед вызовом из Action-ов frm3d.FIdsStream.Add(frm3d.FCAD.FCADListID {GCadForm.FCADListID}); frm3d.FFilesStream.Add(AFileStream); try fig1 := TConnectorObject.Create(0, 0, 0, GetLayerHandle(0), mydsNormal, self); TConnectorObject(fig1).ConnectorType := TConnectorType(0); Self.AddCustomFigure(0, fig1, false); TConnectorObject(fig1).Name := 'Anchor'; fig2 := TConnectorObject.Create(self.WorkWidth, self.WorkHeight, 0, GetLayerHandle(0), mydsNormal, self); TConnectorObject(fig2).ConnectorType := TConnectorType(0); Self.AddCustomFigure(0, fig2, false); TConnectorObject(fig2).Name := 'Anchor'; CollectFaces; // 22.07.2011 //16.09.2011 frm3D.LoadModelFromStream(AFileStream, GCadForm.FCADListID, Faces); //16.09.2011 if frm3D.F3DStreamModel = nil then // begin // frm3D.UpdateModelTree; // frm3D.UpdateScsModelTree; // end // else // begin // frm3D.UpdateModelTreeFromStream(Faces); // frm3D.UpdateScsModelTreeFromStream(Faces); // end; // frm3D.UpdateFaces(Faces, 1); frm3D.SyncModelFromStream(AFileStream, frm3d.FCAD.FCADListID, Faces); finally try TConnectorObject(fig1).Delete(false, False); fig1 := nil; TConnectorObject(fig2).Delete(false, False); fig2 := nil; Refresh; except end; end; // Tolik -- 01/02/2017 -- даже если будет ошибка - созданные коннекторы нужно // обязательно шлепнуть except on E: Exception do begin AddExceptionToLog('TPCDrawing.View3D: ' + E.Message); if fig1 <> nil then TConnectorObject(fig1).Delete(false, False); if fig2 <> nil then TConnectorObject(fig2).Delete(false, False); end; end; // {$endif 3D} end; function TPCDrawing.Get3DModel(const AFileStream: String=''): TObject; var SavedCAD: TF_CAD; begin Result := nil; {$ifdef 3D} BeginProgress; SavedCAD := GCadForm; GCadForm := TF_CAD(Owner); try if not Assigned(frm3D) then begin Application.CreateForm(Tfrm3D, frm3d); end; if Assigned(frm3D.F3DModel) then FreeAndNil(frm3D.F3DModel); frm3D.CreateModel; frm3D.FIdsStream.Clear; frm3D.FFilesStream.Clear; frm3D.CreateTopNode; frm3D.CreateTopSCSNode; frm3D.FZOrder := 0; frm3d.FCAD := TF_CAD(Owner); //frm3d.FFileStream := AFileStream; frm3d.FIdsStream.Add(frm3d.FCAD.FCADListID {GCadForm.FCADListID}); frm3d.FFilesStream.Add(AFileStream); CollectFaces; //16.09.2011 frm3D.UpdateFaces(Faces, 1); frm3D.SyncModelFromStream(AFileStream, frm3d.FCAD.FCADListID, Faces); //27.09.2011 frm3D.SyncModelFromStream(AFileStream, GCadForm.FCADListID, Faces); //PauseProgress(true); //frm3D.ShowModal; Result := frm3D.F3DModel; frm3D.F3DModel := nil; try FreeAndNil(frm3D); except on E: Exception do AddExceptionToLog(CPowerCadMessage + ' TPCDrawing.Get3DModel FreeAndNil(frm3D) ' + E.Message); end; finally GCadForm := SavedCAD; EndProgress; end; {$endif 3D} end; (* procedure TPCDrawing.AddCustomProperty(BlockName: String; CustomProp: TProperty); var index: integer; CList:TList; begin index := CPBlockNames.IndexOf(BlockName); if index = -1 then begin CPBlockNames.Add(BlockName); CList:= TList.Create; CPLists.Add(CList); CList.Add(CustomProp); end else begin CList := TList(CPLists[index]); CList.Add(CustomProp); end; end; *) Function TPCDrawing.GetCustomPropList(BlockName: String):Tlist; var index: integer; begin index := CPBlockNames.IndexOf(BlockName); if index = -1 then result := nil else result := Tlist(CPLists[index]); end; Procedure TPCDrawing.ResetRegions; var a: integer; Figure: TFigure; Begin For a := 0 to Figures.count - 1 do begin Figure := TFigure(Figures[a]); Figure.ResetRegion; end; end; Procedure TPCDrawing.RecordInsertUndo(xFig:Tfigure; aTag:Integer=0); var xAction: TUndoAction; begin if not RecordUndo then exit; xAction := TUndoAction.Create(uaInsert); xAction.List.Add(xFig); xAction.Tag := aTag; xFig.Urc := xfig.Urc+1; InsertUndoAction(xAction); end; Procedure TPCDrawing.AddFigureToModifyUndo(xAction: TUndoAction; xFig: TFigure); var s: TMemoryStream; begin xAction.List.Add(xFig); s := TMemoryStream.Create; xFig.WriteToStream(s); xAction.Params.Add(s); end; Procedure TPCDrawing.RecordModifyUndo(xFig:Tfigure); var xAction: TUndoAction; a,b: integer; s: TMemoryStream; jFig: TFigure; begin if not RecordUndo then exit; xAction := TUndoAction.Create(uaModify); if xFig <> nil then begin xAction.List.Add(xFig); s := TMemoryStream.Create; xFig.WriteToStream(s); xAction.Params.Add(s); InsertUndoAction(xAction); end else begin for a := 0 to figures.count - 1 do begin if TFigure(figures[a]).selected then begin xFig := TFigure(figures[a]); xAction.List.Add(xFig); s := TMemoryStream.Create; xFig.WriteToStream(s); xAction.Params.Add(s); for b := 0 to xFig.JoinedFigures.Count-1 do begin jFig := Tfigure(xFig.JoinedFigures[b]); xAction.List.Add(jFig); s := TMemoryStream.Create; jFig.WriteToStream(s); xAction.Params.Add(s); end; end; end; InsertUndoAction(xAction); end; end; Procedure TPCDrawing.InsertUndoAction(xAction:TUndoAction); var i: Integer; cAction: TUndoAction; uc: Integer; begin //Tolik 23/06/2021 -- { if GCadForm.FListType = lt_DesignBox then begin GCadForm.SaveForUndoDesignList(uat_None, False, False); if xAction <> nil then FreeAndNil(xAction); exit; end; } // // Tolik 03/06/2021 -- игрушка для посмотреть {else if GCadForm.FListType = lt_ElScheme then begin SaveListToUndoStack(GCadForm.FCADListID); if xAction <> nil then FreeAndNil(xAction); exit; end;} { else // Tolik 13/02/2021 -- if GCadForm.FListType = lt_ElScheme then begin GCadForm.SaveForUndoELScheme(uat_None, False, False); if xAction <> nil then FreeAndNil(xAction); exit; end; } FUndoList.Insert(0,xAction); FUndoIdx := 0; uc := FUndoList.Count; if (FUndoCount > 0) and (uc > FUndoCount) then begin try for i := uc downto FUndoCount+1 do begin cAction := FUndoList[i-1]; KillUndoAction(cAction); FUndoList.Delete(i-1); end; except // on E: Exception do AddExceptionToLog(CPowerCadMessage + 'TPCDrawing.InsertUndoAction' + E.Message); end; end; end; Procedure TPCDrawing.PrintMessage(Mes:String); begin end; Function TPCDrawing.GetVersion:Integer; begin result := 300; end; Function TPCDrawing.GetBuildNumber: Integer; begin result := 1000; end; procedure TPCDrawing.SetTool(aToolIndex: TPCTool; aToolInfo: String;aToolData:Integer); begin inherited; evToolIndex.RaiseEvent(Integer(Self),'',0); ResetActions; //Tolik 01/10/2021 - - if aToolInfo <> 'TOrthoLine' then GNoTraceCable := False; if aToolInfo = 'TWallPath' then CreateArchGuidesLines else DestroyArchGuidesLines; end; (* Procedure TPCDrawing.SetInterfaceHandle; begin // set in TPowercad end; Procedure TPCDrawing.NilInterfaceHandle; begin //SetControlForPlugins(nil); //SetControlForScripting(nil); end; *) Procedure TPCDrawing.DoSelChange; var Info : String; ar:Boolean; begin if FSelection.Count = 1 then begin Info := TFigure(Fselection[0]).ClassName+'>'+TFigure(Fselection[0]).Name; PrintMessage(Info); SnapInfo := TFigure(Fselection[0]).ClassName; end else PrintMessage(''); if assigned(FOnSelChange) and (not FSelChangeLocked) then begin ar := AutoRefresh; AutoRefresh := False; FOnSelChange(self); AutoRefresh := ar; end; end; // all figure classes Function TPCDrawing.FigureGetHandle(FigureIndex:Integer):Integer; begin result := 0; if (FigureIndex > -1) and (FigureIndex < Figures.Count) then result := TFigHandle(Figures[FigureIndex]); end; Function TPCDrawing.FigureGetName(FigureHandle:Integer):String; begin Result := ''; if FigureHandle <> 0 then begin Result := TFigure(FigureHandle).Name; end; end; Function TPCDrawing.FigureGetClass(FigureHandle:Integer):String; var CName: String; cls: String; i: Integer; begin Result := ''; if FigureHandle <> 0 then begin Result := TFigure(FigureHandle).CName; end; end; Function TPCDrawing.FigureGetPointCount(FigureHandle:Integer):Integer; begin Result := 0; if FigureHandle <> 0 then begin Result := TFigure(FigureHandle).PointCount; end; end; Function TPCDrawing.FigureGetPoint(FigureHandle,pIndex:Integer):TDoublePoint; begin Result := DoublePoint(0,0); if FigureHandle <> 0 then begin Result := TFigure(FigureHandle).FigurePoints[pIndex]; end; end; Function TPCDrawing.FigureGetDCPoint(FigureHandle,pIndex:Integer):TDoublePoint; var p: TDoublePoint; z: Double; begin Result := DoublePoint(0,0); if FigureHandle <> 0 then begin p := TFigure(FigureHandle).FigurePoints[pIndex]; z := 0; DEngine.ConvertPoint(p.x,p.y,z); result := p; end; end; Function TPCDrawing.GetDCPoint(p:TDoublePoint):TDoublePoint; var pp: TDoublePoint; z: Double; begin pp := p; z := 0; DEngine.ConvertPoint(pp.x,pp.y,z); result := pp; end; Function TPCDrawing.GetDCLen(l:Double):Integer; var ll: Double; begin ll := l; DEngine.ConvertLen(ll); result := round(ll); end; Function TPCDrawing.FigureGetCenter(FigureHandle:Integer):TDoublePoint; begin Result := DoublePoint(0,0); if FigureHandle <> 0 then begin Result := TFigure(FigureHandle).CenterPoint; end; end; Function TPCDrawing.FigureGetRect(FigureHandle:Integer):TDoubleRect; begin Result := DoubleRect(0,0,0,0); if FigureHandle <> 0 then begin Result := TFigure(FigureHandle).GetBoundRect; end; end; Function TPCDrawing.FigureGetRadius(FigureHandle:Integer):Double; begin Result := 0; if FigureHandle <> 0 then begin Result := TFigure(FigureHandle).Radius; end; end; Function TPCDrawing.FigureGetFontName(FigureHandle:Integer):String; begin Result := ''; if (FigureHandle <> 0) and (TFigure(FigureHandle) is TText) then begin Result := TText(FigureHandle).Font.Name; end; end; Function TPCDrawing.FigureGetFontBold(FigureHandle:Integer):Boolean; begin Result := False; if (FigureHandle <> 0) and (TFigure(FigureHandle) is TText) then begin Result := fsBold in TText(FigureHandle).Font.Style; end; end; Function TPCDrawing.FigureGetFontItalic(FigureHandle:Integer):Boolean; begin Result := False; if (FigureHandle <> 0) and (TFigure(FigureHandle) is TText) then begin Result := fsItalic in TText(FigureHandle).Font.Style; end; end; Function TPCDrawing.FigureGetFontUnderline(FigureHandle:Integer):Boolean; begin Result := False; if (FigureHandle <> 0) and (TFigure(FigureHandle) is TText) then begin Result := fsUnderLine in TText(FigureHandle).Font.Style; end; end; Function TPCDrawing.FigureGetFontStrike(FigureHandle:Integer):Boolean; begin Result := False; if (FigureHandle <> 0) and (TFigure(FigureHandle) is TText) then begin Result := fsStrikeOut in TText(FigureHandle).Font.Style; end; end; Function TPCDrawing.FigureGetFontSize(FigureHandle:Integer):Double; begin Result := 0; if (FigureHandle <> 0) and (TFigure(FigureHandle) is TText) then begin Result := TText(FigureHandle).Height; end; end; Function TPCDrawing.FigureGetFontCharset(FigureHandle:Integer):Integer; begin Result := 0; if (FigureHandle <> 0) and (TFigure(FigureHandle) is TText) then begin Result := TText(FigureHandle).Font.Charset; end; end; Function TPCDrawing.FigureGetFontColor(FigureHandle:Integer):TColor; begin Result := 0; if (FigureHandle <> 0) and (TFigure(FigureHandle) is TText) then begin Result := TText(FigureHandle).Color; end; end; Function TPCDrawing.FigureGetPenColor(FigureHandle:Integer):TColor; begin Result := 0; if (FigureHandle <> 0) then begin Result := TFigure(FigureHandle).color; end; end; Function TPCDrawing.FigureGetBrushColor(FigureHandle:Integer):TColor; begin Result := 0; if (FigureHandle <> 0) then begin Result := TFigure(FigureHandle).brc; end; end; Function TPCDrawing.FigureGetPenStyle(FigureHandle:Integer):TPenStyle; begin Result :=psClear; if (FigureHandle <> 0) then begin Result := TPenStyle(TFigure(FigureHandle).Style); end; end; Function TPCDrawing.FigureGetBrushStyle(FigureHandle:Integer):TBrushStyle; begin Result :=bsClear; if (FigureHandle <> 0) then begin Result := TBrushStyle(TFigure(FigureHandle).brs); end; end; Function TPCDrawing.FigureGetRowStyle(FigureHandle:Integer):TRowStyle; begin Result :=rsNone; if (FigureHandle <> 0) then begin Result := TRowStyle(TFigure(FigureHandle).RowStyle); end; end; Function TPCDrawing.FigureGetPenWidth(FigureHandle:Integer):Integer; begin Result := 0; if (FigureHandle <> 0) then begin Result := TFigure(FigureHandle).Width; end; end; Function TPCDrawing.FigureGetInfo(FigureHandle:Integer):String; begin Result := ''; if (FigureHandle <> 0) then begin Result := TFigure(FigureHandle).Info; end; end; Function TPCDrawing.FigureGetAngle(FigureHandle:Integer):Double; begin Result := 0; if (FigureHandle <> 0) then begin Result := TFigure(FigureHandle).Angle; end; end; Function TPCDrawing.FigureGetLayerHandle(FigureHandle:Integer):Integer; begin Result := 0; if (FigureHandle <> 0) then begin Result := TFigure(FigureHandle).LayerHandle; end; end; Function TPCDrawing.FigureGetDiagonal(FigureHandle:Integer):Boolean; begin Result := False; if (FigureHandle <> 0) then begin Result := TFigure(FigureHandle).DiagonalScale; end; end; Function TPCDrawing.FigureGetLockMove(FigureHandle:Integer):Boolean; begin Result := False; if (FigureHandle <> 0) then begin Result := TFigure(FigureHandle).LockMove; end; end; Function TPCDrawing.FigureGetLockModify(FigureHandle:Integer):Boolean; begin Result := False; if (FigureHandle <> 0) then begin Result := TFigure(FigureHandle).LockModify; end; end; Function TPCDrawing.FigureGetSelected(FigureHandle:Integer):Boolean; begin Result := False; if (FigureHandle <> 0) then begin Result := TFigure(FigureHandle).Selected; end; end; Function TPCDrawing.FigureTestPoint(FigureHandle:Integer;TestPoint:TDoublePoint):Boolean; begin Result := False; if (FigureHandle <> 0) then begin Result := TFigure(FigureHandle).IsPointIn(TestPoint.x,TestPoint.y); end; end; Function TPCDrawing.FigureTestRect(FigureHandle:Integer;TestRect:TDoubleRect):Boolean; begin Result := False; if (FigureHandle <> 0) then begin Result := TFigure(FigureHandle).CheckifInArea(TestRect); end; end; Function TPCDrawing.FigureGetRgnHandle(FigureHandle:Integer):Integer; begin Result := 0; if (FigureHandle <> 0) then begin Result := TFigure(FigureHandle).RegHandle; end; end; Procedure TPCDrawing.FigureSelect(FigureHandle:Integer); begin if (FigureHandle <> 0) then begin TFigure(FigureHandle).Select; end; end; Procedure TPCDrawing.FigureSelectAsRotate(FigureHandle:Integer); begin if (FigureHandle <> 0) then begin TFigure(FigureHandle).RotateSelect; end; end; Procedure TPCDrawing.FigureDeSelect(FigureHandle:Integer); begin if (FigureHandle <> 0) then begin TFigure(FigureHandle).DeSelect; end; end; Procedure TPCDrawing.FigureEdit(FigureHandle:Integer); begin if (FigureHandle <> 0) then begin TFigure(FigureHandle).Edit; end; end; Procedure TPCDrawing.FigureMove(FigureHandle:Integer;deltax,deltay: Double); begin if (FigureHandle <> 0) then begin TFigure(FigureHandle).Move(deltaX,deltaY); end end; Procedure TPCDrawing.FigureRotate(FigureHandle:Integer;Angle:Double); begin if (FigureHandle <> 0) then begin TFigure(FigureHandle).Rotate(Angle,TFigure(FigureHandle).CenterPoint); end; end; Procedure TPCDrawing.FigureRotateByPoint(FigureHandle:Integer;Angle:Double; cPoint:TDoublePoint); begin if (FigureHandle <> 0) then begin TFigure(FigureHandle).Rotate(Angle,cPoint); end; end; Procedure TPCDrawing.FigureMirror(FigureHandle:Integer; Point1,Point2: TDoublePoint); begin if (FigureHandle <> 0) then begin TFigure(FigureHandle).Mirror(point1,point2); end; end; Procedure TPCDrawing.FigureScale(FigureHandle:Integer; px,py: Double); begin if (FigureHandle <> 0) then begin TFigure(FigureHandle).Scale(px,py,TFigure(FigureHandle).CenterPoint); end; end; Procedure TPCDrawing.FigureScaleByPoint(FigureHandle:Integer; px,py: Double; rPoint: TDoublepoint); begin if (FigureHandle <> 0) then begin TFigure(FigureHandle).Scale(px,py,rPoint); end; end; Procedure TPCDrawing.FigureSetFontName(FigureHandle:Integer;value:String); begin if (FigureHandle <> 0) and (TFigure(FigureHandle) is TText) then begin TText(FigureHandle).Font.name := Value; TText(FigureHandle).Modified := True; end; end; Procedure TPCDrawing.FigureSetFontBold(FigureHandle:Integer;value:Boolean); var xfont: Tfont; begin if (FigureHandle <> 0) and (TFigure(FigureHandle) is TText) then begin xfont := TText(FigureHandle).Font; if value then xfont.Style := xFont.Style + [fsBold] else xfont.Style := xFont.Style - [fsBold]; TText(FigureHandle).Modified := True; end; end; Procedure TPCDrawing.FigureSetFontItalic(FigureHandle:Integer;value:Boolean); var xfont: Tfont; begin if (FigureHandle <> 0) and (TFigure(FigureHandle) is TText) then begin xfont := TText(FigureHandle).Font; if value then xfont.Style := xFont.Style + [fsItalic] else xfont.Style := xFont.Style - [fsItalic]; TText(FigureHandle).Modified := True; end; end; Procedure TPCDrawing.FigureSetFontUnderline(FigureHandle:Integer;value:Boolean); var xfont: Tfont; begin if (FigureHandle <> 0) and (TFigure(FigureHandle) is TText) then begin xfont := TText(FigureHandle).Font; if value then xfont.Style := xFont.Style + [fsUnderLine] else xfont.Style := xFont.Style - [fsUnderLine]; TText(FigureHandle).Modified := True; end; end; Procedure TPCDrawing.FigureSetFontStrike(FigureHandle:Integer;value:Boolean); var xfont: Tfont; begin if (FigureHandle <> 0) and (TFigure(FigureHandle) is TText) then begin xfont := TText(FigureHandle).Font; if value then xfont.Style := xFont.Style + [fsStrikeOut] else xfont.Style := xFont.Style - [fsStrikeOut]; TText(FigureHandle).Modified := True; end; end; Procedure TPCDrawing.FigureSetFontSize(FigureHandle:Integer;value:Double); begin if (FigureHandle <> 0) and (TFigure(FigureHandle) is TText) then begin TText(FigureHandle).Height := Value; TText(FigureHandle).Modified := True; end; end; Procedure TPCDrawing.FigureSetFontCharset(FigureHandle:Integer;value:Integer); begin if (FigureHandle <> 0) and (TFigure(FigureHandle) is TText) then begin TText(FigureHandle).Font.Charset := Value; TText(FigureHandle).Modified := True; end; end; Procedure TPCDrawing.FigureSetFontColor(FigureHandle:Integer;value:TColor); begin if (FigureHandle <> 0) and (TFigure(FigureHandle) is TText) then begin TText(FigureHandle).Font.Color := Value; TText(FigureHandle).Color := Value; TText(FigureHandle).Modified := True; end; end; Procedure TPCDrawing.FigureSetPenColor(FigureHandle:Integer;value:TColor); begin if (FigureHandle <> 0) then begin TFigure(FigureHandle).Color := value; end; end; Procedure TPCDrawing.FigureSetBrushColor(FigureHandle:Integer;value:TColor); begin if (FigureHandle <> 0) then begin TFigure(FigureHandle).brc := value; end; end; Procedure TPCDrawing.FigureSetPenStyle(FigureHandle:Integer;value:TPenStyle); begin if (FigureHandle <> 0) then begin TFigure(FigureHandle).Style := ord(value); end; end; Procedure TPCDrawing.FigureSetBrushStyle(FigureHandle:Integer;value:TBrushStyle); begin if (FigureHandle <> 0) then begin TFigure(FigureHandle).brs := ord(value); end; end; Procedure TPCDrawing.FigureSetRowStyle(FigureHandle:Integer;value:TRowStyle); begin if (FigureHandle <> 0) then begin TFigure(FigureHandle).RowStyle := ord(value); end; end; Procedure TPCDrawing.FigureSetPenWidth(FigureHandle:Integer;value:Integer); begin if (FigureHandle <> 0) then begin TFigure(FigureHandle).Width := Value; end; end; Procedure TPCDrawing.FigureSetPoint(FigureHandle,pIndex:Integer;fPoint:TDoublePoint); begin if (FigureHandle <> 0) then begin TFigure(FigureHandle).FigurePoints[pIndex] := fPoint; end; end; Procedure TPCDrawing.FigureSetInfo(FigureHandle:Integer;value:String); begin if (FigureHandle <> 0) then begin TFigure(FigureHandle).Info := Value; end; end; Procedure TPCDrawing.FigureSetAngle(FigureHandle:Integer;value:Double); begin if (FigureHandle <> 0) then begin TFigure(FigureHandle).Angle := Value; end; end; Procedure TPCDrawing.FigureSetLayerHandle(FigureHandle:Integer;value:Integer); begin if (FigureHandle <> 0) then begin TFigure(FigureHandle).LayerHandle := Value; end; end; Procedure TPCDrawing.FigureSetDiagonal(FigureHandle:Integer;value:Boolean); begin if (FigureHandle <> 0) then begin TFigure(FigureHandle).DiagonalScale := Value; end; end; Procedure TPCDrawing.FigureSetLockMove(FigureHandle:Integer;value:Boolean); begin if (FigureHandle <> 0) then begin TFigure(FigureHandle).LockMove := Value; end; end; Procedure TPCDrawing.FigureSetLockModify(FigureHandle:Integer;value:Boolean); begin if (FigureHandle <> 0) then begin TFigure(FigureHandle).LockModify := Value; end; end; Procedure TPCDrawing.FigureSetRgnHandle(FigureHandle,Rgn:Integer); var r: Integer; begin if (FigureHandle <> 0) then begin r := TFigure(FigureHandle).RegHandle; if r <> 0 then deleteobject(r); TFigure(FigureHandle).RegHandle := Rgn; end; end; //block - figure grp Function TPCDrawing.FigureGrpGetFigureCount(FigureHandle:Integer):Integer; begin result := 0; if (FigureHandle <> 0) and (TFigure(FigureHandle) is TFigureGrp) then begin result := TFigureGrp(FigureHandle).InFigures.Count; end; end; Function TPCDrawing.FigureGrpGetFigureHandle(FigureHandle,fIndex:Integer):Integer; begin result := 0; if (FigureHandle <> 0) and (TFigure(FigureHandle) is TFigureGrp) then begin if (fIndex > -1) and (fIndex < TFigureGrp(FigureHandle).InFigures.Count) then result := Integer(TFigureGrp(FigureHandle).InFigures[fIndex]); end; end; Function TPCDrawing.FigureGrpGetCombined(FigureHandle:Integer):Boolean; begin result := false; if (FigureHandle <> 0) and (TFigure(FigureHandle) is TFigureGrp) then begin result := TFigureGrp(FigureHandle).Combined; end; end; Procedure TPCDrawing.FigureGrpSetCombined(FigureHandle:Integer;Value:Boolean); begin if (FigureHandle <> 0) and (TFigure(FigureHandle) is TFigureGrp) then begin TFigureGrp(FigureHandle).Combined := value; end; end; Procedure TPCDrawing.FigureGrpUngroup(FigureHandle:Integer); begin if (FigureHandle <> 0) and (TFigure(FigureHandle) is TFigureGrp) then begin TFigureGrp(FigureHandle).UnGroup; end; end; // block Function TPCDrawing.FigureBlockGetBlockname(FigureHandle:Integer):String; begin result := ''; if (FigureHandle <> 0) and (TFigure(FigureHandle) is TBlock) then begin result := TBlock(FigureHandle).BlockName; end; end; // line - polyline Function TPCDrawing.FigureGetJoin1(FigureHandle:Integer):Integer; begin result := 0; if (FigureHandle <> 0) and (TFigure(FigureHandle) is DrawObjects.TLine) then begin result := Integer(DrawObjects.TLine(FigureHandle).JoinFigure1); end; end; Function TPCDrawing.FigureGetJoin2(FigureHandle:Integer):Integer; begin result := 0; if (FigureHandle <> 0) and (TFigure(FigureHandle) is DrawObjects.TLine) then begin result := Integer(DrawObjects.TLine(FigureHandle).JoinFigure2); end; end; Procedure TPCDrawing.FigureSetJoin1(FigureHandle,JHandle:Integer); begin if (FigureHandle <> 0) and (TFigure(FigureHandle) is DrawObjects.TLine) then begin DrawObjects.TLine(FigureHandle).SetJFigure1(Tfigure(Jhandle)); end; end; Procedure TPCDrawing.FigureSetJoin2(FigureHandle,JHandle:Integer); begin if (FigureHandle <> 0) and (TFigure(FigureHandle) is DrawObjects.TLine) then begin DrawObjects.TLine(FigureHandle).SetJFigure2(Tfigure(Jhandle)); end; end; Function TPCDrawing.FigureGetClosed(FigureHandle:Integer):Boolean; begin result := false; if (FigureHandle <> 0) and (TFigure(FigureHandle) is TPolyline) then begin result := TPolyline(FigureHandle).Closed; end; end; Procedure TPCDrawing.FigureSetClosed(FigureHandle:Integer; Closed:Boolean); begin if (FigureHandle <> 0) and (TFigure(FigureHandle) is TPolyline) then begin TPolyline(FigureHandle).Closed := Closed; end; end; Function TPCDrawing.FigureGetControlPoint(FigureHandle,SegmentIndex,pIndex:Integer):TDoublePoint; var Seg: TPlSegment; begin result := DoublePoint(0,0); if (FigureHandle <> 0) and (TFigure(FigureHandle) is TPolyline) then begin if (SegmentIndex > 0) and (SegmentIndex <= TPolyline(FigureHandle).Segments.Count) then begin seg := TPlSegment(TPolyline(FigureHandle).Segments[SegmentIndex-1]); if pIndex = 0 then result := seg.CPoint1 else result := seg.CPoint2; end; end; end; Procedure TPCDrawing.FigureSetControlPoints(FigureHandle,SegmentIndex:Integer;cPoint1,cPoint2:TDoublePoint); var Seg: TPlSegment; begin if (FigureHandle <> 0) and (TFigure(FigureHandle) is TPolyline) then begin if (SegmentIndex > 0) and (SegmentIndex <= TPolyline(FigureHandle).Segments.Count) then begin seg := TPlSegment(TPolyline(FigureHandle).Segments[SegmentIndex-1]); seg.CPoint1 := cPoint1; seg.CPoint2 := cPoint2; end; end; end; Function TPCDrawing.FigureGetSegmentType(FigureHandle,SegmentIndex:Integer):TSegmentType; var Seg: TPlSegment; begin result := sLine; if (FigureHandle <> 0) and (TFigure(FigureHandle) is TPolyline) then begin if (SegmentIndex > 0) and (SegmentIndex <= TPolyline(FigureHandle).Segments.Count) then begin seg := TPlSegment(TPolyline(FigureHandle).Segments[SegmentIndex-1]); result := seg.sType; end; end; end; Procedure TPCDrawing.FigureSetSegmentType(FigureHandle,SegmentIndex:Integer; SegType:TSegmentType); var Seg: TPlSegment; begin if (FigureHandle <> 0) and (TFigure(FigureHandle) is TPolyline) then begin if (SegmentIndex > 0) and (SegmentIndex <= TPolyline(FigureHandle).Segments.Count) then begin TPolyline(FigureHandle).ArrangeSegment(SegmentIndex,SegType); end; end; end; Procedure TPCDrawing.FigureInvertArcSegment(FigureHandle,SegmentIndex:Integer); var Seg: TPlSegment; begin if (FigureHandle <> 0) and (TFigure(FigureHandle) is TPolyline) then begin if (SegmentIndex > 0) and (SegmentIndex <= TPolyline(FigureHandle).Segments.Count) then begin seg := TPlSegment(TPolyline(FigureHandle).Segments[SegmentIndex-1]); seg.Inverted := seg.Inverted; end; end; end; Procedure TPCDrawing.FigureConvertPLBezier(FigureHandle:Integer); begin if (FigureHandle <> 0) and (TFigure(FigureHandle) is TPolyline) then begin TPolyline(FigureHandle).ConvertToBezier; end; end; Procedure TPCDrawing.FigureConvertPLPolyline(FigureHandle:Integer); begin if (FigureHandle <> 0) and (TFigure(FigureHandle) is TPolyline) then begin TPolyline(FigureHandle).ConvertToPolyline; end; end; // ellipse Function TPCDrawing.FigureGetElpALen(FigureHandle:Integer):Double; begin result := 0; if (FigureHandle <> 0) and (TFigure(FigureHandle) is TEllipse) then begin result := TEllipse(FigureHandle).Alen; end else if (FigureHandle <> 0) and (TFigure(FigureHandle) is TElpArc) then begin result := TElpArc(FigureHandle).Alen; end; end; Function TPCDrawing.FigureGetElpBLen(FigureHandle:Integer):Double; begin result := 0; if (FigureHandle <> 0) and (TFigure(FigureHandle) is TEllipse) then begin result := TEllipse(FigureHandle).Blen; end else if (FigureHandle <> 0) and (TFigure(FigureHandle) is TElpArc) then begin result := TElpArc(FigureHandle).Blen; end; end; //arc Function TPCDrawing.FigureGetArcStyle(FigureHandle:Integer):TArcStyle; begin result := asOpen; if (FigureHandle <> 0) and (TFigure(FigureHandle) is TArc) then begin result := TArc(FigureHandle).ArcStyle; end else if (FigureHandle <> 0) and (TFigure(FigureHandle) is TElpArc) then begin result := TElpArc(FigureHandle).ArcStyle; end; end; Procedure TPCDrawing.FigureSetArcStyle(FigureHandle:Integer;aStyle:TArcStyle); begin if (FigureHandle <> 0) and (TFigure(FigureHandle) is TArc) then begin TArc(FigureHandle).ArrangeStyle(aStyle); end else if (FigureHandle <> 0) and (TFigure(FigureHandle) is TElpArc) then begin TElpArc(FigureHandle).ArrangeStyle(aStyle); end; end; Procedure TPCDrawing.FigureInvertArc(FigureHandle:Integer); begin if (FigureHandle <> 0) and (TFigure(FigureHandle) is TArc) then begin TArc(FigureHandle).Invert; end else if (FigureHandle <> 0) and (TFigure(FigureHandle) is TElpArc) then begin TElpArc(FigureHandle).Invert; end; end; Function TPCDrawing.FigureGetArcSAngle(FigureHandle:Integer):Double; begin result := 0; if (FigureHandle <> 0) and (TFigure(FigureHandle) is TArc) then begin result := TArc(FigureHandle).SAngle; end else if (FigureHandle <> 0) and (TFigure(FigureHandle) is TElpArc) then begin result := TElpArc(FigureHandle).SAngle; end; end; Function TPCDrawing.FigureGetArcFAngle(FigureHandle:Integer):Double; begin result := 0; if (FigureHandle <> 0) and (TFigure(FigureHandle) is TArc) then begin result := TArc(FigureHandle).FAngle; end else if (FigureHandle <> 0) and (TFigure(FigureHandle) is TElpArc) then begin result := TElpArc(FigureHandle).FAngle; end; end; Procedure TPCDrawing.FigureSetArcAngles(FigureHandle:Integer; SAngle,FAngle:Double); begin if (FigureHandle <> 0) and (TFigure(FigureHandle) is TArc) then begin TArc(FigureHandle).SAngle := SAngle; TArc(FigureHandle).FAngle := FAngle; TArc(FigureHandle).ResetRegion; TArc(FigureHandle).Modified := True; end else if (FigureHandle <> 0) and (TFigure(FigureHandle) is TElpArc) then begin TElpArc(FigureHandle).SAngle := SAngle; TElpArc(FigureHandle).FAngle := FAngle; TElpArc(FigureHandle).ResetRegion; TElpArc(FigureHandle).Modified := True; end; end; // rich text Function TPCDrawing.FigureGetRichText(FigureHandle:Integer):String; begin result := ''; if (FigureHandle <> 0) and (TFigure(FigureHandle) is TRichText) then begin result := TRichText(FigureHandle).re.Lines.Text; end; end; Procedure TPCDrawing.FigureSetRichText(FigureHandle:Integer;rText:String); begin if (FigureHandle <> 0) and (TFigure(FigureHandle) is TRichText) then begin TRichText(FigureHandle).re.Lines.Text := rtext; end; end; Function TPCDrawing.FigureGetPictureName(FigureHandle:Integer):String; begin result := ''; if (FigureHandle <> 0) and ((TFigure(FigureHandle) is TbmpObject) or (TFigure(FigureHandle) is TWmfObject)) then begin if (TFigure(FigureHandle) is TbmpObject) then result := TBmpObject(FigureHandle).PictureName else result := TWmfObject(FigureHandle).PictureName; end; end; // Bmp Object Function TPCDrawing.FigureGetTransparent(FigureHandle:Integer):Boolean; begin result := False; if (FigureHandle <> 0) and (TFigure(FigureHandle) is TbmpObject) then begin result := TBmpObject(FigureHandle).Transparent; end; end; Procedure TPCDrawing.FigureSetTransparent(FigureHandle:Integer;Value:Boolean); begin if (FigureHandle <> 0) and (TFigure(FigureHandle) is TbmpObject) then begin TBmpObject(FigureHandle).Transparent := Value; end; end; Procedure TPCDrawing.FigureFlipHorz(FigureHandle:Integer); begin if (FigureHandle <> 0) and (TFigure(FigureHandle) is TbmpObject) then begin TBmpObject(FigureHandle).FlipHorz; end; end; Procedure TPCDrawing.FigureFlipVert(FigureHandle:Integer); begin if (FigureHandle <> 0) and (TFigure(FigureHandle) is TbmpObject) then begin TBmpObject(FigureHandle).FlipVert; end; end; Procedure TPCDrawing.FigureSkewBitmap(FigureHandle:Integer); begin if (FigureHandle <> 0) and (TFigure(FigureHandle) is TbmpObject) then begin TBmpObject(FigureHandle).SkewShape; end; end; Procedure TPCDrawing.FigureSaveBitmapToFile(FigureHandle:Integer;FName:String); begin if (FigureHandle <> 0) and (TFigure(FigureHandle) is TbmpObject) then begin TBmpObject(FigureHandle).Picture.SaveToFile(Fname); end; end; Procedure TPCDrawing.FigureLoadBitmapFromFile(FigureHandle:Integer; FName:String); begin if (FigureHandle <> 0) and (TFigure(FigureHandle) is TbmpObject) then begin TBmpObject(FigureHandle).Picture.LoadFromFile(FName); TBmpObject(FigureHandle).Modified := True; end; end; // Text Function TPCDrawing.FigureGetText(FigureHandle:Integer):String; begin result := ''; if (FigureHandle <> 0) and (TFigure(FigureHandle) is TText) then begin result := TText(FigureHandle).Text; end; end; Procedure TPCDrawing.FigureSetText(FigureHandle:Integer;Value:String); begin if (FigureHandle <> 0) and (TFigure(FigureHandle) is TText) then begin TText(FigureHandle).Text := Value; TText(FigureHandle).Modified := true; end; end; Function TPCDrawing.DrawUserFigureEvent(Cname:String; DC,Handle:Integer;isGrayed:Boolean):Boolean; var res: Boolean; Begin res := false; if assigned(FonUserDraw) then begin FOnUserDraw(Self,CName,Dc,Handle,isGrayed,res); end; result := res; end; Function TPCDrawing.PointInUserFigureEvent(Cname:String;Handle:Integer;x,y:Double; var Test:Boolean):Boolean; var res: Boolean; Begin res := false; if assigned(FOnUserHitTest) then begin FOnUserHitTest(Self,Cname,Handle,x,y,Test,Res); end; result := res; end; procedure TPCDrawing.LockSelChange; begin FSelChangeLocked := True; end; procedure TPCDrawing.UnLockSelChange; begin FSelChangeLocked := False; end; procedure TPCDrawing.DrawDetail; var a: integer; Figure : TFigure; Layer : TLayer; isDraw,isFlue: Boolean; unreg: string; xFont: TFont; nh,nl:Integer; vRect: TDoubleRect; frect: TDoubleRect; cReg:HRGN; begin vRect := GetVisibleRect; if FDetail then begin DEngine.Canvas.Pen.Color := clBlack; DEngine.Canvas.Pen.Style := psSolid; DEngine.Canvas.Pen.Mode := pmCopy; DEngine.Canvas.Pen.Width := 2; Dengine.Canvas.Brush.Color := PageColor; Dengine.Canvas.Brush.Style := bsSolid; if DetailActive then begin DEngine.Canvas.Pen.Width := 3; DEngine.Canvas.Pen.Color := clRed; DEngine.Canvas.Rectangle(FdetailPosX+1,FDetailPosY+1,FdetailPosX+FDetailWidth,FDetailPosY+FDetailHeight); end else DEngine.Canvas.Rectangle(FdetailPosX+1,FDetailPosY+1,FdetailPosX+FDetailWidth,FDetailPosY+FDetailHeight); DrawGrids(DEngine.Canvas); DrawGuides(DEngine.Canvas); For a := 0 to Figures.count-1 do begin Figure := TFigure(Figures[a]); isDraw := True;isFlue := False; fRect := fiGure.GetBoundRect; if RectOverlaps(vRect,fRect) then begin if Figure.LayerHandle > 0 then begin Layer := TLayer(Figure.LayerHandle); isDraw := (Layer.visible <> lost); isFlue := (Layer.visible = grayed); end; if (isDraw or (Figure is TFigureGrp)) then begin Figure.DrawDetail(Dengine,DetailStyle); end; end; end; Dengine.Canvas.Brush.Style := bsClear; DEngine.Canvas.Pen.Color := clBlack; DEngine.Canvas.Pen.Style := psSolid; DEngine.Canvas.Pen.Mode := pmCopy; DEngine.Canvas.Pen.Width := 2; if DetailActive then begin DEngine.Canvas.Pen.Width := 3; DEngine.Canvas.Pen.Color := clRed; DEngine.Canvas.Rectangle(FdetailPosX+1,FDetailPosY+1,FdetailPosX+FDetailWidth,FDetailPosY+FDetailHeight); end else DEngine.Canvas.Rectangle(FdetailPosX+1,FDetailPosY+1,FdetailPosX+FDetailWidth,FDetailPosY+FDetailHeight); DEngine.Canvas.Rectangle(FdetailPosX+1,FDetailPosY+1,FdetailPosX+FDetailWidth,FDetailPosY+FDetailHeight); end; end; function TPCDrawing.GetZAvg(dRect: TDoubleRect): Double; var i,k: Integer; zMin,zMax: Double; fAvg: Double; Figure:TFigure; fRect:TDoubleRect; isDraw:Boolean; begin zMin := 0; zMax := 0; k := 0; for i := 0 to Figures.Count-1 do begin Figure := TFigure(Figures[i]); isDraw := True; fRect := fiGure.GetBoundRect; if Figure.LayerHandle > 0 then begin isDraw := (TLayer(Figure.LayerHandle).visible <> lost); end; if isDraw and Figure.GetZAvg(dRect,fAvg) then begin if k = 0 then begin zMin := fAvg; zMax := fAvg; end else begin if fAvg < ZMin then zMin := fAvg; if fAvg > ZMax then zMax := fAvg; end; k := k+1; end; end; Result := (zMin+zMax)/2; end; function TPCDrawing.HitTestModPointIntVal(x, y: Integer): TModPoint; var a: integer; pdim : Integer; Begin result := nil; pdim := pointdim; for a := 0 to ModPoints.count-1 do begin if TModPoint(ModPoints[a]).IsPointInInt(x,y,pdim) then begin result := ModPoints[a]; exit; end; end; end; function TPCDrawing.HitTestModPointDetVal(x, y: Integer): TModPoint; var a: integer; pdim : Integer; Begin result := nil; pdim := pointdim; for a := 0 to ModPoints.count-1 do begin if TModPoint(ModPoints[a]).IsPointInDetInt(x,y,pdim) then begin result := ModPoints[a]; exit; end; end; end; function TPCDrawing.CheckByPointInt(LayerNbr, x, y: Integer): TFigure; var a,i:integer; f: Tfigure; invis:boolean; begin result := nil; for i := 0 to figures.count-1 do begin a := figures.count-1-i; f := TFigure(figures[a]); invis := false; if (f.LayerHandle <> 0) then invis := (TLayer(f.LayerHandle).Visible = lost); if (not invis) and ((LayerNbr = 0) or (f.LayerHandle = LongInt(Layers[LayerNbr]))) and (f.isPointInInt(x,y)) then begin Result := f; exit; end; end; end; Function TPCDrawing.SelectByFigure(LayerNbr: Integer; Fig: TFigHandle; shiftpressed: boolean):Boolean; begin result := false; if TFigure(Fig).LockSelect then exit; FIsSelectingFig := true; if not TFigure(Fig).Selected then begin If (not shiftpressed) and (FAnySelected) then begin deselectall(LayerNbr); end; end else begin if shiftpressed then begin TFigure(Fig).DeSelect; If Selection.Count = 0 then FAnySelected := false; ReDrawSelection; SyncEnv; DoSelChange; Result := false; end else begin if TFigure(Fig).InsideSelection then begin TFigure(Fig).reselect; ReDrawSelection; DoSelChange; end; Result := True; end; Exit; end; TFigure(Fig).rMode := false; TF_Cad(Owner).GPCadPrevSelCount := 1; //Tolik 24/07/2021 -- TFigure(Fig).Select; if assigned(FFigureSelect) then FFigureSelect(Self,TFigure(Fig)); FAnySelected := true; ReDrawSelection; SyncEnv; DoSelChange; result := true; FIsSelectingFig := false; end; procedure TPCDrawing.GetIsometricBounds(var MinX, MinY, MaxX, MaxY: Double); var i: Integer; figMaxX,figMaxY,figMinX,figMinY: Double; Figure: TFigure; begin For i := 0 to Figures.count-1 do begin Figure := TFigure(Figures[i]); Figure.GetIsometricBounds(figMaxX,figMaxY,figMinX,figMinY); if i = 0 then begin MinX := figMinX; MinY := figMinY; MaxX := figMaxX; MaxY := figMaxY; end else begin if figMinX < MinX then MinX := figMinX; if figMinY < MinY then MinY := figMinY; if figMaxX > MaxX then MaxX := figMaxX; if figMaxY > MaxY then MaxY := figMaxY; end; end; end; procedure TPCDrawing.SetZoomRect(const Value: Boolean); begin FZoomRect := Value; end; procedure TPCDrawing.ReDrawSelectionPoints; begin if not (csDesigning in self.ComponentState) then begin DrawGuideTrace(-25000,-25000); TempBitmap.Assign(BaseBitmap); DrawSelectionPoints; DrawFigureGuides; if assigned(self.parent) then Surface.Canvas.Draw(0,0,TempBitmap); if assigned(CustomSurface) then CustomSurface.Draw(0,0,TempBitmap); DoSelChange; end; end; procedure TPCDrawing.CenterPage; var dRect:TDoubleRect; dx,dy: Double; begin dRect := GetDrawingRect; dx := (WorkWidth/2)- ((dRect.Left+dRect.right)/2); dy := (WorkHeight/2)- ((dRect.Top+dRect.Bottom)/2); DeltaMoveX := dx; DeltaMoveY := dy; MoveAll(dx,dy); end; procedure TPCDrawing.SetRangeCheck(const Value: Boolean); begin fRangeCheck := Value; Refresh; end; procedure TPCDrawing.RotateSelectionCenter(Angle: Double); var xRect:TDoubleRect; cp: TDoublePOint; begin cp := DoublePOint((xRect.Left+xrect.right)/2,(xRect.top+xrect.bottom)/2); xRect := GetSelectionRect; RotateSelection(Angle,cp); end; procedure TPCDrawing.SetFigureGuides(const Value: Boolean); begin FFigureGuides := Value; Refresh; end; function TPCDrawing.GetRecordUndo: Boolean; begin Result := FRecordUndo and (not assigned(FOnCustomUndo)); end; procedure TPCDrawing.StartBlink; begin FBlinkPaused := False; FBlinkTimer.Enabled := True; end; procedure TPCDrawing.OnBlinkTimer(Sender: TObject); var i:Integer; mp:TmodPoint; begin if not Self.Focused then begin StopBlink; FBlinkPaused := True; exit; end; FBlinkPaused := False; for i := 0 to ModPoints.COunt-1 do begin mp := TmodPoint(ModPOints[i]); if mp.isBlink then mp.isDraw := not mp.isDraw; end; FSelChangeLocked := True; RedrawSelectionPoints; FSelChangeLocked := False; end; procedure TPCDrawing.StopBlink; var i:Integer; mp:TmodPoint; begin FBlinkTimer.Enabled := False; for i := 0 to ModPoints.COunt-1 do begin mp := TmodPoint(ModPOints[i]); if mp.isBlink then mp.isDraw := True; end; RedrawSelectionPoints; end; function TPCDrawing.IsBlinking: Boolean; begin result := FBlinkTimer.Enabled; end; procedure TPCDrawing.MoveAll(deltax, deltay: Double); var a: integer; begin if RecordUndo then RecordModifyUndo(nil); if assigned(FBeforeMoveAll) then FBeforeMoveAll(Self,deltaX,deltaY); if (deltaX = 0) and (deltaY = 0) then exit; for a := 0 to figures.count - 1 do begin TFigure(figures[a]).move(deltax,deltay); if assigned(FOnFigureMoved) then FOnFigureMoved(Self,TFigure(figures[a]),deltax,deltay); end; if assigned(FAfterMoveAll) then FAfterMoveAll(Self,deltaX,deltaY); Updated := True; end; function TPCDrawing.SelectionAsBitmap(dpi:Integer): TBitmap; var r: TDoubleRect; w,h: Double; dx,dy: Double; Begin dcDpm := dpi /25.4; r := GetSelectionRect; w := abs(r.right-r.Left); h := abs(r.top-r.bottom); result := TBitmap.Create; result.Width := Round(w * dcDpm)+1; result.Height := round(h * dcDpm)+1; if VerticalZero = vzBottom then dy := workheight-r.bottom else dy := r.top; if HorizontalZero = vzLeft then dx := r.left else dx := workwidth-r.right; dcConvertDim(dx); dcConvertDim(dy); dcCoordX := Round(-1*dx); dcCoordy := Round(-1*dy); SetEngine(result.Canvas,dcConvertXY,prDeConvertXY,dcConvertDim,prDeConvertDim,false,nil); DrawSelectedFigures; end; function TPCDrawing.DrawingasWmf(dpm: Double): TMetafile; var mf : TMetafile; mc : TMetafileCanvas; r: TDoubleRect; w,h: Double; dx,dy: Double; Begin mf := TMetafile.Create; dcDpm := dpm; r := GetDrawingRect; w := abs(r.right-r.Left); h := abs(r.top-r.bottom); mf.Width := Round(w * dcDpm)+1; mf.Height := round(h * dcDpm)+1; mc := TMetafileCanvas.Create(mf,0); if VerticalZero = vzBottom then dy := workheight-r.top else dy := r.bottom; if HorizontalZero = vzLeft then dx := r.left else dx := workwidth-r.right; dcConvertDim(dx); dcConvertDim(dy); dcCoordX := Round(-1*dx); dcCoordy := Round(-1*dy); SetEngine(mc,dcConvertXY,prDeConvertXY,dcConvertDim,dcDeConvertDim,false,nil); ResetRegions; DrawFigures; ResetRegions; mc.Free; result := mf; end; procedure TPCDrawing.dcDeConvertDim(var Dim: Double); begin Dim := Dim / (dcDpm*ConvertRatio); end; procedure TPCDrawing.CreateDimLinesOfSelection; var a: integer; begin if RecordUndo then RecordModifyUndo(nil); for a := 0 to Figures.count - 1 do begin if TFigure(Figures[a]).selected then begin TFigure(Figures[a]).CreateDimLines; end; end; refresh; Updated := True; end; procedure TPCDrawing.ClearDimLinesOfSelection; var a: integer; begin if RecordUndo then RecordModifyUndo(nil); for a := 0 to Figures.count - 1 do begin if TFigure(Figures[a]).selected then begin TFigure(Figures[a]).ClearDimLines; end; end; refresh; Updated := True; end; procedure TPCDrawing.CancelActions; begin //** end; function TPCDrawing.FigureAsWmf(FigHandle: TFigHandle;isGrayed:Boolean): TMetafile; var mf : TMetafile; mc : TMetafileCanvas; r: TDoubleRect; w,h: Double; dx,dy: Double; Figure: TFigure; Begin Figure := Tfigure(FigHandle); mf := TMetafile.Create; dcDpm := DotsPerMilOrig; r := Figure.GetBoundRect; w := abs(r.right-r.Left); h := abs(r.top-r.bottom); mf.Width := Round(w * dcDpm)+1; mf.Height := round(h * dcDpm)+1; mc := TMetafileCanvas.Create(mf,0); if VerticalZero = vzBottom then dy := workheight-r.top else dy := r.top; if HorizontalZero = vzLeft then dx := r.left else dx := workwidth-r.left; dcConvertDim(dx); dcConvertDim(dy); dcCoordX := Round(-1*dx); dcCoordY := Round(-1*dy); SetEngine(mc,dcConvertXY,prDeConvertXY,dcConvertDim,prDeConvertDim,false,nil); Figure.ResetRegion; Figure.Draw(Dengine,isGrayed); mc.Free; result := mf; SetBufferEngine; end; procedure TPCDrawing.SetFieldText(FName, FValue: String); var fig: TFigure; i: Integer; begin for i := 0 to Figures.Count-1 do begin fig := Tfigure(Figures[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 TPCDrawing.ExitClear; var a,cnt,b: integer; f: TFigure; begin // only called by destroy {cnt := figures.count; for a:= 0 to cnt-1 do begin b := cnt-1-a; f := TFigure(figures[b]); TFigure(figures[b]).deselect; TFigure(figures[b]).Deleted := True; TFigure(figures[b]).free; figures.Delete(b); end; } //Tolik //Tolik 08/11/2016-- // Tolik -- 16/03/2017 -- закомментил нафиг по той причине, что если Кад закроется на простом // закрытии проекта -- сработает ClearFiguresOnListDelete, где корректно удалятся все фигуры // если будет закрытие приложения -- вонда сама освободит занимаемые приложением ресурсы, // нефиг париться { try While Figures.Count > 0 do begin f := TFigure(figures[figures.Count - 1]); // TFigure(figures[figures.Count - 1]).deselect; figures.Delete(figures.Count - 1); //TFigure(figures[0]).Deleted := True; //TFigure(figures[b]).free; FreeAndNil(f); end; except on E: Exception do AddExceptionToLog('TPCDRawing.ExitClear: Figure Destroy Error!'); end;} { cnt := figures.count - 1; for a := cnt downto 0 do begin f := TFigure(figures[a]); TFigure(figures[a]).deselect; TFigure(figures[a]).Deleted := True; //TFigure(figures[b]).free; FreeAndNil(f); figures.Delete(a); end;} ClearGuides; end; 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 prDpm := prDpm * self.ZoomScale / 100 else begin // tolik 19/12/2020 -- {if self.ZoomScale < 400 then prDpm := prDpm * 4} { if self.ZoomScale < 400 then prDpm := prDpm * 4 else // prDpm := prDpm * self.ZoomScale / 100;} prDpm := prDpm * 4 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 := pf32bit; 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; { 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; // //maxv := 200000000; // Tolik 13/08/2019 -- //Result.PixelFormat := pf32bit; // //res1 := Round((WorkWidth) * prDpm) * Round((WorkHeight) * prDpm) * 32 div 8; { res1 := Round((WorkWidth) * prDpm) * Round((WorkHeight) * prDpm) * 4;//2 div 8; if res1 > maxv then begin //res1 := Round((WorkWidth) * prDpm) * Round((WorkHeight) * prDpm) * 24 div 8; res1 := Round((WorkWidth) * prDpm) * Round((WorkHeight) * prDpm) * 3;// div 8; if res1 > maxv then begin //res1 := Round((WorkWidth) * prDpm) * Round((WorkHeight) * prDpm) * 16 div 8; res1 := Round((WorkWidth) * prDpm) * Round((WorkHeight) * prDpm) * 2; if res1 > maxv then begin Result.PixelFormat := pf8bit; end else Result.PixelFormat := pf16bit; end else Result.PixelFormat := pf24bit; end;} //Result.Width := Round((WorkWidth) * prDpm); //Result.Height := round((WorkHeight) * prDpm); 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; function TPCDrawing.ImportDrawing(LayerNbr: Integer; x, y: Double; fName: String; Selected: Boolean): TFigHandle; var sBytes: array [1..8] of Byte; a,i: integer; Version: Word; SecCount: Byte; xSize: integer; SecStr: TMemoryStream; SecName: String; Stream: TfileStream; fCount: integer; Figure : TFigure; figStream:TMemoryStream; grp: TFigureGrp; LHandle: Integer; begin result := 0; grp := nil; try Stream := TFileStream.Create(fName,fmOpenRead); except exit; end; for a := 1 to 8 do Stream.Read(sBytes[a],1); for a := 1 to 8 do if sBytes[a] <> signBytes[a] then begin AddExceptionToLog('TPCDrawing.LoadFromStream'); // ShowMessage(emInvalidStream); // === Stream.Free; Exit; end; if (LayerNbr > -1) and (LayerNbr < Layers.Count) then LHandle := Integer(Layers[LayerNbr]) else LHandle := Integer(Layers[0]); Stream.Read(Version,2); Stream.Read(SecCount,1); for a := 1 to SecCount do begin Stream.Read(xSize,4); SecName := ReadStringFromStream(Stream); SecStr:= TMemoryStream.Create; StreamToStream(Stream,SecStr,xSize); SecStr.Seek(0,soFromBeginning); if SecName = 'Figures' then begin grp := TfigureGrp.create(lHandle,Self); SecStr.Read(fCount,4); For i := 1 to fCount do begin SecStr.Read(xSize,4); figStream := TMemoryStream.Create; StreamToStream(SecStr,figStream,xSize); figStream.Seek(0,soFromBeginning); Figure := nil; Figure := TFigure.CreateFromStream(figStream,0,mydsNormal,self); figStream.Free; if Figure <> nil then begin grp.AddToGrp(Figure); //28.04.2011 grp.InFigures.Add(Figure); end; end; end; SecStr.Free; end; if assigned(grp) then begin Figures.Add(grp); result := grp.Handle; if assigned(FOnObjectInserted) then FOnObjectInserted(Self,irLoad); Updated := True; end; Stream.Free; Refresh; end; procedure TPCDrawing.GotFocus(Sender: TObject); begin ResumeBlink; if FBlinkPaused then begin FBlinkPaused := False; StartBlink; end; end; function TPCDrawing.GetLayer(LayerNbr: integer): TLayer; Begin if (LayerNbr > LayerCount - 1) then begin result := nil; end else begin Result := TLayer(Layers[LayerNbr]); end; end; procedure TPCDrawing.SetActiveLayer(value: integer); var xLayer:TLayer; begin inherited; xLayer := GetLayer(ActiveLayer); if xLayer.LayerWidth <> 0 then WorkWidth := xLayer.LayerWidth; if xLayer.LayerHeight <> 0 then WorkHeight := xLayer.LayerHeight; end; function TPCDrawing.GetLayerNbr(xLayer: TLayer): integer; var a: integer; Begin result := -1; result := Layers.IndexOf(xLayer); end; procedure TPCDrawing.SimplfySelectedPolyline; var a: integer; xAction: TUndoAction; Found:Boolean; begin Found := False; if RecordUndo then xAction := TUndoAction.Create(uaModify); for a := 0 to Selection.Count-1 do begin if TFigure(Selection[a]) is TpolyLine then begin if RecordUndo then AddFigureToModifyUndo(xAction,Selection[a]); TpolyLine(Selection[a]).SimplfyPoints; Updated := True; Found := True; end; end; if not found then fDefPLineClosed := True; if RecordUndo then begin if xAction.List.Count > 0 then begin InsertUndoAction(xAction); end else begin xAction.Free; end; end; refresh; end; procedure TPCDrawing.CalibrateLayerScale(p1, p2: TDoublePoint;cUnit:Byte); var d: Double; begin d := GetLineLength(p1,p2); //cUnit: Byte = 0; // 0=nm 1=mm 2=cm 3=dm 4=m 5=km if assigned(FCalibrateLayer) then FCalibrateLayer(Self,ActiveLayer,d,cUnit); end; function TPCDrawing.GetFigureByDataID(aDataID: Integer): TFigure; var i: integer; Figure: TFigure; begin Result := nil; for i := 0 to Figures.Count - 1 do begin Figure := TFigure(Figures[i]); if Figure.DataID = aDataID then begin Result := Figure; Break; //// BREAK //// end; end; end; function TPCDrawing.GetForm: TForm; var Container: TWinControl; begin Result := nil; Container := Self; while Container <> nil do begin if Container is TForm then begin Result := TForm(Container); Break; //// BREAK //// end; Container := Container.Parent; end; end; function TPCDrawing.GetLineLengthM(p1, p2: TDoublePoint): Double; begin Result := GetLengthM(GetLineLenght(p1, p2)); end; function TPCDrawing.GetLengthM(aPCLen: Double): Double; begin Result := aPCLen / 1000 * Self.MapScale; end; procedure TPCDrawing.BeginMultiDeselect; begin // Tolik 15/06/2021 -- if Assigned(F_ProjMan) then begin if Assigned(F_ProjMan.Tree_Catalog) then //F_ProjMan.Tree_Catalog.Tag := 999; F_ProjMan.Timer_TreeCatalogChange.Tag := 999; F_ProjMan.Timer_Changing.Tag := 999; end; // if FMultiDeselectCount = 0 then FModPointsStartIdx := 0; Inc(FMultiDeselectCount); end; procedure TPCDrawing.EndMultiDeselect; begin if FMultiDeselectCount > 0 then begin Dec(FMultiDeselectCount); if FMultiDeselectCount = 0 then begin ModPoints.Pack; // ClearTreeSelection; // Tolik 25/11/2021 - - end; end; // Tolik 15/06/2021 -- if Assigned(F_ProjMan) then begin if Assigned(F_ProjMan.Tree_Catalog) then //F_ProjMan.Tree_Catalog.Tag := 0; F_ProjMan.Timer_TreeCatalogChange.Tag := 0; F_ProjMan.Timer_Changing.tag := 0; end; end; procedure TPCDrawing.SelectFigures(aFigures: TList); //11.05.2012 var i: integer; begin for i := 0 to aFigures.Count - 1 do TFigure(aFigures[i]).Select; end; procedure TPCDrawing.BeginUpdate; begin if FUpdateCountAdd >= 0 then begin Inc(FUpdateCount); end; Inc(FUpdateCountAdd); end; procedure TPCDrawing.EndUpdate(aReFresh: Boolean); begin if FUpdateCount > 0 then begin Dec(FUpdateCount); if FUpdateCount = 0 then if aReFresh then Self.Refresh; end; Dec(FUpdateCountAdd); end; function TPCDrawing.PointToScreen(aPt: TDoublePoint): TPoint; begin Self.ConvertXY(aPt.X, aPt.Y, aPt.Z); Result.x := Trunc(aPt.X); Result.Y := Trunc(aPt.Y); Result := Self.ClientToScreen(Result); end; function TPCDrawing.DoMagicWand(LayerNbr:Integer;x, y: Double): TFigHandle; var i: integer; rFigure,Figure : TFigure; begin result := 0; If (LayerNbr < 0) or (LayerNbr > Layers.Count - 1) then exit; for i:= 0 to Figures.Count-1 do begin figure := TFigure(figures[i]); if (figure.LayerHandle = Integer(Layers[LayerNbr])) and (figure is TBmpObject) then begin rFigure := TBmpObject(Figure).DoMagicWand(x,y); if assigned(rFigure) then begin result := rFigure.Handle; AddCustomFigure(LayerNbr,rFigure,True); Refresh; end; end; end; end; procedure TPCDrawing.PrintPageAsWmf; var mf, mfx: TMetafile; mc, mcx: TMetafileCanvas; a: integer; Layer: TLayer; p1, p2, p3, p4, xp1, xp2: TDoublePOint; wp1, wp2, wp3, wp4: TPoint; reg: HRGN; pw, ph, xw, xh, dx, dy: Double; i: Integer; xRect: Trect; ww,wh: Double; xCopy: Integer; prDpmx, prDpmY: Double; PlotRotate: Boolean; pCnt: Integer; dCnt: Double; Begin ResetRegions; mf := TMetafile.Create; prDpmx := (GetDeviceCaps(Printer.Handle, LOGPIXELSX) / 25.4); prDpmy := (GetDeviceCaps(Printer.Handle, LOGPIXELSY) / 25.4); if prDpmX > prDpmY then prDpm := prDpmX else prDpm := prDpmY; pw := (printer.PageWidth / prDpm); ph := (printer.PageHeight / prDpm); xCopy := PlotCopy; xw := (WorkHeight * PlotCopy); if (xw > pw) and (xCopy > 1) then begin xCopy := 1; // ShowMessage('Зoklu basэm iзin kaрэt geniюliрi uygun deрil.Gerekli Geniюlik:'+ // inttostr(round(xw)) + ' Mevcut Geniюlik:' + inttostr(round(pw))); end; mf.Width := Round(WorkWidth * prDpm); if xCopy = 1 then mf.Height := round(WorkHeight * prDpm) else mf.Height := round(pw * prDpm); mc := TMetafileCanvas.Create(mf, 0); SetEngine(mc, prConvertXY, prDeConvertXY, prConvertDim, prDeConvertDim, false, nil); {$ifndef designtime} PenRatio := prDpm * ThickUnit; {$endif designtime} dx := printer.PageWidth / xCopy; for i := 1 to xcopy do begin MCopyDelta := (i - 1) * (-dx); DrawFigures; end; TileY := 0; MCopyDelta := 0; ww := workwidth; wh := workheight; if xCopy > 1 then wh := pw; {$ifndef designtime} PenRatio := 1; {$endif designtime} mc.Free; p1 := DoublePOint(0, 0); p2 := DoublePOint(ww, 0); p3 := DoublePOint(ww, wh); p4 := DoublePoint(0, wh); plotRotate := False; if (pw < ww) and (ph > wh) then begin p4 := DoublePOint(0, 0); p1 := DoublePOint(wh, 0); p2 := DoublePOint(wh, ww); p3 := DoublePoint(0, ww); plotRotate := True; end else if (pw > WorkWidth) and (ph < WorkHeight) then begin p4 := DoublePOint(0, 0); p1 := DoublePOint(wh, 0); p2 := DoublePOint(wh, ww); p3 := DoublePoint(0, ww); end else if (pw < ww - 10) and (ph < wh - 10) then begin p1 := DoublePOint(0, 0); p2 := DoublePOint(pw, 0); p3 := DoublePOint(pw, ph); p4 := DoublePoint(0, ph); end else if (pw > ph) and (WorkWidth > WorkHeight) then begin dy := ph - WorkHeight - 10; p1 := MovePoint(p1, 0, dy); p2 := MovePoint(p2, 0, dy); p3 := MovePoint(p3, 0, dy); p4 := MovePoint(p4, 0, dy); end; //mf.SaveToFile('c:\deneme.wmf'); SetEngine(Printer.Canvas, prConvertXY, prDeConvertXY, prConvertDim, prDeConvertDim, true, nil); reg := 1; DEngine.DrawMetafile(p1, p2, p3, p4, clWhite, 1, ord(psClear), mf, true, reg); if plotRotate and (ph < WorkWidth - 50) then begin dCnt := (WorkWidth / ph); if Trunc(dCnt) <> dCnt then pCnt := Trunc(Dcnt) + 1 else pCnt := Trunc(dCnt); for i := 1 to pCnt - 1 do begin printer.EndDoc; printer.BeginDoc; p1 := MovePoint(p1, 0, -ph); p2 := MovePoint(p2, 0, -ph); p3 := MovePoint(p3, 0, -ph); p4 := MovePoint(p4, 0, -ph); SetEngine(Printer.Canvas, prConvertXY, prDeConvertXY, prConvertDim, prDeConvertDim, true, nil); DEngine.DrawMetafile(p1, p2, p3, p4, clWhite, 1, ord(psClear), mf, true, reg); end; end; mf.Free; ResetRegions; refresh; end; procedure TPCDrawing.NameSelection; var fig: TFigure; xName:String; begin if Selection.Count = 0 then exit; fig := Tfigure(Selection[0]); xName := fig.Name; xName := InputBox('Edit Name','Enter the new name for the selected figure',xName); fig.Name := xName; end; function TPCDrawing.GetBrushPatCount: Integer; begin result := BrushList.Count; end; procedure TPCDrawing.ResumeBlink; begin if FBlinkPaused then begin FBlinkPaused := False; StartBlink; end; end; procedure TPCDrawing.TestPrinter; var prW,prH: Double; resW,resH,mW,mH: Integer; Begin tileY := 0; tileX := 0; MCopyDelta := 0; Printer.BeginDoc; Printer.Canvas.Ellipse(50-2,100-2,50+2,100+2); Printer.Canvas.TextOut(50,100,'C(50,100)'); Printer.Canvas.Ellipse(50-2,Printer.PageHeight - 600-2,50+2,Printer.PageHeight - 600+2); Printer.Canvas.TextOut(50 ,Printer.PageHeight - 600,'C(50,'+inttostr(Printer.PageHeight-600)+')'); Printer.Canvas.Ellipse(Printer.PageWidth-650-2,Printer.PageHeight - 600-2,Printer.PageWidth-650+2,Printer.PageHeight - 600+2); Printer.Canvas.TextOut(Printer.PageWidth-650 ,Printer.PageHeight - 600,'C('+inttostr(Printer.PageWidth-650)+','+inttostr(Printer.PageHeight-600)+')'); Printer.Canvas.Ellipse(Printer.PageWidth-650-2,100-2,Printer.PageWidth-650+2,100+2); Printer.Canvas.TextOut(Printer.PageWidth-650 ,100, 'C('+inttostr(Printer.PageWidth-650)+',100)'); Printer.Canvas.Ellipse(Printer.PageWidth div 2-2 ,Printer.PageHeight div 2-2,Printer.PageWidth div 2+2 ,Printer.PageHeight div 2+2); Printer.Canvas.TextOut(Printer.PageWidth div 2 ,Printer.PageHeight div 2,'C('+inttostr(Printer.PageWidth div 2)+','+inttostr(Printer.PageHeight div 2)+')'); Printer.EndDoc; end; procedure TPCDrawing.AlignPageDown; var dRect:TDoubleRect; dx,dy: Double; begin dRect := GetDrawingRect; dy := WorkHeight -10 - dRect.Bottom; dx := 0; DeltaMoveX := dx; DeltaMoveY := dy; MoveAllSilent(dx,dy); end; procedure TPCDrawing.AlignPageUp; var dRect:TDoubleRect; dx,dy: Double; begin dRect := GetDrawingRect; dy := - dRect.Top+5; dx := 0; DeltaMoveX := dx; DeltaMoveY := dy; MoveAllSilent(dx,dy); end; procedure TPCDrawing.MoveAllSilent(deltax, deltay: Double); var a: integer; begin if (deltaX = 0) and (deltaY = 0) then exit; for a := 0 to figures.count - 1 do begin TFigure(figures[a]).move(deltax,deltay); end; Updated := True; end; procedure TPCDrawing.PrintDrawingAsWmf(TitleinStatusBox: String); var prW,prH: Double; resW,resH,mW,mH: Integer; //Log: TStringList; Begin tileY := 0; tileX := 0; MCopyDelta := 0; //Log := TStringList.Create; Printer.BeginDoc; Printer.Title := TitleinStatusBox; //Log.Add('Calling PrintPageAsWmf'); PrintPageAsWmf; Printer.EndDoc; //Log.SaveToFile('c:\plotWmf.txt'); //Log.Free; end; function TPCDrawing.DrawingasWmf: TMetafile; var mf : TMetafile; mc : TMetafileCanvas; r: TDoubleRect; w,h: Double; dx,dy: Double; Begin mf := TMetafile.Create; dcDpm := DotsPerMilOrig; r := GetDrawingRect; w := abs(r.right-r.Left); h := abs(r.top-r.bottom); mf.Width := Round(w * dcDpm)+1; mf.Height := round(h * dcDpm)+1; mc := TMetafileCanvas.Create(mf,0); mc.Brush.Color := PageColor; mc.Brush.Style := bsSolid; mc.FillRect(Rect(1, 1, Round(w * dcDpm) + 1, round(h * dcDpm) + 1)); if VerticalZero = vzBottom then dy := workheight-r.bottom else dy := r.top; if HorizontalZero = vzLeft then dx := r.left else dx := workwidth-r.right; dcConvertDim(dx); dcConvertDim(dy); dcCoordX := Round(-1*dx); dcCoordy := Round(-1*dy); SetEngine(mc,dcConvertXY,prDeConvertXY,dcConvertDim,prDeConvertDim,false,nil); ResetRegions; DrawFigures; ResetRegions; mc.Free; result := mf; refresh; end; procedure TPCDrawing.SetSelectionGradient(GStyle: TGradStyle; ForeColor, BackColor: TColor); var i: Integer; begin for i := 0 to Selection.Count-1 do begin TFigure(Selection[i]).SetGradient(GStyle,ForeColor,BackColor); end; Refresh; end; procedure TPCDrawing.SetSelectionHatch(HStyle: THatchStyle; ForeColor, BackColor: TColor; StepSize: Double); var i: Integer; begin for i := 0 to Selection.Count-1 do begin TFigure(Selection[i]).SetHatch(HStyle,ForeColor,BackColor,StepSize); end; Refresh; end; procedure TPCDrawing.SetSelectionTexture(TStyle: TTextureStyle; TexSize: Integer); var i: Integer; begin for i := 0 to Selection.Count-1 do begin TFigure(Selection[i]).SetTexture(TStyle,TexSize); end; Refresh; end; function TPCDrawing.SelectionAsBmpHandle(dpi: Integer): Integer; var xbmp:TBitmap; begin xBmp := nil; xBmp := SelectionAsBitmap(Dpi); if assigned(xBmp) then result := xBmp.Handle else result := 0; end; function TPCDrawing.DrawingAsMetaFile: Integer; var xwmf:TMetafile; begin xWmf := nil; xWmf := DrawingAsWmf; if assigned(xWmf) then result := xWmf.Handle else result := 0; end; function TPCDrawing.FigureAsMetaFile(FigHandle:TFigHandle): Integer; var xwmf:TMetafile; begin xWmf := nil; xWmf := FigureAsWmf(FigHandle,False); if assigned(xWmf) then result := xWmf.Handle else result := 0; end; function TPCDrawing.CreatePreviewBitmapHandle: Integer; begin result := CreatePreviewBitmap.Handle; end; function TPCDrawing.InsertBitmapHandle(LayerNbr: Integer; x, y: Double; xBitmap: HBitmap; transparent, selected: boolean): TFigHandle; var bmp:TBitmap; begin bmp := TBitmap.Create; bmp.Handle := xBitmap; result := InsertBitmapHandle(LayerNbr,x,y,bmp,transparent,selected); end; procedure TPCDrawing.Clear(LayerNbr: integer); begin Clear(LayerNbr,False); end; // Tolik ??? что-то здесь как-то странно реализовано..... // имхо фигуры никуда не делись, список как создался, так и очистился, а нах? procedure TPCDrawing.ClearFigures; var i: integer; FFigure: TFigure; FigList: TList; begin FigList := TList.Create; for i := 0 to Self.FigureCount - 1 do begin FFigure := TFigure(Self.Figures[i]); FigList.Add(FFigure); end; for i := 0 to FigList.Count - 1 do begin FFigure := TFigure(FigList[i]); Figures.Remove(FFigure); end; FigList.Free; Self.Refresh; end; procedure TPCDrawing.ClearNoRect(ARect: TDoubleRect); begin Dengine.drawrect(ARect.Right, ARect.Top, WorkWidth, WorkHeight, clWhite, 1, Ord(psSolid), clWhite, Ord(psSolid)); Dengine.drawrect(ARect.Left, ARect.Bottom, WorkWidth, WorkHeight, clWhite, 1, Ord(psSolid), clWhite, Ord(psSolid)); //ClearReg(x2, y1, WorkWidth, WorkHeight); //ClearReg(x1, y2, WorkWidth, WorkHeight); end; procedure TPCDrawing.DrawFigures; begin // IGOR - для нормального экспорта цветных УГОшек //Важно - нужно сбросить регионы до и после экспорта на канвас с другими размерами и конвертациями ResetRegions; DrawFigures(False); ResetRegions; end; { TlistMod } destructor TlistMod.Destroy; begin inherited; end; function TlistMod.RemoveItem(Item: Pointer): Integer; begin Result := IndexOf(Item); if Result >= 0 then begin Delete(Result); // TFigure(Item).Destroy; end; end; function TPCDrawing.SaveSCSFiguresToFile(FileName: string): Boolean; var a, fCount: integer; Figure: TFigure; xSize: Integer; FileStream: TStream; Stream: TMemoryStream; figStream: TMemoryStream; LHandle2: Integer; LHandle3: Integer; LHandle4: Integer; LHandle5: Integer; LHandle6: Integer; LHandle8: Integer; LHandle9: Integer; isFigureShadowObj: boolean; begin Result := false; try // получить Handles для каждого сохраняемого нами слоя LHandle2 := GetLayerHandle(2); LHandle3 := GetLayerHandle(3); LHandle4 := GetLayerHandle(4); LHandle5 := GetLayerHandle(5); LHandle6 := GetLayerHandle(6); LHandle8 := GetLayerHandle(8); LHandle9 := GetLayerHandle(9); fCount := Figures.Count; // отобрать лист с сохраняемыми объектами For a := 0 to fCount - 1 do begin Figure := TFigure(Figures[a]); // проверить относиться ли объект к сохраняемому слою if (Figure.LayerHandle = LHandle2) or (Figure.LayerHandle = LHandle3) or (Figure.LayerHandle = LHandle4) or (Figure.LayerHandle = LHandle5) or (Figure.LayerHandle = LHandle6) or (Figure.LayerHandle = LHandle8) or (Figure.LayerHandle = LHandle9) then begin isFigureShadowObj := False; if TFigure(Figures[a]) is TFigureGrpNotMod then if TFigureGrpNotMod(Figures[a]).InFigures.Count = 1 then begin if TFigure(TFigureGrpNotMod(Figures[a]).InFigures[0]).ClassName = 'TLine' then begin isFigureShadowObj := True; end; end; if not isFigureShadowObj then GCadForm.FUndoFiguresList.Add(Figure); { begin //if (Figure.Classname = 'TConnectorObject') or (Figure.Classname = 'TOrthoLine') then // if ((Figure.Classname = 'TNet') or (Figure.Classname = 'TCabinet')) then // if Figure.Classname = 'TFigureGrpMod' then if Figure.Classname = 'TFigureGrpNotMod' then begin if TFigureGrpNotMod(Figure).InFigures.Count > 0 then if TFigure(TFigureGrpNotMod(Figure).InFigures[0]).ClassNAme <> 'TRectangle' then GCadForm.FUndoFiguresList.Add(Figure); end; end; } end; end; // из этого листа сделать сохранение GCadForm.FUndoStatus := True; // FileStream := TFileStream.Create(FileName, fmCreate); FileStream := SafeOpenFileStream(FileName, fmCreate, 'TPCDrawing.SaveSCSFiguresToFile', cSCSComponent_Msg22_7); if FileStream <> nil then begin //FileStream.Write(fCount, 4); // Tolik 03/02/2017 -- FileStream.Write(Self.FMapscale, 8); // FileStream.Write(GCadForm.FUndoFiguresList.Count, 4); For a := 0 to GCadForm.FUndoFiguresList.Count - 1 do begin Figure := TFigure(GCadForm.FUndoFiguresList[a]); if Figure <> nil then if not Figure.Deleted then begin figStream := TMemoryStream.Create; Figure.WriteToStream(figStream); xSize := figStream.Size; figStream.Seek(0, soFromBeginning); FileStream.Write(xSize, 4); StreamToStream(figStream, FileStream, xSize); if assigned(FOnObjectSaved) then FOnObjectSaved(self, Figure); FreeAndNil(figStream); end; end; FreeAndNil(FileStream); Result := true; end; except on E: Exception do AddExceptionToLog('TPCDrawing.SaveSCSFiguresToFile' + E.Message); end; GCadForm.FUndoStatus := False; end; function TPCDrawing.SavePlanFiguresToFile(FileName: string): Boolean; var a, fCount: integer; Figure: TFigure; xSize: Integer; FileStream: TStream; Stream: TMemoryStream; figStream: TMemoryStream; LHandle1: Integer; begin Result := false; try // получить Handles для каждого сохраняемого нами слоя LHandle1 := GetLayerHandle(1); fCount := Figures.Count; // отобрать лист с сохраняемыми объектами For a := 0 to fCount - 1 do begin Figure := TFigure(Figures[a]); // проверить относиться ли объект к сохраняемому слою if (Figure.LayerHandle = LHandle1) then begin GCadForm.FUndoFiguresList.Add(Figure); end; end; // из этого листа сделать сохранение GCadForm.FUndoStatus := True; // FileStream := TFileStream.Create(FileName, fmCreate); FileStream := SafeOpenFileStream(FileName, fmCreate, 'TPCDrawing.SavePlanFiguresToFile', cSCSComponent_Msg22_7); if FileStream <> nil then begin //FileStream.Write(fCount, 4); // Tolik -- 03/02/2017 -- FileStream.Write(Self.FMapscale, 8); // FileStream.Write(GCadForm.FUndoFiguresList.Count, 4); For a := 0 to GCadForm.FUndoFiguresList.Count - 1 do begin Figure := TFigure(GCadForm.FUndoFiguresList[a]); begin figStream := TMemoryStream.Create; Figure.WriteToStream(figStream); xSize := figStream.Size; figStream.Seek(0, soFromBeginning); FileStream.Write(xSize, 4); StreamToStream(figStream, FileStream, xSize); if assigned(FOnObjectSaved) then FOnObjectSaved(self, Figure); FreeAndNil(figStream); end; end; FreeAndNil(FileStream); Result := true; end; except on E: Exception do AddExceptionToLog('TPCDrawing.SavePlanFiguresToFile' + E.Message); end; GCadForm.FUndoStatus := False; end; // Tolik 12/02/2021 -- function TPCDrawing.SaveElSchemeFiguresToFile(FileName: string): Boolean; // Tolik -- 12/02/2021 var a, fCount: integer; Figure: TFigure; xSize: Integer; FileStream: TStream; Stream: TMemoryStream; figStream: TMemoryStream; LHandle1: Integer; begin Result := false; try // получить Handles для каждого сохраняемого нами слоя LHandle1 := GetLayerHandle(1); //LHandle1 := GetLayerHandle(0); // Tolik 01/06/2021 -- тут список слоев идет с нуля (0 - подложка) fCount := Figures.Count; // отобрать лист с сохраняемыми объектами For a := 0 to fCount - 1 do begin Figure := TFigure(Figures[a]); // проверить относиться ли объект к сохраняемому слою if (Figure.LayerHandle = LHandle1) then begin GCadForm.FUndoFiguresList.Add(Figure); end; end; // из этого листа сделать сохранение GCadForm.FUndoStatus := True; // FileStream := TFileStream.Create(FileName, fmCreate); FileStream := SafeOpenFileStream(FileName, fmCreate, 'TPCDrawing.SaveElSchemeFiguresToFile', cSCSComponent_Msg22_7); if FileStream <> nil then begin //FileStream.Write(fCount, 4); // Tolik -- 03/02/2017 -- FileStream.Write(Self.FMapscale, 8); // FileStream.Write(GCadForm.FUndoFiguresList.Count, 4); For a := 0 to GCadForm.FUndoFiguresList.Count - 1 do begin Figure := TFigure(GCadForm.FUndoFiguresList[a]); begin figStream := TMemoryStream.Create; Figure.WriteToStream(figStream); xSize := figStream.Size; figStream.Seek(0, soFromBeginning); FileStream.Write(xSize, 4); StreamToStream(figStream, FileStream, xSize); if assigned(FOnObjectSaved) then FOnObjectSaved(self, Figure); FreeAndNil(figStream); end; end; FreeAndNil(FileStream); Result := true; end; except on E: Exception do AddExceptionToLog('TPCDrawing.SaveElSchemeFiguresToFile' + E.Message); end; GCadForm.FUndoStatus := False; end; procedure TPCDrawing.LoadSCSFiguresFromFile(FileName: string); var a, fCount: integer; Figure: TFigure; xSize: Integer; Stream: TMemoryStream; FileStream: TStream; figStream: TMemoryStream; // Tolik 28/08/2019 -- //OldTick, CurTick: cardinal; OldTick, CurrTick: DWord; begin try // FileStream := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite); FileStream := SafeOpenFileStream(FileName, fmOpenRead or fmShareDenyWrite, 'TPCDrawing.LoadSCSFiguresFromFile', cSCSComponent_Msg22_13); if FileStream <> nil then begin // Tolik -- 03/02/2017 -- FileStream.Read(Self.FMapscale, 8); // FileStream.Read(fCount, 4); For a := 1 to fCount do begin FileStream.Read(xSize,4); figStream := TMemoryStream.Create; StreamToStream(FileStream, figStream, xSize); figStream.Seek(0, soFromBeginning); Figure := nil; Figure := TFigure.CreateFromStream(figStream, 0, mydsNormal, self); FreeAndNil(figStream); if Figure <> nil then begin Figures.Add(Figure); GCadForm.FUndoFiguresList.Add(Figure); if assigned(FOnObjectInserted) then FOnObjectInserted(self, irLoad); end; end; FreeAndNil(FileStream); end; except on E: Exception do AddExceptionToLog('TPCDrawing.LoadSCSFiguresFromFile' + E.Message); end; end; initialization {$ifdef demo} if not delphiloaded then application.terminate; {$endif demo} {$ifdef 3D} // !!!! НЕЛЬЗЯ ЗДЕСЬ ЭТО ДЕЛАТЬ - падает ДЛЛ на вин7 64-ке ! //frm3D := Tfrm3d.Create(application); {$endif 3D} finalization end.