unit PCDrawBox; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, U_Common_Classes, ExtCtrls, PCPanel,PCScrollbar,math,PCTypesUtils,PaintBoxExt,StdCtrls,DrawEngine,DrawObjects; type TGuideLine = class(TMyObject) gType : TGuideType; coord : Double; fautoCr: boolean; constructor create(aType: TGuideType; aCoord: Double; autoCr: boolean = False); destructor destroy; Procedure WriteToStream(Stream: TStream); Class Function CreateFromStream(Stream: TStream): TGuideLine; end; TScrollValuesEvent = Procedure (Sender:TObject;ScHorzMAx,scVertMax,scHorzPos,scVertPos,scHorzPage,scVertPage,sChange,lChange:Integer) of Object; TCursorEvent = Procedure (Sender:TObject;Cursor:TCursor) of Object; TCustomTraceEvent = Procedure (Sender:TObject;x,y:Integer;dx,dy:Double;xCanvas:TCanvas) of Object; TCustomTraceEventVB = Procedure (Sender:TObject;x,y:Integer;dx,dy:Double;Dc:Integer) of Object; (*vbclassexport begin*) TPCDrawBox = class(TPCPanel) private { Private declarations } SOnMouseTrace : TMouseTraceEvent; SOnMousePush : TMousePushEvent; SOnMousePull : TMousePullEvent; SOnMouseLeave : TNotifyEvent; SOnMouseClick : TNotifyEvent; SOnMouseDblClick : TNotifyEvent; SOnDropDrag : TDropDragEvent; SOnDragTrace : TDragTraceEvent; SOnDragEnd : TDragEndEvent; SOnDragStart: TDragStartEvent; SOnScale: TNotifyEvent; FBeforePaint: TNotifyEvent; FScrollBars: Boolean; FSurfaceMArgin: Integer; FRulerSystem : TRulerSystem; FActiveLayer : integer; yold,xold,GuidexOld,GuideYold: integer; SnapX,SnapY: Integer; SnapXold,SnapYold: Integer; FVertBarVisible,FHorzBarVisible: Boolean; FWorkHeight,FWorkWidth : Double; FScale : integer; FDpmOrig : Double; OldCursor: TCursor; PageLeft,PageTop,PageWidth,PageHeight: integer; FGuides,Fgrids,FCenterGuide: Boolean; FBackGround,FGridColor,FGuideColor : TColor; FGridStep: Double; FGridType: TGridType; FOrient : TPageOrient; FLayout : TPageLayout; FguideTrace: TGuideTraces; FSnapToGuides: boolean; FSnapToNPoint: boolean; FSnapToGrids : Boolean; FCustomGuideTrace: TCustomTraceEvent; FCustomGuideTraceVB: TCustomTraceEventVB; FPageColor: TColor; FbarsLocked: Boolean; FScrollValues: TScrollValuesEvent; FCursorChange: TCursorEvent; ScHorzMAx,scVertMax,scHorzPos,scVertPos,scHorzPage,scVertPage: Integer; scHorzWidth,scVertHeight:Integer; vsRgn,hsRgn: HRGN; rVRgn,rHRgn: HRGN; FShadow: Boolean; RulerMode: Integer; RulerMapScale: Double; FRulerColor: TColor; FCoordZ: Double; FDetailStyle: TDetailStyle; FIsometric: Boolean; FDrawPageBorder: Boolean; FdrawInCursor: Boolean; FPageGuide: Boolean; Procedure setSnapToNPoint(value: boolean); Procedure setSnapToGuides(value: boolean); Procedure setSnapToGrids(value: boolean); Procedure setHorzBarVisible(value: Boolean); Procedure setVertBarVisible(value: Boolean); Procedure LostFocus(sender:Tobject); Procedure SetScrollBars(value: Boolean); Procedure DrawToCanvas(Canvas:TCanvas); Procedure ZoomCenter; Procedure SetScrolls(SHorzMAx,SVertMax,SHorzPos,SVertPos,SHorzPage,SVertPage:Integer); procedure setCenterGuide(const Value: Boolean); procedure setRulerColor(const Value: TColor); procedure setCoordZ(const Value: Double); procedure SetRulerSytem(const Value: TRulerSystem); procedure SetDetailStyle(const Value: TDetailStyle); Procedure CalculateDetailMargins(ReScale:Boolean=False); Procedure CalculateIsometricmargins; procedure setIsometric(const Value: Boolean); procedure setPageborder(const Value: Boolean); procedure SetDrawInCursor(const Value: Boolean); procedure setPageGuide(const Value: Boolean); procedure SetDpmOrig(const Value: Double); function GetToolData: Integer; protected { Protected declarations } ZoomPointFlag :Boolean; ZoomPoint :TDoublePoint; BaseBitmap: TBitmap; TempBitmap :TBitmap; FToolIdx : TPCTool; FToolInfo: String; FToolData:LongInt; FBlockDrop:String; // IsDragging: Boolean; cRgn: HRGN; FDetail: Boolean; FDetailWidth: Integer; FDetailHeight: Integer; FDetailScale: Integer; FDetailTop : Double; FDetailLeft: Double; FDetailPosX: Integer; FDeTailPosY: Integer; FDetMarX,FDetMarY:Double; FIsoMarX,FIsoMarY:Double; CurrentZ: Double; CurrentModPoint: TModPoint; CurrentIsoFigure: TFigure; ZoomDp: TDoublePoint; scHorzPosSave :Integer; scVertPosSave :Integer; Procedure DrawTrace;virtual; Procedure SetActiveLayer(value: integer);virtual; Function GetLayerCount:integer;virtual; Procedure DrawGrids(Canvas:TCanvas); Procedure DrawGuides(Canvas:TCanvas); procedure DrawGuidesTop(Canvas: TCanvas); procedure DrawCenterGuide(Canvas:TCanvas); procedure SetEngine(xCanvas: TCanvas; CPoint,DeCPoint:ConvertXYProc; CDim,DeCDim:ConvertDimProc;isPrinting: Boolean; prBmp: TBitmap); Procedure SetDefaultEngine; Procedure SetForceDefaultEngine; Procedure SetDetailEngine; Procedure SetBufferEngine; Procedure SetForceBufferEngine; Procedure SetBufferDetailEngine; Procedure KillTraceFigure;virtual; Procedure ClipToActiveRegion(xCanvas:TCanvas=nil); Procedure ClipToUnScrollRegion(xCanvas:TCanvas=nil); Procedure ClipToDetailRegion(xCanvas:TCanvas=nil); Procedure unClip(xCanvas:TCanvas=nil); Procedure DrawRulersToCanvas(Canvas:TCanvas); Procedure DrawScrollsToCanvas(Canvas: TCanvas; DoubleBuffered: Boolean; hpressed, vpressed: Boolean); Procedure DoPageLocate; Procedure SurfaceResize(sender: TObject); Procedure SetScale(value: integer);virtual; Procedure DoZoomDelta(Delta:Integer); Procedure DoZoomIn;override; Procedure DoZoomOut;override; Procedure DoZoomArea;override; Procedure DoZoomActualSize;override; Procedure DoZoomFitToWindow;override; Function DoKeyEvents(Message: TWMKey): Boolean;override; Function GetBackColor:TColor;override; Procedure setBg(value: Tcolor); procedure setShadow(const Value: Boolean); procedure setPageColor(Value: TColor); Procedure setGuides(value: Boolean); Procedure setGrids(value: Boolean); Procedure SetGridType(value:TGridType); Procedure setGColor(value: TColor); Procedure setGuideColor(value: TColor); Procedure setGStep(value: Double); Procedure setlayout(value : TPageLayout); Procedure setwHeight(value: Double); Procedure setwWidth(value: Double); Procedure setorient(Value : TPageOrient); Procedure setGTrace(value: TGuideTraces); // Procedure CheckToSnap(var X,Y:Double);virtual; // Procedure CalculateSnapPoint(var X,Y:Double);virtual; Procedure SurfaceMove(Sender: TObject;Shift: TShiftState; X, Y: Integer); Procedure SurfaceMouseMove(Sender: TObject;Shift: TShiftState; X, Y: Integer); Procedure SurfaceClick(Sender:TObject); Procedure SurfaceDblClick(Sender:TObject); Procedure SurfaceLeave(Sender: TObject); Procedure SurfaceDragDrop(Sender, Source: TObject; X,Y: Integer); Procedure SurfaceDragEnd(Sender, Target: TObject; X,Y: Integer); Procedure SurfaceDragOver(Sender, Source: TObject; X,Y: Integer; State: TDragState; var Accept: Boolean); Procedure SurfaceDragStart(Sender: TObject;var DragObject: TDragObject); Procedure SurfacePull(Sender: TObject;Button: TMouseButton; Shift: TShiftState; X, Y: Integer); Procedure SurfacePush(Sender: TObject;Button: TMouseButton; Shift: TShiftState; X, Y: Integer); Procedure DragMove(x,y:Integer); Procedure DragDropped(x,y:Integer); Procedure SurfaceMouseWheel(Sender: TObject; Shift: TShiftState; WheelDelta: Integer; MousePos: TPoint; var Handled: Boolean); Procedure CadMouseWheel(Sender: TObject; Shift: TShiftState; WheelDelta: Integer; MousePos: TPoint; var Handled: Boolean); Procedure MSPush(sender: TObject;Button: TMouseButton; Shift: TShiftState; X, Y: Double);virtual; procedure MSTrace(Sender: TObject; Shift: TShiftState; X,Y: Double);virtual; procedure MSPull(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Double);virtual; procedure MSDropDrag(Sender:Tobject; Source: Integer; X, Y: Double);virtual; procedure MSDragOver(Sender:TObject; Source: Integer; X, Y: Double;State: TDragState; var Accept: Boolean);virtual; procedure MSEndDrag(Sender, Target: TObject; X, Y: Double);virtual; procedure MSStartDrag(Sender: TObject;var DragObject: TDragObject);virtual; procedure MSClick(Sender: TObject);virtual; procedure MSDblClick(Sender: TObject);virtual; Procedure MSLeave(Sender: TObject);virtual; Procedure DoSurfacePaint(Sender: TObject); virtual; Procedure DrawguideTrace(x,y: integer); Procedure Refresh;override; Procedure SyncEnv;override; Procedure ResetActions;virtual; Procedure ResetRegions;virtual; Function SnapToFigures(var x,y: Double):Boolean;virtual; // Procedure DrawGuideOnSurface(x,y:Integer;guType:TGuideType); Procedure SetRulerValues(MapScale: Double; Mode: Integer); procedure SetDetail(const Value: Boolean); procedure setDetailHeight(const Value: Integer); procedure setDetailWidth(const Value: Integer); procedure SetDetailScale( Value: Integer); Procedure GotFocus(Sender:TObject);virtual; Function GetZAvg(dRect:TDoubleRect):Double;virtual; Procedure GetIsometricBounds(var MinX,MinY,MaxX,MaxY: Double);virtual; Property HorzBarVisible: Boolean read FHorzBarVisible write setHorzBarVisible; Property VertBarVisible: Boolean read FVertBarVisible write setVertBarVisible; public { Public declarations } IsDragging: Boolean; DrawBars:Boolean; CurrentUserClass: String; evGrids : TEventEngine; evGridType : TEventEngine; evGuides : TEventEngine; evCenterGuide: TEventEngine; evSnapGrids : TEventEngine; evSnapGuides : TEventEngine; evSnapObject : TEventEngine; evGridColor : TEventEngine; evGuideColor : TEventEngine; evBackColor : TEventEngine; evPageColor : TEventEngine; evGuideTrace : TeventEngine; evPageLo : TeventEngine; evPageOr : TeventEngine; SurfaceHandle: HWND; Surface: TPaintBoxExt; DEngine: TPCDrawEngine; SnapLocked: Boolean; DetailHit: Boolean; DetailHitPoint:Tpoint; SnapInfo: String; DetailActive: Boolean; IsoAngle : Double; IsoType : Byte; Guides: TList; GuidesCreatedOnDropCompon: TList; MaxScale: Integer; //16.12.2011 FGrayedColor: TColor; //06.08.2012 - Цвет прозрачности FResetRegionsOnZoomScroll: Boolean; //07.08.2012 - Вызывать ResetRegions на масштабировании/скроле Procedure DrawGuideOnSurface(x,y:Integer;guType:TGuideType; needDraw: boolean = True); Procedure SurfaceMiddleDblClick(Sender:TObject); Procedure SaveScroll;(*vb*) Procedure RestoreScroll;(*vb*) Function GetActiveCanvas:TCanvas; Procedure ReLocate;(*vb*) Procedure SetCustomSurface(CWindow:HWnD; CDC:HDC);override;(*vb*) Procedure DoSurfaceMove(Shift:Integer; X,Y: Integer);(*vb*) Procedure DoSurfaceClick;(*vb*) Procedure DoSurfaceDblClick;(*vb*) Procedure DoSurfaceLeave;(*vb*) Procedure DoSurfaceDragDrop(Source:Integer; X,Y: Integer);(*vb*) Procedure DoSurfaceDragEnd(X,Y: Integer); Procedure DoSurfaceDragOver(Source:Integer; X,Y: Integer; State: Integer; var Accept: Boolean); Procedure DoSurfaceDragStart(Sender: TObject;var DragObject: TDragObject); Procedure DoSurfacePull(Button: Integer; Shift: Integer; X, Y: Integer);(*vb*) Procedure DoSurfacePush(Button: Integer; Shift: Integer; X, Y: Integer);(*vb*) Procedure DoSurfaceWheel(Shift: Integer; WheelDelta: Integer;X,Y:Integer);(*vb*) Procedure DoSurfaceWheelPull(Shift: Integer; X, Y: Integer); Procedure DoSurfaceWheelPush(Shift: Integer; X, Y: Integer); Procedure SurfaceWheel(Shift: TShiftState; WheelDelta: Integer; MousePos: TPoint); Procedure SurfaceWheelPull(Shift: TShiftState; X, Y: Integer); Procedure SurfaceWheelPush(Shift: TShiftState; X, Y: Integer); //Вынес в Паблик, потому что в модуле U_CAD через переменную PCad нужно заюзать их Procedure CheckToSnap(var X,Y:Double);virtual; // Procedure CalculateSnapPoint(var X,Y:Double);virtual; Function CalculateSnapPoint(var X,Y:Double): Boolean;virtual; Function DoKeyStroke(ChCode:Integer;Shift:Integer):Boolean;virtual;(*vb*) Function CheckForGuideDrop(X,Y: Integer; autoCr: boolean = False):Boolean;(*vb*) Function CheckAndGetGuideDrop(X,Y: Integer; var GuideLine: TGuideLine; autoCr: boolean = False): Boolean; Procedure DragStarted;virtual;(*vb*) Function GetSelectionRect:TDoubleRect;virtual;(*vb*) Function GetDrawingRect:TDoubleRect;virtual;(*vb*) Function GetVisibleRect:TDoubleRect;virtual;(*vb*) Procedure DeConvertXY(var X,Y,Z: Double); (*vb*) Procedure DeConvertDim(var Dime: Double);(*vb*) Procedure ConvertXY(var X,Y,Z: double); (*vb*) Procedure ConvertDim(var Dime: double); (*vb*) Procedure DetDeConvertXY(var X,Y,Z: Double); Procedure DetDeConvertDim(var Dim: Double); Procedure DetConvertXY(var X,Y,Z: double); Procedure DetConvertDim(var Dim: double); Procedure IsoDeConvertXY(var X,Y,Z: Double); Procedure IsoDeConvertDim(var Dim: Double); Procedure IsoConvertXY(var X,Y,Z: double); Procedure IsoConvertDim(var Dim: double); Procedure IsoTo2D(var x,y,z: Double); Procedure ZoomArea(ZoomRect:TDoubleRect);(*vb*) Procedure FitToWindow;(*vb*) Procedure ActualSize;(*vb*) Procedure ZoomOut;(*vb*) Procedure ZoomIn;(*vb*) Constructor Create(AOwner: TComponent);override; Destructor Destroy;override; Procedure ClearGuides;(*vb*) Procedure SetTool(aToolIndex: TPCTool;aToolInfo:String;aToolData:Integer);virtual;(*vb*) Procedure SetCursor(cr:TCursor);virtual;(*vb*) Procedure SetDragCursor(cr:TCursor); (*vb*) Function CheckGuideLine(x,y:Double):Boolean;(*vb*) Function CheckForExistGuide(x,y: double; guType:TGuideType): Boolean; Procedure BeginHRulerDrag;(*vb*) Procedure BeginVRulerDrag;(*vb*) Function SurfaceWidth:Integer;(*vb*) Function SurfaceHeight: Integer;(*vb*) Function GetPageRect:TRect;overload; Procedure GetPageRect(var left,top,right,bottom:Integer);overload;(*vb*) Procedure SetSurfaceMargin(Value:Integer);(*vb*) Procedure SetScrollPositions(hPos,vPos:Integer)(*vb*); Procedure SetHScrollPosition(hPos: Integer;Update: Boolean); (*vb*) Procedure SetVScrollPosition(vPos: Integer;Update:Boolean);(*vb*) Procedure SetHScrollDelta(hDelta:Double;Update: Boolean);(*vb*) Procedure SetVScrollDelta(hDelta:Double;Update: Boolean); (*vb*) Function HSCBarPosition: Integer; (*vb*) Function VSCBarPosition: Integer;(*vb*) Function PointInHScroll(x,y:Double):Boolean; (*vb*) Function PointInVScroll(x,y:Double):Boolean;(*vb*) Function PointInHRuler(x,y:Double):Boolean;(*vb*) Function PointInVRuler(x,y:Double):Boolean;(*vb*) Function PointInDetail(x,y:Double):Boolean; Procedure CenterLocation(x,y:Double);(*vb*) Function PointInView(x,y:Double):Boolean;(*vb*) Procedure ZoomDetailArea(ZoomRect:TDoubleRect); Procedure ZoomDetailPoint(ZoomCenter:TDoublePoint);(*vb*) Procedure MoveDetailArea(dx,dy: Double); Function HitTestModPoint(x,y:Double):TModPoint;virtual; Function HitTestModPointInt(x,y:Double):Integer;virtual;(*vb*) Function HitTestModPointIntVal(x,y:Integer):TModPoint;virtual; Function HitTestModPointDetVal(x,y:Integer):TModPoint;virtual; Function CheckByPointInt(LayerNbr:Integer;x,y:Integer):TFigure;virtual; Procedure CollectFaces;virtual; Procedure SimulateTrace(x,y:Double);(*vb*) Procedure SimulateDown(x,y:Double);(*vb*) Procedure SimulateUp(x,y:Double);(*vb*) Procedure SimulateRightClick(x,y:Double);(*vb*) Procedure SnapToGrid(var X,Y:Double); //01.10.2013 procedure SurfacePaint; //07.08.2012 Property ToolIdx : TPCTool read FToolIdx;(*vb*) Property ToolInfo : string read FToolInfo;(*vb*) Property ToolData: Integer read GetToolData;(*vb*) Property DotsPerMilOrig: Double read FDpmOrig write SetDpmOrig;(*vb*) Property ActiveLayer : Integer read FActiveLayer write setActiveLayer;(*vb*) property Color; //07.08.2012 - из TCustomPanel property OnMouseWheel; Procedure DestroyCreatedOnDropGuides; published { Published declarations } Property ZoomScale: integer read FScale write setscale;(*vb*) Property GuidesVisible : Boolean read FGuides write setGuides; (*vb*) Property BackGround :Tcolor read FBackGround write setBg;(*vb*) Property PageColor :TColor read FPageColor write setPageColor;(*vb*) Property Grids: Boolean read FGrids write setGrids;(*vb*) Property GridType: TGridType read FGridType write SetGridType;(*vb*) Property CenterGuide:Boolean read FCenterGuide write setCenterGuide; (*vb*) Property PageGuide:Boolean read FPageGuide write setPageGuide;(*vb*) Property DrawShadow: Boolean read FShadow write setShadow;(*vb*) Property DrawPageBorder: Boolean read FDrawPageBorder write setPageborder;(*vb*) Property GridColor: TColor read FGridColor write setGcolor;(*vb*) Property GuideColor: TColor read FGuideColor write setGuidecolor;(*vb*) Property RulerColor:TColor read FRulerColor write setRulerColor;(*vb*) Property GridStep: Double read FGridStep write setGstep;(*vb*) Property WorkHeight: Double read FWorkHeight write setWHeight;(*vb*) Property WorkWidth: Double read FWorkWidth write setWWidth;(*vb*) Property PageLayout: TPageLayOut read FLayout write setLayOut; (*vb*) Property PageOrient: TPageOrient read FOrient write setOrient;(*vb*) Property GuideTrace: TGuideTraces read FGuideTrace write setGTrace;(*vb*) Property SnapToGuides: Boolean read FSnapToGuides write setSnapToGuides;(*vb*) Property SnapToNearPoint: Boolean read FSnapToNPoint write setSnapToNPoint;(*vb*) Property SnapToGrids: Boolean read FSnapToGrids write setSnaptoGrids;(*vb*) Property ScrollBars : Boolean read FScrollBars write setScrollBars;(*vb*) Property IsoCoordZ: Double read FCoordZ write setCoordZ; Property RulerSystem: TRulerSystem read FRulerSystem write SetRulerSytem;(*vb*) Property DrawInCursor:Boolean read FdrawInCursor write SetDrawInCursor;(*vb*) Property DetailWindow:Boolean read FDetail write SetDetail; Property DetailWidth:Integer read FDetailWidth write setDetailWidth; Property DetailHeight:Integer read FDetailHeight write setDetailHeight; Property DetailScale: Integer read FDetailScale write SetDetailScale; Property DetailStyle:TDetailStyle read FDetailStyle write SetDetailStyle; Property Isometric:Boolean read FIsometric write setIsometric; property OnSurfaceMove : TMouseTraceEvent read SOnMouseTrace write SOnMouseTrace;(*vb*) property OnSurfaceMouseDown : TMousePushEvent read SOnMousePush write SOnMousePush; (*vb*) property OnSurfaceMouseUp : TMousePullEvent read SOnMousePull write SOnMousePull;(*vb*) property OnSurfaceLeave : TNotifyEvent read SOnMouseLeave write SOnMouseLeave;(*vb*) property OnSurfaceClick : TNotifyEvent read SOnMouseClick write SOnMouseClick;(*vb*) property OnSurfaceDblClick: TNotifyEvent read SOnMouseDblClick write SOnMouseDblClick;(*vb*) Property OnSurfaceDragDrop: TDropDragEvent read SOnDropDrag write SOnDropDrag; (*vb*) Property OnSurfaceDragOver: TDragTraceEvent read SOnDragTrace write SOnDragTrace;(*vb*) Property OnSurfaceEndDrag: TDragEndEvent read SOnDragEnd write SOnDragEnd; Property OnSurfaceStartDrag: TDragStartEvent read SOnDragStart write SOnDragStart; Property OnScaleChanged: TNotifyEvent read SOnScale write SOnScale;(*vb*) Property OnScrollValues:TScrollValuesEvent read FScrollValues write FScrollValues;(*vb*) Property OnCursorChange:TCursorEvent read FCursorChange write FCursorChange;(*vb*)(*vbprivate*) Property OnBeforePaint: TNotifyEvent read FBeforePaint write FBeforePaint;(*vb*) Property OnCustomGuideTrace: TCustomTraceEvent read FCustomGuideTrace write FCustomGuideTrace; Property OnCustomGuideTraceVB: TCustomTraceEventVB read FCustomGuideTraceVB write FCustomGuideTraceVB;(*vb*) end; (*vbclassexport end*) const crZoom = crDefault + 30; const crLocate = crDefault + 31; const crPan = crDefault + 32; const crDelete = crDefault + 33; implementation uses U_Common, U_BaseCommon, USCS_Main, U_CAD{Tolik -- 29/03/2017 -- }, U_Master_compl; {$R *.RES} {$R *.DCR} var oldPosX,oldPosY:Integer; //****************************************************************************** // TGUЭDELЭNE IMPLEMENTATION //****************************************************************************** Constructor TGuideline.create(aType: TGuideType; aCoord: Double; autoCr: boolean = False); begin inherited create; // Tolik 14/04/2021 -- if GAutoCreatedGuide then begin fautoCr := GAutoCreatedGuide; GAutoCreatedGuide := False; end else // fautoCr := autoCr; gType := aType; coord := aCoord; end; destructor TGuideline.destroy; begin inherited; end; /////////////////////////////////////////////////// //****************************************************************************** // TPCDRAWBOX IMPLEMENTATION //****************************************************************************** Constructor TPCDrawBox.Create(AOwner: TComponent); Begin inherited create(AOwner); FDrawInCursor := False; ZoomPointFlag := False; SnapLocked := False; CurrentModPoint := nil; DEngine := TPCDrawEngine.create; RulerMode := 0; //rmPage RulerMapScale := 1; IsDragging := False; CustomSurface := nil; Guides := TList.Create; GuidesCreatedOnDropCompon := TList.Create; FScrollBars := True; FDetailStyle:= dsZoom; FIsometric := False; vsRgn := 0; HSRgn := 0; rVRgn := 0; rHRgn := 0; FBarsLocked := False; DrawBars := True; FDetail := False; FDetailWidth := 100; FDetailHeight := 100; FDetailTop := 0; FDetailLeft := 0; CurrentZ := 0; FActiveLayer := 0; Surface:= TPaintboxExt.Create(self); Surface.Parent := Container; Surface.Align := alClient; Surface.Visible := true; Surface.OnPaint := DoSurfacePaint; Container.OnResize := SurfaceResize; FDetailPosX := SurfaceWidth-FDetailWidth-20; FDetailPosY := 20; FVertBarVisible := False; FHorzBarVisible := False; FWorkHeight:= 100; FWorkWidth := 100; FScale := 100; FDpmOrig := 4; SetDpm((FScale / 100) * FDpmOrig); FSurfaceMargin := 0; FBackGround := clWhite; FRulerColor := clSilver; FPageColor := clWhite; FOrient:= poPortrait; FLayout := plCustom; FGridStep := 5; FGridColor := clSilver; FGrids := true; FGridType := grtLine; FShadow := True; FDrawPageBorder := True; FGuideColor := clGreen; FGuides := True; FguideTrace := gtNone; FSnapToGrids := False; FSnapToGuides := False; FSnapToNPoint := False; IsoAngle := pi/4; IsoType := 0; MaxScale := 3000; //16.12.2011 FGrayedColor := DefGrayedColor; //06.08.2012 FResetRegionsOnZoomScroll := true; //07.08.2012 //Surface.OnMouseMove := SurfaceMove; Surface.OnMouseMove := SurfaceMouseMove; Surface.OnClick := SurfaceClick ; Surface.OnDblClick := SurfaceDblClick; Surface.OnMouseLeave := SurfaceLeave; Surface.OnDragDrop := SurfaceDragDrop; Surface.OnEndDrag := SurfaceDragEnd; Surface.OnDragOver := SurfaceDragOver; Surface.OnStartDrag := SurfaceDragStart; Surface.OnMouseUp := SurfacePull; Surface.OnMouseDown := SurfacePush; Surface.Visible := True; OnMouseWheel := CadMouseWheel; Surface.OnMouseWheel := SurfaceMouseWheel; Surface.OnMiddleDblClick := SurfaceMiddleDblClick; Self.OnEnter := GotFocus; yold := - 50000; xold := - 50000; Guideyold := - 50000; Guidexold := - 50000; SnapX := - 50000; SnapY := - 50000; SnapXold := - 50000; SnapYold := - 50000; screen.Cursors[crZoom] := LoadCursor(HInstance,'ZOOM'); screen.Cursors[crLocate] := LoadCursor(HInstance,'LOCATE'); screen.Cursors[crPan] := LoadCursor(HInstance,'PAN'); screen.Cursors[crDelete] := LoadCursor(HInstance,'DELETE'); TempBitmap := TBitmap.Create; BaseBitmap := TBitmap.Create; evGrids := EventEngine(cGrids,1,'',0); evGridType := EventEngine(cGridType,0,'',0); evCenterGuide := EventEngine(cCenterGuides,1,'',0); evGuides := EventEngine(cGuides,1,'',0); evSnapGrids := EventEngine(cSnapGrid,0,'',0); evSnapGuides := EventEngine(cSnapGuides,0,'',0); evSnapObject := EventEngine(cSnapObject,0,'',0); evGridColor := EventEngine(cGridColor,FGridColor,'',0); evGuideColor := EventEngine(cGuideColor,FGuideColor,'',0); evBackColor := EventEngine(cBackColor,FBackground,'',0); evPageColor := EventEngine(cPageColor,FPageColor,'',0); evGuideTrace := EventEngine(cAngularGuides,0,'',0); evPageLo := EventEngine(cPageLo,ord(FLayout),'',0); evPageOr := EventEngine(cPageOr,ord(FOrient),'',0); evRulerSys := EventEngine(cRulerSystem,ord(FRulerSystem),'',0); FcoordZ := 0; DetailActive := False; end; Procedure TPCDrawBox.setScrollBars(value: Boolean); Begin if value = FScrollBars then exit; FScrollBars := value; DoPageLocate; if autorefresh then DoSurfacePaint(Surface); SyncEnv; End; Procedure TPCDrawBox.setHorzBarVisible(value: Boolean); Begin FHorzBarVisible := value; //SyncEnv; End; Procedure TPCDrawBox.setVertBarVisible(value: Boolean); Begin FVertBarVisible := value; //SyncEnv; End; Procedure TPCDrawBox.SurfaceResize(sender: TObject); Begin FDetailPosX := SurfaceWidth-FDetailWidth-20; FDetailPosY := 20; DoPageLocate; ZoomCenter; DrawGuideTrace(-25000,-25000); End; Procedure TPCDrawBox.SetScale(value: integer); var i, stCnt: Integer; st: Integer; Begin If (value < 1) or (value > MaxScale) then exit; if FScale <> Value then //07.08.2012 begin FScale := Value; SetDpm(FDpmOrig * (FScale / 100)); ZoomCenter; end else ResetRegions; End; Procedure TPCDrawBox.DoPageLocate; var rt: TrulerType; inch: real; SWidth, SHeight: Integer; Begin if Locked then exit; if FResetRegionsOnZoomScroll then //07.08.2012 ResetRegions; FBarsLocked := True; try if rulerVisible then begin // PageLeft := 35; // PageTop := 35; SWidth := SurfaceWidth-30; SHeight := SurfaceHeight - 30; end else begin PageLeft := 5; PageTop := 5; SWidth := SurfaceWidth; SHeight := SurfaceHeight; end; PageWidth:= Round((FWorkWidth ) * DotsPerMil ); PageHeight:= Round((FWorkHeight) * DotsPerMil ); // скролл по горизонтали If PageWidth < swidth then begin if rulerVisible then begin PageLeft := (swidth - PageWidth) div 2 + 30; end else begin PageLeft := (swidth - PageWidth) div 2; end; HorzBarVisible := False; SCHorzMax := 0; scHorzPos := 0; end else if FScrollbars then begin HorzBarVisible := True; SCHorzMax := PageWidth + 25; scHorzPage := swidth; scHorzPos := 0; end else begin HorzBarVisible := False; SCHorzMax := 0; SCHorzPos := 0; end; { else begin HorzBarVisible := False; SCHorzMax := PageWidth + 25; scHorzPage := swidth; scHorzPos := 0; end; } // скролл по вертикали If PageHeight < sHeight then begin if rulerVisible then begin PageTop := (SHeight -PageHeight) div 2 + 30; end else begin PageTop := (SHeight - PageHeight) div 2; end; VertBarVisible := False; SCVertMax := 0; ScvertPos := 0; end else if FScrollbars then begin VertBarVisible := True; scVertMax := PageHeight + 25; scVertPage := SHeight; scvertPos := 0; end else begin VertBarVisible := False; scVertMax := 0; scvertPos := 0; end; { else begin VertBarVisible := False; scVertMax := PageHeight + 25; scVertPage := SHeight; scvertPos := 0; end; } inch := 2.54; if RulerSystem = rsMetric then begin if Dotspermil > 40 then rt := rtDeciMilim else if Dotspermil > 24 then rt := rtHalfMilim else if Dotspermil > 12 then rt := rtMilim else if Dotspermil > 2.4 then rt := rtHalfCMeter else if Dotspermil > 1.2 then rt := rtCentiMeter else rt := rtDecimeter; end else begin if (Dotspermil * inch * 10 / 128) > 12 then rt := rtDeciMilim // 1/128 inch else if (Dotspermil * inch * 10 / 32) > 12 then rt := rtHalfMilim // 1/32 inch else if (Dotspermil * inch * 10 / 16) > 12 then rt := rtMilim // 1/16 inch else if (Dotspermil * inch * 5) > 12 then rt := rtHalfCMeter // 1/2 inch else if (Dotspermil * inch * 10) > 12 then rt := rtCentiMeter // inch else rt := rtDecimeter; // 10 x inch end; RulerType := rt; except end; FbarsLocked := False; End; Procedure TPCDrawBox.DoSurfacePaint(sender: TObject); var sx, sy: integer; pnt: Tpoint; Begin try if Locked then exit; if rulerVisible then begin If HorzBarVisible then PageLeft := 35 - HSCBarPosition; If VertBarVisible then PageTop := 35 - VSCBarPosition; end else begin If HorzBarVisible then PageLeft := 5 - HSCBarPosition; If VertBarVisible then PageTop := 5 - VSCBarPosition; end; if VerticalZero = vzBottom then sy := PageTop + PageHeight else sy := PageTop; if HorizontalZero = vzRight then sx := PageLeft + PageWidth else sx := PageLeft; RulerStart := Point(sx, sy); if assigned(TempBitmap) then begin TempBitmap.FreeImage; TempBitmap.Free; end; if Assigned(GCadForm) then if GCanRefreshCad then DrawShadowCrossPoints; // Tolik 17/01/2022 TempBitmap := TBitmap.Create; TempBitmap.Width := SurfaceWidth; TempBitmap.Height := SurfaceHeight; TempBitmap.Canvas.Brush.Color := Background; TempBitmap.Canvas.Brush.Style := bsSolid; TempBitmap.Canvas.FillRect(Rect(0, 0, TempBitmap.Width, TempBitmap.Height)); DrawGuideTrace(-25000, -25000); SnapXold := -50000; SnapYold := -50000; SetForceBufferEngine; DrawToCanvas(TempBitmap.canvas); SetBufferEngine; if FIsometric then CalculateIsometricMargins; except //On E: Exception do AddExceptionToLog(CPowerCadMessage + 'TPCDrawBox.DoSurfacePaint' + E.Message); On E: Exception do AddExceptionToLog('TPCDrawBox.DoSurfacePaint' + E.Message); end; End; Procedure TPCDrawBox.ZoomCenter; var xrect: TDoubleRect; FRefresh: Boolean; lMar: Integer; event: TScrollValuesEvent; Begin FbarsLocked := True; if ZoomPointFlag then begin xRect := DoubleRect(ZoomPoint.X - 10, ZoomPoint.Y - 10, ZoomPoint.X + 10, ZoomPoint.Y + 10); end else begin xRect := GetSelectionRect; if (xrect.left = 0) and (xrect.right =0) and (xrect.top = 0) and (xrect.bottom = 0) then begin xRect := GetDrawingRect; end; if (xrect.left = 0) and (xrect.right =0) and (xrect.top = 0) and (xrect.bottom = 0) then begin XRect := DoubleRect(0, 0, WorkWidth, WorkHeight); end; end; SetDpm(FDpmOrig * (FScale / 100)); FRefresh := AutoRefresh; AutoRefresh := False; event := FScrollValues; FScrollValues := nil; DoPageLocate; FScrollValues := event; FbarsLocked := True; If HorzBarVisible then begin lmar := Round(SurfaceWidth - abs(xRect.Right - xRect.Left) * DotsPermil) div 2; if HorizontalZero = vzRight then scHorzPos := round(((FWorkWidth - xRect.right)) * DotsPerMil - lmar) else scHorzPos := round((xRect.Left) * DotsPerMil - lmar); end; If VertBarVisible then begin lmar := Round(SurfaceHeight - abs(xRect.Top - xRect.Bottom) * DotsPermil) div 2; if VerticalZero = vzBottom then scVertPos := round(((FWorkHeight - xRect.Bottom)) * DotsPerMil - lmar) else scVertPos := round(((xRect.Top)) * DotsPerMil - lmar); end; AutoRefresh := Frefresh; if AutoRefresh then DoSurfacePaint(Surface); If assigned(SOnScale) then SOnScale(self); SyncEnv; FbarsLocked := False; end; Procedure TPCDrawBox.DoZoomIn; Begin ZoomScale := ZoomScale + 10; inherited; End; Procedure TPCDrawBox.DoZoomOut; Begin ZoomScale := ZoomScale - 10; inherited; End; Procedure TPCDrawBox.DoZoomArea; Begin inherited; End; procedure TPCDrawBox.ZoomArea(ZoomRect:TDoubleRect); var sc1,sc2 : double; rw,rh: real; w,h : double; tval: double; lmar: Integer; begin if zoomrect.bottom > zoomrect.top then begin tVal := zoomrect.bottom; zoomrect.bottom := zoomrect.top; zoomrect.top := tval; end; if zoomrect.left > zoomrect.right then begin tVal := zoomrect.left; zoomrect.left := zoomrect.right; zoomrect.right := tval; end; w := Abs(ZoomRect.Left - ZoomRect.Right); h := Abs(ZoomRect.Top - ZoomRect.Bottom); rW := (w)*Fdpmorig; sc1 := (surfacewidth-35)/rw; rH := (h)*Fdpmorig; sc2 := (surfaceheight-35)/rH; if not((rw > 30) and (rh > 30)) then exit; FbarsLocked := True; AutoRefresh := False; if Sc1 > sc2 then ZoomScale := Round(sc2*100) else ZoomScale := Round(sc1*100); If HorzBarVisible then begin lmar := Round(SurfaceWidth - abs(ZoomRect.Right-ZoomRect.Left)*DotsPermil) div 2; if HorizontalZero = vzRight then scHorzPos := round(((FWorkWidth-ZoomRect.right))*DotsPerMil-lmar) else scHorzPos := round((ZoomRect.Left)*DotsPerMil-lmar); end; If VertBarVisible then begin lmar := Round(SurfaceHeight - abs(ZoomRect.Top-ZoomRect.Bottom)*DotsPermil) div 2; if VerticalZero = vzBottom then scVertPos := round(((FWorkHeight - ZoomRect.Top))*DotsPerMil-lmar) else scVertPos := round(((ZoomRect.Bottom))*DotsPerMil-lmar); end; AutoRefresh := True; Refresh; FbarsLocked := False; DoZoomArea; end; Procedure TPCDrawBox.DoZoomActualSize; Begin ZoomScale := 100; inherited; End; Procedure TPCDrawBox.ActualSize; begin DoZoomActualSize; end; Procedure TPCDrawBox.DoZoomFitToWindow; var scx,scy,SWidth,SHeight: integer; Begin if rulerVisible then begin SWidth := SurfaceWidth-30; SHeight := SurfaceHeight - 30; end else begin SWidth := SurfaceWidth; SHeight := SurfaceHeight; end; scx := round((Swidth / ((FWorkWidth ) * FDpmOrig )) * 100)-1; scy := round((SHeight / ((FWorkHeight ) * FDpmOrig )) * 100)-1; // Tolik 20/03/2019 //ZoomScae := Round(MinValue([scx,scy])); if scx < scy then ZoomScale := scx else ZoomScale := scy; inherited; End; Procedure TPCDrawBox.FitToWindow; Begin DoZoomFitToWindow; end; procedure TPCDrawBox.setbg(value: Tcolor); begin FBackGround := value; if autorefresh then DoSurfacePaint(Surface); evBackColor.RaiseEvent(Value); Updated := True; SyncEnv; end; procedure TPCDrawBox.SetGuides(value: Boolean); begin FGuides := value; if autorefresh then DoSurfacePaint(Surface); evGuides.RaiseEvent(value); Updated := True; SyncEnv; end; procedure TPCDrawBox.setgrids(value: boolean); begin FGrids := value; if autorefresh then DoSurfacePaint(Surface); evGrids.RaiseEvent(Value); Updated := True; SyncEnv; end; Procedure TPCDrawBox.SetGridType(value:TGridType); begin FGridType := value; if autorefresh then DoSurfacePaint(Surface); evGridType.RaiseEvent(ord(Value)); Updated := True; SyncEnv; end; Procedure TPCDrawBox.setGcolor(value:Tcolor); begin FGridColor := value; if autorefresh then DoSurfacePaint(Surface); evGridColor.RaiseEvent(Value); Updated := True; SyncEnv; end; Procedure TPCDrawBox.setGstep(value: Double); begin FGridStep := value; if autorefresh then DoSurfacePaint(Surface); Updated := True; SyncEnv; end; Procedure TPCDrawBox.setGTrace(value: TGuideTraces); begin FGuideTrace := value; if autorefresh then DoSurfacePaint(Surface); evGuideTrace.RaiseEvent(ord(value)); Updated := True; SyncEnv; end; Procedure TPCDrawBox.setGuidecolor(value:Tcolor); begin FGuideColor := value; if autorefresh then DoSurfacePaint(Surface); evGuideColor.RaiseEvent(Value); Updated := True; SyncEnv; end; Procedure TPCDrawBox.setlayout(value : TPageLayout); begin Flayout := value; case Flayout of plA0 : begin if forient = poPortrait then begin fWorkHeight := 1189; fWorkWidth := 841; end else begin fWorkHeight := 841; fWorkWidth := 1189; end; end; plA1 : begin if forient = poPortrait then begin fWorkHeight := 841; fWorkWidth := 594; end else begin fWorkHeight := 594; fWorkWidth := 841; end; end; plA2 : begin if forient = poPortrait then begin fWorkHeight := 594; fWorkWidth := 421; end else begin fWorkHeight := 421; fWorkWidth := 594; end; end; plA3 : begin if forient = poPortrait then begin fWorkHeight := 421; fWorkWidth := 297; end else begin fWorkHeight := 297; fWorkWidth := 421; end; end; plA4 : begin if forient = poPortrait then begin fWorkHeight := 297; fWorkWidth := 210; end else begin fWorkHeight := 210; fWorkWidth := 297; end; end; plA5 : begin if forient = poPortrait then begin fWorkHeight := 210; fWorkWidth := 148; end else begin fWorkHeight := 148; fWorkWidth := 210; end; end; plA6 : begin if forient = poPortrait then begin fWorkHeight := 105; fWorkWidth := 74; end else begin fWorkHeight := 74; fWorkWidth := 105; end; end; plB4 : begin if forient = poPortrait then begin fWorkHeight := 353; fWorkWidth := 250; end else begin fWorkHeight := 250; fWorkWidth := 353; end; end; plB5 : begin if forient = poPortrait then begin fWorkHeight := 250; fWorkWidth := 176; end else begin fWorkHeight := 176; fWorkWidth := 250; end; end; plTabloid : begin if forient = poPortrait then begin fWorkHeight := 431; fWorkWidth := 279; end else begin fWorkHeight := 279; fWorkWidth := 431; end; end; plLetter : begin if forient = poPortrait then begin fWorkHeight := 279; fWorkWidth := 215; end else begin fWorkHeight := 215; fWorkWidth := 279; end; end; plCustom : begin end; end; DoPageLocate; if autorefresh then DoSurfacePaint(Surface); evPageLo.RaiseEvent(ord(FLayOut)); Updated := True; SyncEnv; end; Procedure TPCDrawBox.setwHeight(value: Double); begin FWorkHeight := value; flayout := plCustom; // if fworkheight > fworkwidth then // fOrient := poPortrait // else // fOrient := poLandscape; DoPageLocate; if autorefresh then DoSurfacePaint(Surface); Updated := True; SyncEnv; end; Procedure TPCDrawBox.setwWidth(value: Double); Begin FWorkWidth := value; flayout := plCustom; // if fworkheight > fworkwidth then // fOrient := poPortrait // else // fOrient := poLandscape; DoPageLocate; if autorefresh then DoSurfacePaint(Surface); Updated := True; SyncEnv; end; Procedure TPCDrawBox.setorient(Value : TPageOrient); var buffer1, buffer2: Double; begin FOrient := value; { If FOrient = poPortrait then begin if fWorkWidth > fWorkHeight then begin end; end else begin if fWorkWidth < fWorkHeight then begin end; end; } DoPageLocate; if autorefresh then DoSurfacePaint(Surface); evPageOr.RaiseEvent(ord(FOrient)); Updated := True; SyncEnv; end; Procedure TPCDrawBox.setSnapToNPoint(value: boolean); begin SnapLocked := False; FSnapToNPoint := value; evSnapObject.RaiseEvent(Value); Updated := True; SyncEnv; end; Procedure TPCDrawBox.setSnapToGuides(value: boolean); begin SnapLocked := False; FSnapToGuides := value; evSnapGuides.RaiseEvent(Value); Updated := True; SyncEnv; end; Procedure TPCDrawBox.setSnapToGrids(value: boolean); begin SnapLocked := False; FSnapToGrids := value; evSnapGrids.RaiseEvent(Value); Updated := True; SyncEnv; end; Procedure TPCDrawBox.DeConvertXY(var X,Y,Z: double); Begin if HorizontalZero = vzRight then x := (PageLeft + PageWidth) - x else x := x - PageLeft; if VerticalZero = vzBottom then y := (PageTop + PageHeight) - y else y := y - PageTop; DeConvertDim(x); DeConvertDim(y); End; Procedure TPCDrawBox.DeConvertDim(var Dime: Double); Begin Dime := Dime / (DotsPerMil * ConvertRatio); End; Procedure TPCDrawBox.ConvertXY(var X,Y,Z: double); Begin ConvertDim(x); ConvertDim(y); if HorizontalZero = vzRight then x := (PageLeft + PageWidth) - x else x := x + PageLeft; if VerticalZero = vzBottom then y := (PageTop + PageHeight) - y else y := PageTop + y; x := x + ConvertDx; y := y + ConvertDy; End; Procedure TPCDrawBox.ConvertDim(var Dime: Double); Begin Dime := Dime * (DotsPerMil * ConvertRatio); End; Procedure TPCDrawBox.SurfaceMove(Sender: TObject;Shift: TShiftState; X, Y: Integer); var xd,yd,z,dx,dy: Double; Begin //Self.SetFocus; if xold <> -25000 then begin DrawGuideTrace(x,y); end else begin xold := -50000; yold := -50000; end; dx := abs(dragStartxInt-x); dy := abs(dragStartyInt-y); if DragReadyInt and ((dx > 3) or (dy > 3)) then begin DragReadyInt := false; OldCursor := Surface.Cursor; if dragState = dsVScroll then begin SetCursor(crDefault); end else if dragState = dsHScroll then begin SetCursor(crDefault); end else if dragState = dsPan then begin SetCursor(crPan); Screen.Cursor := crPan; end else if dragState = dsDetPan then begin SetCursor(crPan); Screen.Cursor := crPan; end else if dragState = dsHRuler then begin SetCursor(crVSplit); Screen.Cursor := crVSplit; end else if dragState = dsVRuler then begin SetCursor(crHSplit); Screen.Cursor := crVSplit; end; if (dragState = dsMod) or (dragState = dsMove) then KillTraceFigure; DragStarted; Exit; end else if isDragging then begin DragMove(x,y); end; if not (isDragging and (DragState in [dsPan])) then begin if (FDetailStyle = dsZoom) and PointInDetail(x,y) then begin z := CurrentZ; xd := x;yd := y; DetDeConvertXY(Xd,Yd,z); CheckToSnap(Xd,Yd); If assigned(SOnMouseTrace) then SOnMouseTrace(Self,Shift,Xd,Yd); MSTrace(Self,Shift,Xd,Yd); end else begin z := 0; xd := x;yd := y; DeConvertXY(Xd,Yd,z); CheckToSnap(Xd,Yd); If assigned(SOnMouseTrace) then SOnMouseTrace(Self,Shift,Xd,Yd); MSTrace(Self,Shift,Xd,Yd); //Tolik 20/01/2021 if Assigned(GCadForm) then begin if GArchLineH <> nil then begin GArchLineH.Move(0, y - GArchLineH.aP1.y); GArchLineV.Move(x - GArchLineV.Ap1.x, 0); if GCadForm.PCad.TraceFigure = nil then begin DrawShadowCrossPoints; if GCadForm.cbMagnetWalls.Down then DefineShadowCrossPoints(GCurrMousePos.x, GCurrMousePos.y); end; end; end; end; end; End; Procedure TPCDrawBox.SurfaceClick(Sender:TObject); Begin If assigned(SOnMouseClick) then SOnMouseClick(Self); MSClick(Self); End; Procedure TPCDrawBox.SurfaceDblClick(Sender:TObject); Begin If assigned(SOnMouseDblClick) then SOnMouseDblClick(Self); MSDblClick(Self); End; Procedure TPCDrawBox.SurfaceLeave(Sender: TObject); Begin DrawGuideTrace(-50000,-50000); If assigned(SOnMouseLeave) then SOnMouseLeave(Self); MSLeave(Self); End; Procedure TPCDrawBox.SurfaceDragDrop(Sender, Source: TObject; X,Y: Integer); var guType: TGuideType; GuideX,GuideY: Double; xd,yd,z: double; xSource: Integer; BBOx: TPaintBox; Dist: Integer; Begin xSource := 0; if Source = Surface then begin xSource := oleds_Surface; end else if Source is TPaintBox then begin BBox := Source as TPaintBox; if BBox.Name = 'BlockBox' then FBlockDrop := BBox.Hint; xSource := oleDS_BlockBox; end; xd := x; yd := y; z := CurrentZ; if (FDetailStyle = dsZoom) and PointInDetail(x,y) then DetDeConvertXY(Xd,Yd,z) else DeConvertXY(Xd,Yd,z); CheckToSnap(Xd,Yd); If assigned(SOnDropDrag) then SOnDropDrag(Self,Source,Xd,Yd); MSDropDrag(Self, xSource, Xd, Yd); DragState := 0; End; Procedure TPCDrawBox.SurfaceDragEnd(Sender, Target: TObject; X,Y: Integer); var xd,yd,z:Double; Begin xd := x; yd := y; z := CurrentZ; if (FDetailStyle = dsZoom) and PointInDetail(x,y) then DetDeConvertXY(Xd,Yd,z) else DeConvertXY(Xd,Yd,z); CheckToSnap(Xd,Yd); If assigned(SOnDragEnd) then SOnDragEnd(Self,Target,Xd,Yd); MSEndDrag(Self, Target, X, Y); DragState := 0; End; Procedure TPCDrawBox.SurfaceDragOver(Sender, Source: TObject; X,Y: Integer; State: TDragState; var Accept: Boolean); var xd,yd,z: Double; xSource: Integer; Begin xSource := 0; if Source = Surface then xSource := oleDS_Surface else if Source is TPaintBox then xSource := oleDS_BlockBox; SurfaceMove(Sender,[],X,Y); xd := x; yd := y;z := CurrentZ; if (FDetailStyle = dsZoom) and PointInDetail(x,y) then DetDeConvertXY(Xd,Yd,z) else DeConvertXY(Xd,Yd,z); CheckToSnap(Xd,Yd); If assigned(SOnDragTrace) then SOnDragTrace(Self,Source,Xd,Yd,State,Accept); MSDragOver(Self, xSource, Xd, Yd, State, Accept); End; Procedure TPCDrawBox.SurfaceDragStart(Sender: TObject;var DragObject: TDragObject); Begin If assigned(SOnDragStart) then SOnDragStart(Self,DragObject); IsDragging := True; MSStartDrag(Sender,DragObject); End; Procedure TPCDrawBox.SurfacePull(Sender: TObject;Button: TMouseButton; Shift: TShiftState; X, Y: Integer); var xd,yd,z: Double; Begin if (ToolIdx = TPCTool(toFigure)) and (Button = mbMiddle) then exit; if (isDragging or DragReadyInt) and (DragState in [dsHScroll,dsVScroll,dsPan,dsDetPan,dsHRuler,dsVRuler]) then begin // if GCadForm.PCad.GuidesVisible then DragDropped(x,y); end else if (FDetailStyle = dsZoom) and PointInDetail(x,y) then begin DetailHit := True; DetailHitPoint:= Point(x,y); xd := x; yd := y; z := CurrentZ; DetDeConvertXY(Xd,Yd,z); CheckToSnap(Xd,Yd); If assigned(SOnMousePull) then SOnMousePull(Self,Button,Shift,Xd,Yd); MSPull(Self,Button,Shift,Xd,Yd); end else begin DetailHit := False; xd := x; yd := y; z := 0; DeConvertXY(Xd,Yd,z); CheckToSnap(Xd,Yd); If assigned(SOnMousePull) then SOnMousePull(Self,Button,Shift,Xd,Yd); MSPull(Self,Button,Shift,Xd,Yd); end; End; Procedure TPCDrawBox.SurfacePush(Sender: TObject;Button: TMouseButton; Shift: TShiftState; X, Y: Integer); var xd,yd,z: Double; xCanvas:TCanvas; fig: TFigure; odactive: Boolean; Begin if GArchLineH <> nil then begin //GArchLineH.Move(0, y - GArchLineH.aP1.y); //GArchLineV.Move(x - GArchLineV.Ap1.x, 0); if GCadForm.PCad.TraceFigure = nil then begin //if GCadForm.cbMagnetWalls.Down then // DrawShadowCrossPoints; //if GCadForm.cbMagnetWalls.Down then // DefineShadowCrossPoints(GCurrMousePos.x, GCurrMousePos.y); end; end; GotFocus(Self); odactive := DetailActive; DetailActive := False; CurrentModPoint := nil; if PointInHScroll(x,y) then begin DragStartXInt := x; OldPosX := HSCBarPosition; DragState := dsHScroll; DragReadyInt := True; xCanvas :=GetActiveCanvas; DrawScrollsToCanvas(xCanvas,True,True,False); end else if PointInVScroll(x,y) then begin DragStartYInt := y; OldPosY := VSCBarPosition; DragState := dsVScroll; DragReadyInt := True; xCanvas :=GetActiveCanvas; DrawScrollsToCanvas(xCanvas,True,False,True); end else if PointInHRuler(x,y) then begin DragStartYInt := y; DragStartXInt := x; DragOldx := x; DragOldY := y; DragState := dsHRuler; DragReadyInt := True; end else if PointInVRuler(x,y) then begin DragStartYInt := y; DragStartXInt := x; DragOldx := x; DragOldY := y; DragState := dsVRuler; DragReadyInt := True; end else if (Button = mbMiddle) and (PointInDetail(x,y)) then begin DetailActive := True; DragStartXInt := x; DragStartYInt := y; //OldPosY := VSCBarPosition; //OldPosX := HSCBarPosition; DragState := dsDetPan; DragReadyInt := True; //xCanvas :=GetActiveCanvas; //DrawScrollsToCanvas(xCanvas,True,False,True); end else if PointInDetail(x,y) then begin DetailActive := True; xd := x; yd := y; z := 0; CurrentZ := 0; DetailHit := True; DetailHitPoint := Point(x,y); If assigned(SOnMousePush) then SOnMousePush(Self,Button,Shift,Xd,Yd); if ToolIdx = toSelect then begin CurrentModPoint := HitTestModPointDetVal(x,y); if assigned(CurrentModPoint) then begin z := CurrentModPoint.CoordZ; CurrentZ := z; end else if FDetailStyle = dsIsometry then begin CurrentIsoFigure := nil; fig := nil; fig := CheckByPointInt(ActiveLayer,x,y); if assigned(fig) then begin CurrentIsoFigure := fig; end; end; end; DetDeConvertXY(Xd,Yd,z); CheckToSnap(Xd,Yd); MSPush(Self,Button,Shift,Xd,Yd); CurrentIsoFigure := nil; if FDetailStyle = dsIsometry then begin MSPull(Self,Button,Shift,Xd,Yd); end; CurrentModPoint := nil; end else if (Button = mbMiddle) and (not PointInDetail(x,y)) then begin if ToolIdx <> TPCTool(toFigure) then begin DragStartXInt := x; DragStartYInt := y; OldPosY := VSCBarPosition; OldPosX := HSCBarPosition; DragState := dsPan; DragReadyInt := True; xCanvas :=GetActiveCanvas; DrawScrollsToCanvas(xCanvas,True,False,True); end; end else if FIsometric then begin DetailHit := False; xd := x; yd := y; z := 0; CurrentZ := 0; If assigned(SOnMousePush) then SOnMousePush(Self,Button,Shift,Xd,Yd); if ToolIdx = toSelect then begin CurrentModPoint := HitTestModPointIntVal(x,y); if assigned(CurrentModPoint) then begin z := CurrentModPoint.CoordZ; CurrentZ := z; end else begin CurrentIsoFigure := nil; fig := nil; fig := CheckByPointInt(ActiveLayer,x,y); if assigned(fig) then begin CurrentIsoFigure := fig; end; end; end; IsoDeConvertXY(Xd,Yd,z); CheckToSnap(Xd,Yd); MSPush(Self,Button,Shift,Xd,Yd); CurrentIsoFigure := nil; CurrentModPoint := nil; end else begin xd := x; yd := y; z := 0; DetailHit := False; CurrentModPoint := nil; DeConvertXY(Xd,Yd,z); CheckToSnap(Xd,Yd); MSPush(Self,Button,Shift,Xd,Yd); If assigned(SOnMousePush) then SOnMousePush(Self,Button,Shift,Xd,Yd); end; if detailActive <> odActive then Refresh; End; Procedure TPCDrawBox.LostFocus(sender:Tobject); Begin Container.SetFocus; End; Procedure TPCDrawBox.drawguideTrace(x,y: integer); var alfa : extended; xCanvas: TCanvas; z,xd,yd: Double; begin if Locked then exit; if (csDesigning in self.ComponentState) then exit; xCanvas := GetActiveCanvas; ClipToUnScrollRegion; try with xCanvas do begin pen.color := clRed xor clWhite; pen.width := 1; pen.style := psSolid; pen.mode := pmXor; brush.style := bsSolid; brush.Color := clRed xor clWhite;; if (SnapXOld <> -50000) then begin Ellipse(SnapXOld-4,SnapYOld-4,SnapXOld+4,SnapYOld+4); end; if (SnapX <> -50000) then begin Ellipse(SnapX-4,SnapY-4,SnapX+4,SnapY+4); end; pen.color := clBlue xor clWhite; pen.style := psDot; brush.style := bsClear; if FDrawInCursor then begin pen.style := psSolid; if (xold <> - 50000) then begin moveto(xold-8,yold); lineto(xold+8,yold); moveto(xold,yold-8); lineto(xold,yold+8); end; if x <> - 50000 then begin moveto(x-8,y); lineto(x+8,y); moveto(x,y-8); lineto(x,y+8); end; pen.style := psDot; end; case (FGuideTrace) of gtNone: begin if RulerVisible then begin if (xold <> - 50000) then begin moveto(0,yold);lineto(30,yold); moveto(xold,0);lineto(xold,30); end; if x <> - 50000 then begin moveto(0,y);lineto(30,y); moveto(x,0);lineto(x,30); end; end; end; gtNinty: begin if xold <> - 50000 then begin moveto(0,yold);lineto(SurfaceWidth,yold); moveto(xold,0);lineto(xold,SurfaceHeight); end; if x <> - 50000 then begin moveto(0,y);lineto(SurfaceWidth,y); moveto(x,0);lineto(x,SurfaceHeight); end; end; gtFortyFive: begin alfa := (2*pi)/8; if xold <> - 50000 then begin moveto(0,yold-round(tan(alfa)*xold));lineto(SurfaceWidth,yold+round(tan(alfa)*(SurfaceWidth-xold))); moveto(0,yold+round(tan(alfa)*xold));lineto(SurfaceWidth,yold-round(tan(alfa)*(SurfaceWidth-xold))); end; if x <> - 50000 then begin moveto(0,y-round(tan(alfa)*x));lineto(SurfaceWidth,y+round(tan(alfa)*(SurfaceWidth-x))); moveto(0,y+round(tan(alfa)*x));lineto(SurfaceWidth,y-round(tan(alfa)*(SurfaceWidth-x))); end; end; gtThirty: begin alfa := (2*pi)/12; if xold <> - 50000 then begin moveto(0,yold-round(tan(alfa)*xold));lineto(SurfaceWidth,yold+round(tan(alfa)*(SurfaceWidth-xold))); moveto(0,yold+round(tan(alfa)*xold));lineto(SurfaceWidth,yold-round(tan(alfa)*(SurfaceWidth-xold))); end; if x <> - 50000 then begin moveto(0,y-round(tan(alfa)*x));lineto(SurfaceWidth,y+round(tan(alfa)*(SurfaceWidth-x))); moveto(0,y+round(tan(alfa)*x));lineto(SurfaceWidth,y-round(tan(alfa)*(SurfaceWidth-x))); end; end; gtsixty: begin alfa := (2*pi)/6; if xold <> - 50000 then begin moveto(0,yold-round(tan(alfa)*xold));lineto(SurfaceWidth,yold+round(tan(alfa)*(SurfaceWidth-xold))); moveto(0,yold+round(tan(alfa)*xold));lineto(SurfaceWidth,yold-round(tan(alfa)*(SurfaceWidth-xold))); end; if x <> - 50000 then begin moveto(0,y-round(tan(alfa)*x));lineto(SurfaceWidth,y+round(tan(alfa)*(SurfaceWidth-x))); moveto(0,y+round(tan(alfa)*x));lineto(SurfaceWidth,y-round(tan(alfa)*(SurfaceWidth-x))); end; end; gtCustom: begin if assigned(FCustomGuideTrace) then begin if xold <> - 50000 then begin z := 0; xd := xold;yd := yold; DeConvertXY(Xd,Yd,z); CheckToSnap(Xd,Yd); FCustomGuideTrace(Self,xold,yold,xd,yd,xCanvas); end; if x <> - 50000 then begin z := 0; xd := x;yd := y; DeConvertXY(Xd,Yd,z); CheckToSnap(Xd,Yd); FCustomGuideTrace(Self,x,y,xd,yd,xCanvas); end; end; if assigned(FCustomGuideTraceVB) then begin if xold <> - 50000 then begin z := 0; xd := xold;yd := yold; DeConvertXY(Xd,Yd,z); CheckToSnap(Xd,Yd); FCustomGuideTraceVB(Self,xold,yold,xd,yd,xCanvas.Handle); end; if x <> - 50000 then begin z := 0; xd := x;yd := y; DeConvertXY(Xd,Yd,z); CheckToSnap(Xd,Yd); FCustomGuideTraceVB(Self,x,y,xd,yd,xCanvas.Handle); end; end; end; end; yold := y; xold := x; SnapXOld := SnapX; SnapYOld := SnapY; end; except end; UnClip; end; Procedure TPCDrawBox.checktoSnap(var x,y : Double); var xx,yy,z: Double; begin SnapX := -50000; SnapY := -50000; if (ToolIdx = toZoom) or (ToolIdx = toDetailZoom) then exit; if (ToolIdx = toSelect) then begin if not IsDragging then exit; end; xx := x; yy := y; CalculateSnapPoint(x,y); if (xx<> x) or (yy <> y) then begin xx := x; yy := y; Dengine.ConvertCoord(xx,yy,z); SnapX := Round(xx); SnapY := Round(yy); end; end; //Procedure TPCDrawBox.CalculateSnapPoint(var x,y : Double); Function TPCDrawBox.CalculateSnapPoint(var x,y : Double): Boolean; Type DistRec = Record Dist : Double; Coord : Double; end; Var SnapDistance : Double; Coord: Double; gnumberv,gnumberh,a: integer; DistGridx,DistGridy : DistRec; DistGuideX,DistGuideY : Distrec; DistNearx,DistNeary : DistRec; NearX,NearY: Double; Guide: TGuideLine; grStep : double; mx: Integer; mval: Double; workw,workh: Double; dpm: double; distx, disty: Double; Begin result := false; if SnapLocked then exit; snapDistance := 12/dotspermil; // 12 pixel distGridx.dist := SnapDistance; distGridy.dist := SnapDistance; distGridx.coord := x; distGridy.coord := y; distGuidex.dist := SnapDistance; distGuidey.dist := SnapDistance; distGuidex.coord := x; distGuidey.coord := y; distNearx.dist := SnapDistance; distNeary.dist := SnapDistance; distNearx.coord := x; distNeary.coord := y; { if GCadForm.cbMagnetWalls.Down then begin DefineShadowCrossPoints(x ,y); if ((GWallPathPointX <> nil) or (GWallPathPointY <> nil)) then begin //Tolik 20/01/2022 -- if GWallPathPointX <> nil then begin X := GWallPathPointX.x; distx := RoundN(Sqrt(sqr(GWallPathPointX.x - x) + sqr(GWallPathPointX.y - y)), 6); if distx <= 1 then Y := GWallPathPointX.y; end; if GWallPathPointY <> nil then begin if GWallPathPointX = nil then begin disty := RoundN(Sqrt(sqr(GWallPathPointY.x - x) + sqr(GWallPathPointY.y - y)), 6); Y := GWallPathPointY.y; if disty <= 1 then X := GWallPathPointY.x; end else begin if Distx > 1 then begin if Disty <= 1 then Y := GWallPathPointY.y; end; end; end; exit; end; end else begin DrawGuideTrace(Round(x),Round(y)); exit; end; } // If FSnapToNPoint then begin NearX := X; NearY := Y; if SnapToFigures(NearX,NearY) then begin x := NearX; y := NearY; exit; end; end; if FsnaptoGrids then begin if RulerSystem = rsMetric then begin WorkW := FWorkWidth; WorkH := FWorkHeight; dpm := DotsPerMil; grStep := FGridStep; end else begin WorkW := ((FWorkWidth)/25.4)*16; WorkH := ((FWorkHeight)/25.4)*16; dpm := DotsPerMil; grStep := (FGridStep/16)*25.4; end; gnumberv := trunc(workw / FGridStep) ; if Fworkwidth = gnumberv*FGridStep then gnumberv := gnumberv - 1; gnumberh := trunc(workh / FGridStep) ; if Fworkheight = gnumberh*FGridStep then gnumberh := gnumberh - 1; for a := 1 to gnumberv do begin if HorizontalZero = vzRight then coord := FWorkWidth-a*grStep else coord := a*grStep; if abs(coord - x) < DistGridx.dist then begin distGridx.dist := abs(coord - x); distGridx.coord := coord; end; end; for a := 1 to gnumberh do begin if VerticalZero = vzBottom then coord := FWorkHeight-(a*GrStep) else coord := a*grStep; if abs(coord - y) < DistGridy.dist then begin distGridy.dist := abs(coord - y); distGridy.coord := coord; end; end; end; If FSnapToGuides then begin for a := 0 to guides.count-1 do begin Guide := TGuideline(guides[a]); If guide.gType = gtHorz then begin If abs(guide.coord - y) < distguidey.dist then begin distGuidey.dist := abs(guide.coord - y); distGuidey.coord := guide.coord; Result := true end; end else begin If abs(guide.coord - x) < distguidex.dist then begin distGuidex.dist := abs(guide.coord - x); distGuidex.coord := guide.coord; result := true; end; end; end; end; mx := 0; mval := DistGridx.dist; if DistGuidex.dist < mval then begin mVal := DistGuidex.dist; mx := 1; end; if DistNearx.dist < mval then begin mVal := DistGuidex.dist; mx := 2; end; if mx = 0 then x := DistGridx.coord else if mx = 1 then x := DistGuidex.coord else if mx = 2 then x := DistNearX.coord; mx := 0; mval := DistGridy.dist; if DistGuidey.dist < mval then begin mVal := DistGuidey.dist; mx := 1; end; if DistNeary.dist < mval then begin mVal := DistGuidey.dist; mx := 2; end; if mx = 0 then y := DistGridy.coord else if mx = 1 then y := DistGuidey.coord else if mx = 2 then y := DistNeary.coord; end; Procedure TPCDrawBox.MSPush(sender: TObject;Button: TMouseButton; Shift: TShiftState; X, Y: Double);begin end; procedure TPCDrawBox.MSTrace(Sender: TObject; Shift: TShiftState; X,Y: Double);begin end; procedure TPCDrawBox.MSPull(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Double);begin end; procedure TPCDrawBox.MSDropDrag(Sender: TObject;Source:Integer; X, Y: Double);begin end; procedure TPCDrawBox.MSDragOver(Sender: TObject;Source:Integer; X, Y: Double;State: TDragState; var Accept: Boolean);begin end; procedure TPCDrawBox.MSEndDrag(Sender, Target: TObject; X, Y: Double);begin end; procedure TPCDrawBox.MSStartDrag(Sender: TObject; var DragObject: TDragObject); begin end; procedure TPCDrawBox.MSClick(Sender: TObject);begin end; procedure TPCDrawBox.MSDblClick(Sender: TObject);begin end; Procedure TPCDrawBox.MSLeave(Sender: TObject);begin end; Procedure TPCDrawBox.SyncEnv; begin end; Procedure TPCDrawBox.Refresh; begin end; Procedure TPCDrawBox.ResetActions; Begin End; Procedure TPCDrawBox.ResetRegions; Begin End; procedure TPCDrawBox.DrawToCanvas(Canvas: TCanvas); var a4H: Double; Begin with canvas do begin Brush.Color := FPageColor; Brush.Style := bsSolid; Pen.Mode:= pmCopy; Pen.Style:= psSolid; if BackGround = clBlack then Pen.Color:= ClWhite else Pen.Color:= ClBlack; Pen.Width := 1; if FDrawPageBorder then Rectangle(PageLeft, PageTop, PageLeft + PageWidth, PageTop + PageHeight); If assigned(FBeforePaint) then FBeforePaint(self); Brush.Color := clWhite; Brush.Style := bsClear; if FShadow then begin Pen.Width := 2; MoveTo(PageLeft + PageWidth + 1, PageTop + round(2 * DotsPerMil)); LineTo(PageLeft + PageWidth + 1, PageTop + PageHeight); MoveTo(PageLeft + round(2 * DotsPerMil), PageTop + PageHeight + 1); LineTo(PageLeft + PageWidth, PageTop + PageHeight + 1); end; if FGrids then begin DrawGrids(Canvas); end; {Mityai} //D0000006303 //if Assigned(GCadForm) then if (FGuides)and(GuidesVisible) then begin DrawGuides(Canvas); end; if FCenterGuide then begin Pen.Style := psDot; Pen.Color := clGreen; Pen.width := 1; Pen.mode := pmCopy; Brush.Style := bsClear; moveto(PageLeft + PageWidth div 2, PageTop + 1); lineto(PageLeft + PageWidth div 2, PageTop + PageHeight - 1); moveto(PageLeft + 1, PageTop + PageHeight div 2); lineto(PageLeft+PageWidth - 1, PageTop + PageHeight div 2); end; if FPageGuide then begin Pen.Style := psDot; Pen.Color := clGreen; Pen.width := 1; Pen.mode := pmCopy; Brush.Style := bsClear; a4H := 300; Dengine.ConvertDim(a4H); moveto(PageLeft, PageTop + PageHeight - round(a4H)); lineto(PageLeft + PageWidth - 1, PageTop + PageHeight - round(a4H)); a4H := 450; Dengine.ConvertDim(a4H); moveto(PageLeft, PageTop + PageHeight - round(a4H)); lineto(PageLeft + PageWidth - 1, PageTop + PageHeight - round(a4H)); a4H := 900; Dengine.ConvertDim(a4H); moveto(PageLeft, PageTop + PageHeight - round(a4H)); lineto(PageLeft + PageWidth - 1, PageTop + PageHeight - round(a4H)); end; end; end; procedure TPCDrawBox.DrawGrids(Canvas: TCanvas); var gnumberv, gnumberh, a, b: integer; z: double; grx, gry: Double; grStep: double; workw, workh: Double; dpm: double; begin if RulerSystem = rsMetric then begin WorkW := FWorkWidth; WorkH := FWorkHeight; dpm := DotsPerMil; grStep := FGridStep; end else begin WorkW := ((FWorkWidth) / 25.4) * 16; WorkH := ((FWorkHeight) / 25.4) * 16; dpm := DotsPerMil; grStep := (FGridStep / 16) * 25.4; end; with Canvas do begin Pen.Style := pssolid; Pen.Color := FgridColor; Pen.width := 1; Pen.mode := pmCopy; Brush.Style := bsClear; gnumberv := trunc(workw / FGridStep) ; if Fworkwidth * dotspermil <= gnumberv * FGridStep * dotspermil + 2 then gnumberv := gnumberv - 1; gnumberh := trunc(workh / FGridStep) ; if Fworkheight * dotspermil <= gnumberh * FGridStep * dotspermil + 2 then gnumberh := gnumberh - 1; // линейная if FGridType = grtLine then begin for a := 1 to gnumberv do begin if HorizontalZero = vzRight then Dengine.drawline(FWorkWidth - a * grStep,(1 / dotspermil), FWorkWidth - a * grStep, FWorkHeight - (1 / dotspermil), FGridColor, 1, ord(psSolid), 0) else Dengine.drawline(a*grStep,(1/dotspermil),a*grStep,FWorkHeight-(1/dotspermil),FGridColor,1,ord(psSolid),0); end; for a := 1 to gnumberh do begin if VerticalZero = vzBottom then Dengine.drawline((1/dotspermil),FWorkHeight-(a*GrStep),FWorkWidth-(1/dotspermil),FWorkHeight-(a*GrStep),FGridColor,1,ord(psSolid),0) else Dengine.drawline((1/dotspermil),(a*GrStep),FWorkWidth-(1/dotspermil),(a*GrStep),FGridColor,1,ord(psSolid),0); end; end else // точечная if FGridType = grtPoint then begin for a := 1 to gnumberv do begin for b := 1 to gnumberh do begin if HorizontalZero = vzRight then grx := FWorkWidth-(a * GrStep) else grx := (a*GrStep); if VerticalZero = vzBottom then gry := FWorkHeight-(b * grStep) else gry := (b*grStep); DEngine.DrawPoint(DoublePOint(grx,gry),FGridColor); end; end; end else // крестовая begin for a := 1 to gnumberv do begin for b := 1 to gnumberh do begin if HorizontalZero = vzRight then grx := FWorkWidth - (a * GrStep) else grx := (a * GrStep); if VerticalZero = vzBottom then gry := FWorkHeight - (b * grStep) else gry := (b * grStep); Dengine.DrawCross(DoublePoint(grx,gry),FGridColor,1,ord(psSolid),2,False); end; end; end; end; end; procedure TPCDrawBox.DrawGuides(Canvas: TCanvas); var a: integer; g: TGuideLine; gx,gy,z: double; x1,x2,y1,y2: Double; begin DEngine.Canvas.Pen.mode := pmXor; For a := 0 to Guides.Count -1 do begin g := TGuideLine(Guides[a]); if ((not g.fautoCr) or GShowAutoCreatedGuides) then begin gx := g.coord; gy := g.coord; x1 := 0; y1 := 0; z := 0; x2 := SurfaceWidth; y2 := SurfaceHeight; DEngine.DeConvertCoord(x1, y1, z); DEngine.DeConvertCoord(x2, y2, z); if g.gType = gtHorz then begin DEngine.drawline(x1, gy, x2, gy, FGuideColor xor FbackGround, 1, ord(psSolid), 0); end else begin DEngine.drawline(gx, y1, gx, y2, FGuideColor xor FbackGround, 1, ord(psSolid), 0); end; end; end; DEngine.Canvas.Pen.mode := pmCopy; end; procedure TPCDrawBox.DrawCenterGuide(Canvas: TCanvas); begin with canvas do begin if FCenterGuide then begin Pen.Style := psDot; Pen.Color := clGreen; Pen.width := 1; Pen.mode := pmCopy; Brush.Style := bsClear; moveto(PageLeft + PageWidth div 2, PageTop + 1); lineto(PageLeft + PageWidth div 2, PageTop + PageHeight - 1); moveto(PageLeft + 1, PageTop + PageHeight div 2); lineto(PageLeft+PageWidth - 1, PageTop + PageHeight div 2); end; end; end; procedure TPCDrawBox.DrawGuidesTop(Canvas: TCanvas); var a: integer; g: TGuideLine; gx,gy,z: double; x1,x2,y1,y2: Double; begin DEngine.Canvas.Pen.mode := pmCopy; For a := 0 to Guides.Count -1 do begin g := TGuideLine(Guides[a]); if ((not g.fautoCr) or GShowAutoCreatedGuides) then begin gx := g.coord; gy := g.coord; x1 := 0; y1 := 0; z := 0; x2 := SurfaceWidth; y2 := SurfaceHeight; DEngine.DeConvertCoord(x1, y1, z); DEngine.DeConvertCoord(x2, y2, z); if g.gType = gtHorz then begin DEngine.drawline(x1, gy, x2, gy, FbackGround or FbackGround, 1, ord(psSolid), 0); end else begin DEngine.drawline(gx, y1, gx, y2, FbackGround or FbackGround, 1, ord(psSolid), 0); end; end; end; // DEngine.Canvas.Pen.mode := pmXor; end; Function TPCDrawBox.SnapToFigures(var x, y: double):Boolean; begin result := false; end; procedure TPCDrawBox.SetTool(aToolIndex: TPCTool; aToolInfo: String;aToolData:Integer); var sub:string; p: Integer; begin if aToolIndex = toFigure then begin p := Pos('>',aToolInfo); if p > 0 then begin sub := Copy(aToolInfo,p+1,Length(aToolInfo)-p); aToolInfo := Copy(aToolInfo,1,p-1); CurrentUserClass := Sub; end; end; fToolInfo := aToolInfo; fToolIdx := aToolIndex; fToolData := aToolData; case fToolIdx of toSelect : SetCursor(crDefault); toZoom,toDetailZoom : SetCursor(crZoom); toLocate:SetCursor(crLocate); toDelete:SetCursor(crDelete); toMWAnd:SetCursor(crUpArrow); else SetCursor(crCross); end; SyncEnv; end; // Tolik 14/04/2021 -- function TPCDrawBox.CheckGuideLine(x, y: Double): Boolean; var g : TGuideLine; gx,gy,z : Double; a : Integer; Begin result := False; if TF_CAD(parent).FCreateObjectOnClick then exit; if not GuidesVisible then // если направляющие отключены exit; z := 0; Convertxy(x,y,z); try For a := 0 to Guides.Count -1 do begin g := TGuideLine(Guides[a]); if ((not g.fautoCr) or GShowAutoCreatedGuides) then // чтобы не цапнуть мышкой невидимую напрявляющую begin gx := g.coord; gy := g.coord; z := 0; ConvertXY(gx,gy,z); if (g.gType = gtHorz) and (abs(y-gy) < 3) then begin GuideYold := Round(gy); BeginHRulerDrag; Guides.Remove(g); GAutoCreatedGuide := g.fautoCr; g.Free; result := true; exit; end; if (g.gType = gtVert) and (abs(x - gx) < 3) then begin GuideXold := Round(gx); BeginVRulerDrag; Guides.Remove(g); GAutoCreatedGuide := g.fautoCr; g.Free; result := true; exit; end; end; end; except // on E: Exception do AddExceptionToLog(CPowerCadMessage + 'TPCDrawBox.CheckGuideLine' + E.Message); end; end; (* function TPCDrawBox.CheckGuideLine(x, y: Double): Boolean; var g : TGuideLine; gx,gy,z : Double; a : Integer; Begin result := False; if TF_CAD(parent).FCreateObjectOnClick then exit; z := 0; Convertxy(x,y,z); try For a := 0 to Guides.Count -1 do begin g := TGuideLine(Guides[a]); gx := g.coord; gy := g.coord; z := 0; ConvertXY(gx,gy,z); if (g.gType = gtHorz) and (abs(y-gy) < 3) then begin GuideYold := Round(gy); BeginHRulerDrag; Guides.Remove(g); g.Free; result := true; exit; end; if (g.gType = gtVert) and (abs(x - gx) < 3) then begin GuideXold := Round(gx); BeginVRulerDrag; Guides.Remove(g); g.Free; result := true; exit; end; end; except // on E: Exception do AddExceptionToLog(CPowerCadMessage + 'TPCDrawBox.CheckGuideLine' + E.Message); end; end; *) procedure TPCDrawBox.setPageColor(Value: TColor); begin FPageColor := Value; if autorefresh then DoSurfacePaint(Surface); evPageColor.RaiseEvent(Value); Updated := True; SyncEnv; end; destructor TPCDrawBox.Destroy; begin // Tolik if Self.rVRgn <> 0 then DeleteObject(Self.rVRgn); if Self.HsRgn <> 0 then DeleteObject(Self.HsRgn); if Self.rHRgn <> 0 then DeleteObject(Self.rHRgn); if Self.VsRgn <> 0 then DeleteObject(Self.VsRgn); if Self.TempBitmap <> nil then begin // TempBitmap.FreeImage; FreeAndNil(TempBitmap); end; if Self.BaseBitmap <> nil then //Self.BaseBitmap.FreeImage; FreeAndNil(BaseBitmap); // ClearGuides; Guides.Free; GuidesCreatedOnDropCompon.Free; DEngine.Free; //Tolik { Container.OnResize := nil; Surface.Visible := False; Surface.Parent := nil; Surface.OnPaint := nil; Surface.OnMouseMove := nil; Surface.OnClick := nil; Surface.OnDblClick := nil; Surface.OnMouseLeave := nil; Surface.OnDragDrop := nil; Surface.OnEndDrag := nil; Surface.OnDragOver := nil; Surface.OnStartDrag := nil; Surface.OnMouseUp := nil; Surface.OnMouseDown := nil; Surface.OnMouseWheel := nil; Surface.OnMiddleDblClick := nil; FreeAndNil(Surface);} // inherited destroy; end; function TPCDrawBox.GetSelectionRect: TDoubleRect; begin //*** end; function TPCDrawBox.GetDrawingRect: TDoubleRect; begin //*** end; procedure TPCDrawBox.SetCursor(cr: TCursor); begin Surface.Cursor := cr; if assigned(FCursorChange) then FCursorChange(Self,cr); end; function TPCDrawBox.SurfaceHeight: Integer; var wndRect:Trect; begin if CustomWnd <> 0 then begin if Windows.GetWindowRect(CustomWnd,wndRect) then Result := Abs(wndRect.top-wndrect.bottom)-FSurfaceMargin else Result := 300; end else begin result:= Surface.Height; end; end; function TPCDrawBox.SurfaceWidth: Integer; var wndRect:Trect; begin if CustomWnd <> 0 then begin if Windows.GetWindowRect(CustomWnd,wndRect) then Result := Abs(wndRect.left-wndrect.right)-FSurfaceMargin else result := 300; end else begin result:= Surface.Width; end; end; procedure TPCDrawBox.SetScrollPositions(hPos, vPos: Integer); begin scHorzPos := hPos; scVertPos := vPos; ScHorzPos := hPos; ScVertPos := vPos; if FResetRegionsOnZoomScroll then //07.08.2012 ResetRegions; if autorefresh then DoSurfacePaint(Surface); end; function TPCDrawBox.HSCBarPosition: Integer; begin result := scHorzPos; end; function TPCDrawBox.VSCBarPosition: Integer; begin result := scVertPos; end; procedure TPCDrawBox.DrawGuideOnSurface(x,y:Integer;guType:TGuideType; needDraw: boolean = True); var xCanvas:TCanvas; begin if (needDraw or GShowAutoCreatedGuides) then begin xCanvas:= GetActiveCanvas; ClipToUnScrollRegion; with xCanvas do begin Pen.Mode := pmXor; Pen.Style := psSolid; pen.Color := FBackGround xor FGuideColor; Brush.Style := bsClear; if guType = gtHorz then begin if abs(guideYold - Y)> 3 then begin MoveTo(0,guideYold); LineTo(SurfaceWidth,guideYold); MoveTo(0,Y); LineTo(SurfaceWidth,Y); guideYold := y; end; end else begin if abs(guideXold - X) > 3 then begin MoveTo(guideXold,0); LineTo(guideXold,SurfaceHeight); MoveTo(X,0); LineTo(X,SurfaceHeight); guideXold := x; end; end; end; UnClip; end; end; procedure TPCDrawBox.DoSurfaceClick; begin SurfaceClick(nil); end; procedure TPCDrawBox.DoSurfaceDblClick; begin SurfaceDblClick(nil); end; procedure TPCDrawBox.DoSurfaceDragDrop(Source, X, Y: Integer); var guType: TGuideType; GuideX,GuideY: Double; xd,yd,z: double; Dist: Integer; Begin xd := x; yd := y; z := 0; DeConvertXY(Xd,Yd,z); CheckToSnap(Xd,Yd); If assigned(SOnDropDrag) then SOnDropDrag(Self,nil,Xd,Yd); MSDropDrag(Self,Source, Xd, Yd); DragState := 0; end; procedure TPCDrawBox.DoSurfaceDragEnd(X, Y: Integer); begin SurfaceDragEnd(nil,nil,x,y); DragState := 0; end; Procedure TPCDrawBox.DoSurfaceDragStart(Sender: TObject;var DragObject: TDragObject); begin SurfaceDragStart(Sender,DragObject); end; procedure TPCDrawBox.DoSurfaceDragOver(Source, X, Y, State: Integer; var Accept: Boolean); var xd,yd,z: Double; guType:TGuideType; dist: Integer; xCanvas: TCanvas; Begin if (source = oleDS_Surface) then begin Accept := True; if DragState = dsHScroll then begin Dist := x-round(DragStartXInt); SetHScrollDelta(Dist,False); xCanvas:=GetActiveCanvas; DrawScrollsToCanvas(xCanvas,True,True,False); exit; end else if DragState = dsVScroll then begin Dist := y-round(DragStartYInt); SetVScrollDelta(Dist,False); xCanvas:=GetActiveCanvas; DrawScrollsToCanvas(xCanvas,True,False,True); exit; end else if DragState = dsPan then begin Dist := x-round(DragStartXInt); SetHScrollDelta(Dist,False); Dist := y-round(DragStartYInt); SetVScrollDelta(Dist,False); xCanvas:=GetActiveCanvas; DrawScrollsToCanvas(xCanvas,True,False,True); exit; end else if DragState = dsDetPan then begin Dist := x-round(DragStartXInt); FDetailLeft := FDetailLeft-dist; Dist := y-round(DragStartYInt); FDetailTop := FDetailTop-dist; exit; end else if DragState = dsHRuler then begin guType := gtHorz; DrawGuideOnSurface(x,y,guType); exit; end else if DragState = dsVRuler then begin guType := gtVert; DrawGuideOnSurface(x,y,guType); exit; end; end; SurfaceMove(nil,[],X,Y); xd := x; yd := y; z := 0; DeConvertXY(Xd,Yd,z); CheckToSnap(Xd,Yd); If assigned(SOnDragTrace) then SOnDragTrace(Self,nil,Xd,Yd,TDragState(State),Accept); MSDragOver(Self, Source, Xd, Yd, TDragState(State), Accept); end; procedure TPCDrawBox.DragStarted; begin isDragging := True; end; procedure TPCDrawBox.DoSurfaceLeave; begin SurfaceLeave(nil); end; procedure TPCDrawBox.DoSurfaceMove(Shift, X, Y: Integer); var dShift:TShiftState; begin dShift := OleShiftToDelphiSet(shift); SurfaceMove(nil,dShift,x,y); end; procedure TPCDrawBox.DoSurfacePull(Button: Integer; Shift, X, Y: Integer); begin SurfacePull(nil,TMouseButton(Button),OleShiftToDelphiSet(shift),x,y); end; procedure TPCDrawBox.DoSurfacePush(Button, Shift, X, Y: Integer); begin SurfacePush(nil,TMouseButton(Button),OleShiftToDelphiSet(shift),x,y); end; procedure TPCDrawBox.BeginHRulerDrag; begin {Mityai} //D0000006303 if GuidesVisible then DragState := dsHRuler; SetCursor(crVSplit); DragStarted; KillTraceFigure; end; procedure TPCDrawBox.BeginVRulerDrag; begin {Mityai} //D0000006303 if GuidesVisible then DragState := dsVRuler; SetCursor(crHSplit); DragStarted; KillTraceFigure; end; procedure TPCDrawBox.SetCustomSurface(CWindow: HWnD; CDC:HDC); begin inherited; DoPageLocate; end; function TPCDrawBox.GetBackColor: TColor; begin result := FBackGround; end; procedure TPCDrawBox.DrawRulersToCanvas(Canvas: TCanvas); var cPoint: TPoint; dmm,hmm,mm,hcm,cm,dm,m,dam: extended; steps : array [1..3] of Extended; step : Extended; textcounter,len,number,a,coord,text: integer; inch : real; factor : double; rCanvas: TCanvas; rH,rW:INteger; rRect:Trect; Hstart:Integer; FRulerSystem: TRulerSystem; FDpm: Double; FRtype: TrulerType; VStart: Integer; clpRgn: HRGn; begin If not rulerVisible then exit; rCanvas:= Canvas; rw := SurfaceWidth; rh := 30; cPoint := RulerStart; Hstart := cpoint.x; inch := 2.54; factor := 1; FrulerSystem := RulerSystem; Fdpm := DotsPerMil; FRtype:= RulerType; //RulerMode := 0; //RulerMapScale:=500; if FRulerSystem = rsMetric then begin dmm := Fdpm / 10; hmm := Fdpm / 2; mm := Fdpm; hcm := mm*5; cm := mm*10; dm := cm*10; end else begin mm := Fdpm*inch*10/16; dmm := mm / 8; hmm := mm / 2; hcm := Fdpm*inch*10/2; cm := Fdpm*inch*10; dm := cm*10; end; SetBkMode(rCanvas.Handle,transparent); rcanvas.font.name := 'Tahoma'; rcanvas.font.size := 7; rcanvas.Font.Color := clBlack; rCanvas.Font.Style := []; rCanvas.Brush.Color := FRulerColor; rCanvas.Brush.Style := bsSolid; rCanvas.FillRect(Rect(0,0,rw,rh)); rCanvas.Brush.Style := bsClear; rCanvas.Pen.Color := clBlack; rCanvas.Pen.Width := 1; rCanvas.Pen.Style := psSolid; rCanvas.Pen.Mode:= pmCopy; rCanvas.MoveTo(30,rh); //Tolik 08/09/2021 -- commented Line draw //rCanvas.LineTo(rw,rh); // case FRtype of rtDeciMilim :begin if FRulerSystem = rsMetric then begin steps[1] := dmm; steps[2] := 10; steps[3] := 100; factor := 1; text := 2; if RulerMode = 0 then begin rCanvas.TextOut( 10,2,'mm'); factor := 1; end else begin if RulerMapScale < 500 then begin rCanvas.TextOut( 10,2,'cm'); Factor := RulerMapScale/10; end else begin rCanvas.TextOut( 10,2,'M'); Factor := RulerMapScale/1000; end; end; end else begin steps[1] := dmm; steps[2] := 8; steps[3] := 128; text := 2; if RulerMode = 0 then begin rCanvas.TextOut( 10,2,'Inch/16'); factor := 1; end else begin if RulerMapScale < 500 then begin rCanvas.TextOut( 10,2,'Inch'); Factor := RulerMapScale/16; end else begin rCanvas.TextOut( 10,2,'Feet'); Factor := RulerMapScale/(16*12); end; end; end; end; rtHalfMilim : begin if FRulerSystem = rsMetric then begin steps[1] := hmm; steps[2] := 2; steps[3] := 20; text := 3; if RulerMode = 0 then begin rCanvas.TextOut( 10,2,'cm'); factor := 1; end else begin rCanvas.TextOut( 10,2,'M'); Factor := RulerMapScale/100; end; end else begin steps[1] := hmm; steps[2] := 2; steps[3] := 32; factor := 1; text := 3; if RulerMode = 0 then begin rCanvas.TextOut( 10,2,'Inch'); factor := 1; end else begin rCanvas.TextOut( 10,2,'Feet'); Factor := RulerMapScale/12; end; end; end; rtMilim : begin if FRulerSystem = rsMetric then begin steps[1] := mm; steps[2] := 5; steps[3] := 10; text := 3; factor := 1; if RulerMode = 0 then begin rCanvas.TextOut( 10,2,'cm'); factor := 1; end else begin rCanvas.TextOut( 10,2,'M'); Factor := RulerMapScale/100; end; end else begin steps[1] := mm; steps[2] := 8; steps[3] := 16; text := 3; if RulerMode = 0 then begin rCanvas.TextOut( 10,2,'Inch'); factor := 1; end else begin rCanvas.TextOut( 10,2,'Feet'); Factor := (RulerMapScale/12); end; end; end; rtHalfCMeter : begin if FRulerSystem = rsMetric then begin steps[1] := hcm; steps[2] := 2; steps[3] := 20; text := 2; if RulerMode = 0 then begin rCanvas.TextOut( 10,2,'cm'); factor := 1; end else begin rCanvas.TextOut( 10,2,'M'); Factor := RulerMapScale/100; end; end else begin steps[1] := hcm; steps[2] := 2; steps[3] := 20; text := 2; if RulerMode = 0 then begin rCanvas.TextOut( 10,2,'inch'); factor := 1; end else begin rCanvas.TextOut( 10,2,'feet'); Factor := RulerMapScale/12; end; end; end; rtCentiMeter : begin if FRulerSystem = rsMetric then begin steps[1] := cm; steps[2] := 10; steps[3] := 100; text := 2; factor := 10; if RulerMode = 0 then begin rCanvas.TextOut( 10,2,'cm'); factor := 10; end else begin rCanvas.TextOut( 10,2,'M'); Factor := 10*(RulerMapScale/100); end; end else begin steps[1] := cm; steps[2] := 10; steps[3] := 100; text := 2; factor := 10; if RulerMode = 0 then begin rCanvas.TextOut( 10,2,'inch'); factor := 10; end else begin rCanvas.TextOut( 10,2,'feet'); Factor := 10*(RulerMapScale/12); end; end; end; rtDeciMeter : begin if FRulerSystem = rsMetric then begin steps[1] := dm; steps[2] := 1; steps[3] := 10; text := 2; factor := 10; if RulerMode = 0 then begin rCanvas.TextOut( 10,2,'cm'); factor := 10; end else begin rCanvas.TextOut( 10,2,'M'); Factor := 10*(RulerMapScale/100); end; end else begin steps[1] := dm; steps[2] := 1; steps[3] := 10; text := 2; factor := 10; if RulerMode = 0 then begin rCanvas.TextOut( 10,2,'inch'); factor := 10; end else begin rCanvas.TextOut( 10,2,'feet'); Factor := 10*(RulerMapScale/12); end; end; end; end; SelectClipRgn(rcanvas.Handle,0); clpRgn := CreateRectRgn(30,0,rw,rh); SelectClipRgn(rcanvas.Handle,clpRgn); if RHRgn <> 0 then DeleteObject(RHRgn); RHRgn := CreateRectRgn(30,0,rw,rh); step := steps[1]; textcounter := 0; if step < 4 then exit; number := round((rw - HStart) / step) + 1; rcanvas.MoveTo(HStart,rh); rcanvas.LineTo(HStart,rh-20); rCanvas.TextOut(HStart+2,rh-20,'0'); For a := 1 to number do begin coord := round(Hstart + (a*step)); if (a mod round(steps[3])) = 0 then len := 20 else if (a mod round(steps[2])) = 0 then len := 10 else len := 5; if coord > 30 then rcanvas.MoveTo(coord,rh); if coord > 30 then rcanvas.LineTo(coord,rh-len); if text = 1 then begin if coord > 30 then rCanvas.TextOut(coord+2,rh-len,floattostrf(a*factor,ffFixed,8,1)); end else if text = 2 then begin if len <> 5 then begin inc(textcounter); if len = 10 then len := 15; if coord > 30 then rCanvas.TextOut(coord+2,rh-len,floattostrf(textcounter*factor,ffFixed,8,1)); end; end else if text = 3 then begin if len = 20 then begin inc(textcounter); if coord > 30 then rCanvas.TextOut(coord+2,rh-len,floattostrf(textcounter*factor,ffFixed,8,1)); end; end; end; TextCOunter := 0; if HStart > 30 then begin number := round(HStart / step) + 1; For a := 1 to number do begin coord := round(Hstart - (a*step)); if (a mod round(steps[3])) = 0 then len := 20 else if (a mod round(steps[2])) = 0 then len := 10 else len := 5; if coord > 30 then rcanvas.MoveTo(coord,rh); if coord > 30 then rcanvas.LineTo(coord,rh-len); if text = 1 then begin if coord > 30 then rCanvas.TextOut(coord+2,rh-len,floattostrf(a*factor,ffFixed,8,1)); end else if text = 2 then begin if len <> 5 then begin inc(textcounter); if len = 10 then len := 15; if coord > 30 then rCanvas.TextOut(coord+2,rh-len,floattostrf(textcounter*factor,ffFixed,8,1)); end; end else if text = 3 then begin if len = 20 then begin inc(textcounter); if coord > 30 then rCanvas.TextOut(coord+2,rh-len,floattostrf(textcounter*factor,ffFixed,8,1)); end; end; end; end; rw := 30; rh := SurfaceHeight; SelectClipRgn(rcanvas.Handle,0); DeleteObJect(clpRgn); clpRgn := CreateRectRgn(0,30,rw+1,rh); SelectClipRgn(rcanvas.Handle,clpRgn); if RVRgn <> 0 then DeleteObject(RVRgn); RVRgn := CreateRectRgn(0,30,rw+1,rh); SetBkMode(rCanvas.Handle,transparent); rcanvas.font.name := 'Tahoma'; rcanvas.font.size := 7; rcanvas.Font.Color := clBlack; rCanvas.Font.Style := []; rCanvas.Brush.Color := FRulerColor; rCanvas.Brush.Style := bsSolid; rCanvas.FillRect(Rect(0,30,rw,rh)); rCanvas.Brush.Style := bsClear; rCanvas.Pen.Color := clBlack; rCanvas.MoveTo(rw,30); //Tolik 08/09/2021 -- commented Line draw //rCanvas.LineTo(rw,rh); // factor := 1; Vstart := cpoint.y; inch := 2.54; if FRulerSystem = rsMetric then begin dmm := Fdpm / 10; hmm := Fdpm / 2; mm := Fdpm; hcm := mm*5; cm := mm*10; dm := cm*10; end else begin mm := Fdpm*inch*10/16; dmm := mm / 8; hmm := mm / 2; hcm := Fdpm*inch*10/2; cm := Fdpm*inch*10; dm := cm*10; end; case FRtype of rtDeciMilim :begin if FRulerSystem = rsMetric then begin steps[1] := dmm; steps[2] := 10; steps[3] := 100; factor := 1; text := 2; if RulerMode = 0 then begin rCanvas.TextOut( 10,2,'mm'); factor := 1; end else begin if RulerMapScale < 500 then begin rCanvas.TextOut( 10,2,'cm'); Factor := RulerMapScale/10; end else begin rCanvas.TextOut( 10,2,'M'); Factor := RulerMapScale/1000; end; end; end else begin steps[1] := dmm; steps[2] := 8; steps[3] := 128; text := 2; if RulerMode = 0 then begin rCanvas.TextOut( 10,2,'Inch/16'); factor := 1; end else begin if RulerMapScale < 500 then begin rCanvas.TextOut( 10,2,'Inch'); Factor := RulerMapScale/16; end else begin rCanvas.TextOut( 10,2,'Feet'); Factor := RulerMapScale/(16*12); end; end; end; end; rtHalfMilim : begin if FRulerSystem = rsMetric then begin steps[1] := hmm; steps[2] := 2; steps[3] := 20; text := 3; if RulerMode = 0 then begin rCanvas.TextOut( 10,2,'cm'); factor := 1; end else begin rCanvas.TextOut( 10,2,'M'); Factor := RulerMapScale/100; end; end else begin steps[1] := hmm; steps[2] := 2; steps[3] := 32; factor := 1; text := 3; if RulerMode = 0 then begin rCanvas.TextOut( 10,2,'Inch'); factor := 1; end else begin rCanvas.TextOut( 10,2,'Feet'); Factor := RulerMapScale/12; end; end; end; rtMilim : begin if FRulerSystem = rsMetric then begin steps[1] := mm; steps[2] := 5; steps[3] := 10; text := 3; factor := 1; if RulerMode = 0 then begin rCanvas.TextOut( 10,2,'cm'); factor := 1; end else begin rCanvas.TextOut( 10,2,'M'); Factor := RulerMapScale/100; end; end else begin steps[1] := mm; steps[2] := 8; steps[3] := 16; text := 3; if RulerMode = 0 then begin rCanvas.TextOut( 10,2,'Inch'); factor := 1; end else begin rCanvas.TextOut( 10,2,'Feet'); Factor := (RulerMapScale/12); end; end; end; rtHalfCMeter : begin if FRulerSystem = rsMetric then begin steps[1] := hcm; steps[2] := 2; steps[3] := 20; text := 2; if RulerMode = 0 then begin rCanvas.TextOut( 10,2,'cm'); factor := 1; end else begin rCanvas.TextOut( 10,2,'M'); Factor := RulerMapScale/100; end; end else begin steps[1] := hcm; steps[2] := 2; steps[3] := 20; text := 2; if RulerMode = 0 then begin rCanvas.TextOut( 10,2,'inch'); factor := 1; end else begin rCanvas.TextOut( 10,2,'feet'); Factor := RulerMapScale/12; end; end; end; rtCentiMeter : begin if FRulerSystem = rsMetric then begin steps[1] := cm; steps[2] := 10; steps[3] := 100; text := 2; factor := 10; if RulerMode = 0 then begin rCanvas.TextOut( 10,2,'cm'); factor := 10; end else begin rCanvas.TextOut( 10,2,'M'); Factor := 10*(RulerMapScale/100); end; end else begin steps[1] := cm; steps[2] := 10; steps[3] := 100; text := 2; factor := 10; if RulerMode = 0 then begin rCanvas.TextOut( 10,2,'inch'); factor := 10; end else begin rCanvas.TextOut( 10,2,'feet'); Factor := 10*(RulerMapScale/12); end; end; end; rtDeciMeter : begin if FRulerSystem = rsMetric then begin steps[1] := dm; steps[2] := 1; steps[3] := 10; text := 2; factor := 10; if RulerMode = 0 then begin rCanvas.TextOut( 10,2,'cm'); factor := 10; end else begin rCanvas.TextOut( 10,2,'M'); Factor := 10*(RulerMapScale/100); end; end else begin steps[1] := dm; steps[2] := 1; steps[3] := 10; text := 2; factor := 10; if RulerMode = 0 then begin rCanvas.TextOut( 10,2,'inch'); factor := 10; end else begin rCanvas.TextOut( 10,2,'feet'); Factor := 10*(RulerMapScale/12); end; end; end; end; step := steps[1]; if step < 4 then exit; number := round((VStart) / step) + 1; rcanvas.MoveTo(rw,VStart); Rcanvas.LineTo(rw-20,VStart); TextCounter := 0; RCanvas.TextOut(rw-20,Vstart+2,'0'); For a := 1 to number do begin coord := round(Vstart - (a*step)); if (a mod round(steps[3])) = 0 then len := 20 else if (a mod round(steps[2])) = 0 then len := 10 else len := 5; rcanvas.MoveTo(rw,coord); rcanvas.LineTo(rw-len,coord); if text = 1 then begin rCanvas.TextOut(rw-len-2,coord+2,floattostrf(a*factor,fffixed,8,1)); end else if text = 2 then begin if len <> 5 then begin inc(textcounter); if len = 10 then len := 20; rCanvas.TextOut(rw-len-2,coord+2,floattostrf(textcounter*factor,fffixed,8,1)); end; end else if text = 3 then begin if len = 20 then begin inc(textcounter); rCanvas.TextOut(rw-len-2,coord+2,floattostrf(textcounter*factor,fffixed,8,1)); end; end; end; TextCounter := 0; if VStart < rh then begin number := round( (rh - VStart) / step) + 1; For a := 1 to number do begin coord := round(Vstart + (a*step)); if (a mod round(steps[3])) = 0 then len := 20 else if (a mod round(steps[2])) = 0 then len := 10 else len := 5; rcanvas.MoveTo(rw,coord); rcanvas.LineTo(rw-len,coord); if text = 1 then begin rCanvas.TextOut(rw-len-2,coord+2,floattostrf(a*factor,fffixed,8,1)); end else if text = 2 then begin if len <> 5 then begin inc(textcounter); if len = 10 then len := 20; rCanvas.TextOut(rw-len-2,coord+2,floattostrf(textcounter*factor,fffixed,8,1)); end; end else if text = 3 then begin if len = 20 then begin inc(textcounter); rCanvas.TextOut(rw-len-2,coord+2,floattostrf(textcounter*factor,fffixed,8,1)); end; end; end; end; SelectClipRgn(rcanvas.Handle,0); DeleteObJect(clpRgn); end; procedure TPCDrawBox.ReLocate; begin DoPageLocate; DrawGuideTrace(-25000,-25000); end; procedure TPCDrawBox.DrawScrollsToCanvas(Canvas: TCanvas; DoubleBuffered: Boolean; hpressed, vpressed: Boolean); var edge, sWidth, sHeight, pWidth, pHeight, pos: Integer; i: Integer; sRect: Trect; temp: Tbitmap; xCanvas: TCanvas; hRect,vRect: TRect; begin Exit; if hsRgn <> 0 then deleteObject(hsRgn); if vsRgn <> 0 then deleteObject(vsRgn); hsRgn := 0; vsRgn := 0; if not DrawBars then exit; if DoubleBuffered then begin Temp := Tbitmap.Create; xCanvas := Temp.Canvas; end else xCanvas := canvas; xCanvas.Brush.Color := clWhite; xcanvas.Brush.Style := bsSolid; xcanvas.Pen.Color := clBlack; xCanvas.Pen.Mode := pmCopy; xCanvas.Pen.Style := psSolid; edge := 15; if HorzBarVisible and (scHorzMax > 0) then begin sHeight := edge; if vertbarvisible then sWidth := SurfaceWidth - sHeight + 1 else sWidth := SurfaceWidth; scHorzWidth := sWidth; pWidth := Round(sWidth * (ScHorzPage / ScHorzMax)) - 1; pos := Round(sWidth * (scHorzPos / scHorzMax)); xCanvas.Brush.Color := clBtnFace; xCanvas.Pen.Color := clGray; if DoubleBuffered then begin hRect := Rect(0, 0, sWidth, sHeight); Temp.Height := sHeight; Temp.Width := SWidth; end else begin hRect := Rect(0, SurfaceHeight - sHeight, sWidth, SurfaceHeight); end; xcanvas.Rectangle(hRect); xCanvas.Brush.Color := clBtnFace; if DoubleBuffered then begin hRect := Rect(pos, 0, pos + pWidth, sHeight); end else begin hRect := Rect(pos, SurfaceHeight - sHeight, pos + pWidth, SurfaceHeight); end; xcanvas.Rectangle(hRect); if hpressed then DrawEdge(xCanvas.Handle, hRect, EDGE_SUNKEN, BF_RECT) else DrawEdge(xCanvas.Handle, hRect, EDGE_RAISED, BF_RECT); hsRgn := CreateRectRgn(hRect.left, hRect.Top, hRect.right, hRect.Bottom); if DoubleBuffered then Canvas.Draw(0, SurfaceHeight - sHeight, temp); end; if VertBarVisible and (scVertmax > 0) then begin sWidth := edge; if horzbarvisible then sHeight := SurfaceHeight - sWidth + 1 else sHeight := SurfaceHeight; scVertHeight := sHeight; pHeight := Round(sHeight * (ScVertPage / ScVertMax)) - 1; pos := Round(sHeight * (scVertPos / scVertMax)); xCanvas.Pen.Color := clGray; xCanvas.Brush.Color := clBtnFace; if DoubleBuffered then begin vRect := Rect(0, 0, sWidth, sHeight); Temp.Height := sHeight; Temp.Width := SWidth; end else begin vRect := Rect(SurfaceWidth - sWidth, 0, SurfaceWidth, SHeight); end; xcanvas.Rectangle(vRect); if DoubleBuffered then begin vRect := Rect(0, pos, sWidth, pos + pHeight); Temp.Height := sHeight; Temp.Width := SWidth; end else begin vRect := Rect(SurfaceWidth - sWidth, pos, SurfaceWidth, pos + pHeight); end; xcanvas.Rectangle(vRect); if vpressed then DrawEdge(xCanvas.Handle, vRect, EDGE_SUNKEN, BF_RECT) else DrawEdge(xCanvas.Handle, vRect, EDGE_RAISED, BF_RECT); vsRgn := CreateRectRgn(vRect.Left, vRect.Top, vRect.Right, vRect.Bottom); if DoubleBuffered then Canvas.Draw(SurfaceWidth - sWidth, 0, temp); end; if HorzbarVisible and VertbarVisible then begin if DoubleBuffered then begin Temp.Height := edge; Temp.Width := edge; hRect := Rect(0, 0, edge, edge); end else begin hRect := Rect(SurfaceWidth - edge, SurfaceHeight - edge, SurfaceWidth, SurfaceHeight); end; xCanvas.Pen.Color := clGray; xCanvas.Brush.Color := clBtnFace; xcanvas.Rectangle(hRect); if DoubleBuffered then Canvas.Draw(SurfaceWidth - edge, SurfaceHeight - edge, temp); end; if DoubleBuffered then begin //Tolik Temp.FreeImage; // Temp.Free; end; end; procedure TPCDrawBox.SetScrolls(SHorzMAx, SVertMax, SHorzPos, SVertPos, SHorzPage, SVertPage: Integer); begin if assigned(FScrollValues) then FScrollValues(Self,SHorzMAx,SVertMax,SHorzPos, SVertPos,SHorzPage,SVertPage,round(5 * DotsPerMil),round(20 * DotsPerMil)); ScHorzMAx := SHorzMAx; ScVertMax := SVertMax; ScHorzPos := SHorzPos; ScVertPos := SVertPos; ScHorzPage := SHorzPage; ScVertPage := SVertPage; end; procedure TPCDrawBox.SetHScrollPosition(hPos: Integer; Update:Boolean); begin if HPos > (scHorzMax - scHorzPage) then HPos := (scHorzMax - scHorzPage); if hPos < 0 then hpos := 0; ScHorzPos := hPos; if Update then begin if FResetRegionsOnZoomScroll then //07.08.2012 ResetRegions; if autorefresh then DoSurfacePaint(Surface); end; end; procedure TPCDrawBox.SetVScrollPosition(vPos: Integer;Update:Boolean); begin if vPos > (scVertMax - scVertPage) then vPos := (scVertMax - scVertPage); if vPos < 0 then vPos := 0; ScVertPos := vPos; if Update then begin if FResetRegionsOnZoomScroll then //07.08.2012 ResetRegions; if autorefresh then DoSurfacePaint(Surface); end; end; function TPCDrawBox.PointInHRuler(x, y: Double): Boolean; begin result := false; {Mityai} //D0000006303 if (RulerVisible)and(GuidesVisible) then result := PtInRegion(rHrgn,Round(x),Round(y)); end; function TPCDrawBox.PointInHScroll(x, y: Double): Boolean; begin result := false; result := PtInRegion(hsrgn,Round(x),Round(y)); end; function TPCDrawBox.PointInVRuler(x, y: Double): Boolean; begin result := false; {Mityai} //D0000006303 if (RulerVisible)and(GuidesVisible) then result := PtInRegion(rVrgn,Round(x),Round(y)); end; function TPCDrawBox.PointInVScroll(x, y: Double): Boolean; begin result := false; result := PtInRegion(vsrgn,Round(x),Round(y)); end; procedure TPCDrawBox.SetHScrollDelta(hDelta: Double;Update: Boolean); var sgn: Integer; begin if hDelta = 0 then exit; if hdelta <0 then begin sgn := -1; end; sgn := 1; if hDelta < 0 then sgn := -1; hDelta := round(hDelta* (scHorzMax/scHorzWidth)); if (abs(hDelta) >= 0) and (abs(hDelta) < 1) then hDelta := sgn; SetHScrollPosition(round(oldposX)+Round(hDelta),Update); end; procedure TPCDrawBox.SetVScrollDelta(hDelta: Double;Update: Boolean); var sgn: Integer; begin if hDelta = 0 then exit; sgn := 1; if hDelta < 0 then sgn := -1; hDelta := round(hDelta* (scVertMax/scVertHeight)); if (abs(hDelta) >= 0) and (abs(hDelta) < 1) then hDelta := sgn; SetVScrollPosition(round(oldPosY)+Round(hDelta),Update); end; procedure TPCDrawBox.SetDragCursor(cr: TCursor); begin Surface.DragCursor := cr; Surface.Cursor := cr; if assigned(FCursorChange) then FCursorChange(Self,cr); end; Function TPCDrawBox.CheckForGuideDrop(X, Y: Integer; autoCr: boolean = False):Boolean; var gutype: TGuideType; guidex: Double; guidey,z: Double; begin result := false; if (DragState = dsHRuler) or (DragState = dsVRuler) then begin result := true; if DragState = dsHRuler then guType := gtHorz else guType := gtVert; GuideX := x; GuideY:= y;z :=0; DeConvertXY(GuideX,GuideY,z); if guType = gtHorz then begin Guides.Add(TGuideLine.create(gtHorz,GuideY, autoCr)); guideYold := -5000; end else begin Guides.Add(TGuideLine.create(gtVert,GuideX, autoCr)); guideXold := - 5000; end; end; end; function TPCDrawBox.GetActiveCanvas: TCanvas; begin if CustomSurface <> nil then result := CustomSurface else result := Surface.Canvas; end; procedure TPCDrawBox.ClipToActiveRegion(xCanvas:TCanvas=nil); var x1,y1,x2,y2: Integer; dRgn: HRGN; begin x1 := 0; if RulerVisible then x1 := x1+30; y1 := 0; if RulerVisible then y1 := y1+30; x2 := SurfaceWidth; y2 := SurfaceHeight; if HorzBarVisible and (scHorzMax > 0) then y2 := y2 - 15; if VertBarVisible and (scVertMax > 0) then x2 := x2 - 15; if not assigned(xCanvas) then xCanvas := GetActiveCanvas; SelectClipRgn(xCanvas.Handle,0); if crgn <> 0 then DeleteObject(cRgn); cRgn := CreateRectRgn(x1,y1,x2,y2); if FDetail then begin dRgn := CreateRectRgn(FdetailPosX,FDetailPosY,FdetailPosX+FDetailWidth,FDetailPosY+FDetailHeight); CombineRgn(cRgn,cRgn,dRgn,RGN_DIFF); DeleteObject(dRgn); end; SelectClipRgn(xCanvas.Handle,cRgn); Dengine.ClipRgn := crgn; end; procedure TPCDrawBox.unClip(xCanvas:TCanvas=nil); begin if not assigned(xCanvas) then xCanvas := GetActiveCanvas; SelectClipRgn(xCanvas.Handle,0); if crgn <> 0 then DeleteObject(cRgn); cRgn := 0; Dengine.ClipRgn := crgn; end; procedure TPCDrawBox.ClipToUnScrollRegion(xCanvas:TCanvas=nil); var x1,y1,x2,y2: Integer; xrgn: HRGN; begin x1 := 0; y1 := 0; x2 := SurfaceWidth; y2 := SurfaceHeight; if HorzBarVisible and (scHorzMax > 0) then y2 := y2 - 15; if VertBarVisible and (scVertMax > 0) then x2 := x2 - 15; if not assigned(xCanvas) then xCanvas := GetActiveCanvas; SelectClipRgn(xCanvas.Handle,0); if crgn <> 0 then DeleteObject(cRgn); cRgn := CreateRectRgn(x1,y1,x2,y2); xRgn := CreateRectRgn(0,0,30,30); CombineRgn(cRgn,cRgn,xRgn,RGN_DIFF); DeleteObject(xRgn); SelectClipRgn(xCanvas.Handle,cRgn); Dengine.ClipRgn := crgn; end; procedure TPCDrawBox.ClipToDetailRegion(xCanvas: TCanvas); begin if not assigned(xCanvas) then xCanvas := GetActiveCanvas; SelectClipRgn(xCanvas.Handle,0); if crgn <> 0 then DeleteObject(cRgn); cRgn := CreateRectRgn(FdetailPosX,FDetailPosY,FdetailPosX+FDetailWidth,FDetailPosY+FDetailHeight); SelectClipRgn(xCanvas.Handle,cRgn); Dengine.ClipRgn := crgn; end; procedure TPCDrawBox.KillTraceFigure; begin // this is for killing the trace figure in TPowercad end; procedure TPCDrawBox.SetEngine(xCanvas: TCanvas; CPoint,DeCPoint:ConvertXYProc; CDim,DeCdim:ConvertDimProc;isPrinting: Boolean; prBmp: TBitmap); Begin DEngine.Canvas := xCanvas; DEngine.ConvertPoint := CPoint; DEngine.ConvertLen := CDim; DEngine.DeConvertPoint := DeCPoint; DEngine.DeConvertLen := DeCDim; DEngine.isPrinting := isPrinting; DEngine.PrintBmp := prBmp; Dengine.Isometric := FIsometric; end; Procedure TPCDrawBox.SetDefaultEngine; begin if CustomSurface <> nil then begin if FIsometric then begin SetEngine(CustomSurface,IsoConvertXY,IsoDeConvertXY,IsoConvertDim,IsoDeConvertDim,false,nil); end else begin SetEngine(CustomSurface,ConvertXY,DeConvertXY,ConvertDim,DeConvertDim,false,nil); end; end else begin if FIsometric then begin SetEngine(Surface.Canvas,IsoConvertXY,IsoDeConvertXY,IsoConvertDim,IsoDeConvertDim,false,nil); end else begin SetEngine(Surface.Canvas,ConvertXY,DeConvertXY,ConvertDim,DeConvertDim,false,nil); end; end; end; procedure TPCDrawBox.SetDetailEngine; begin if CustomSurface <> nil then begin SetEngine(CustomSurface,DetConvertXY,DetDeConvertXY,DetConvertDim,DetDeConvertDim,false,nil); end else begin SetEngine(Surface.Canvas,DetConvertXY,DetDeConvertXY,DetConvertDim,DetDeConvertDim,false,nil); end; end; function TPCDrawBox.DoKeyEvents(Message: TWMKey): Boolean; var ShiftState: TShiftState; chCode: Word; shift: Integer; scan_code: Byte; const AltMask = $20000000; begin shift := 0; scan_code := (Message.KeyData shr 16) and $FF; if GetKeyState(VK_SHIFT) < 0 then shift := shift or oleShift; if GetKeyState(VK_CONTROL) < 0 then shift := shift or oleCtrl; if Message.KeyData and AltMask <> 0 then shift := shift or oleAlt; chCode := Message.CharCode; if ((scan_code >= 59) and (scan_code <= 68)) or (scan_code = 87) or (scan_code >= 88) then chCode := 0; Result := DoKeyStroke(chCode,Shift); end; function TPCDrawBox.DoKeyStroke(ChCode, Shift: Integer): Boolean; begin //*** end; procedure TPCDrawBox.setShadow(const Value: Boolean); begin FShadow := Value; if autorefresh then DoSurfacePaint(Surface); end; procedure TPCDrawBox.DragMove(x, y: Integer); var guType:TGuideType; dist: Integer; xCanvas: TCanvas; ADeltaX, ADeltaY: double; begin // Tolik 29/03/2017 -- if (Self.Owner = nil) then Exit; // if DragState = dsHScroll then begin Dist := x-Round(DragStartXInt); SetHScrollDelta(Dist,False); xCanvas:=GetActiveCanvas; DrawScrollsToCanvas(xCanvas,True,True,False); end else if DragState = dsVScroll then begin Dist := y-Round(DragStartYInt); SetVScrollDelta(Dist,False); xCanvas:=GetActiveCanvas; DrawScrollsToCanvas(xCanvas,True,False,True); end else if DragState = dsPan then begin { Dist := y-Round(DragStartYInt); SetVScrollDelta(-Dist,False); Dist := x-Round(DragStartXInt); SetHScrollDelta(-Dist,False); xCanvas:=GetActiveCanvas; ResetRegions; Refresh; } ADeltaY := (y - Round(DragStartYInt)) / ZoomScale * 25; DragStartYInt := y; ADeltaX := (x - Round(DragStartXInt)) / ZoomScale * 25; DragStartXInt := x; // Tolik 29/03/2017 -- // TF_CAD(parent).MoveCADOnPan(ADeltaX, ADeltaY); // // обычный Кад if Self.Owner.ClassName = 'TF_CAD' then TF_CAD(Self.Owner).MoveCADOnPan(ADeltaX, ADeltaY) else // мастер комплектации компонента if Self.Owner.ClassName = 'TF_MasterCompl' then TF_MasterCompl(Self.Owner).MoveCADOnPan(ADeltaX, ADeltaY) else // другое... exit; // end else if DragState = dsDetPan then begin Dist := x-round(DragStartXInt); DragStartXInt := x; FDetailLeft := FDetailLeft-dist; Dist := y-round(DragStartYInt); DragStartYInt := y; FDetailTop := FDetailTop-dist; ResetRegions; Refresh; end else {Mityai} //D0000006303 if (DragState = dsHRuler)and(GuidesVisible) then begin guType := gtHorz; DrawGuideOnSurface(x,y,guType); end else {Mityai} //D0000006303 if (DragState = dsVRuler)and(GuidesVisible) then begin guType := gtVert; DrawGuideOnSurface(x,y,guType); end; end; procedure TPCDrawBox.DragDropped(x, y: Integer); begin if CheckForGuideDrop(x,y) then begin isDragging := False; dragState := dsNone; Refresh; end; if (DragState = dsHScroll) or (DragState = dsVScroll) or (DragState = dsPan) or (DragState = dsDetPan) then begin ResetRegions; dragState := dsNone; isDragging := False; DragReadyInt := False; if autorefresh then DoSurfacePaint(Surface); DrawTrace; end; SetCursor(oldCursor); Screen.Cursor := crDefault; end; procedure TPCDrawBox.SetRulerValues(MapScale: Double; Mode: Integer); begin RulerMapScale := MapScale; RulerMode := Mode; refresh; end; function TPCDrawBox.GetPageRect: TRect; begin Result := Rect(PageLeft,PageTop,PageLeft+PageWidth,PageTop+PageHeight); end; procedure TPCDrawBox.setCenterGuide(const Value: Boolean); begin FCenterGuide := Value; if autorefresh then DoSurfacePaint(Surface); evCenterGuide.RaiseEvent(Value); Updated := True; SyncEnv; end; function TPCDrawBox.GetVisibleRect: TDoubleRect; var SWidth,SHeight,z:Double; p:TDoublePoint; begin SWidth := SurfaceWidth; SHeight := SurfaceHeight; p := DoublePoint(0,0); z := 0; DeConvertXY(p.x,p.y,z); result.Left := p.x; result.Top := p.y; p := DoublePoint(SWidth,SHeight); z := 0; DeConvertXY(p.x,p.y,z); result.Right := p.x; result.Bottom := p.y; end; procedure TPCDrawBox.SetSurfaceMargin(Value: Integer); begin FsurfaceMargin := Value; Relocate; end; procedure TPCDrawBox.ClearGuides; var i: Integer; begin try for i := 0 to Guides.Count - 1 do TGuideLine(Guides[i]).Free; GuidesCreatedOnDropCompon.Clear; Guides.Clear; Refresh; except // on E: Exception do AddExceptionToLog(CPowerCadMessage + 'TPCDrawBox.ClearGuides' + E.Message); end; end; procedure TPCDrawBox.setRulerColor(const Value: TColor); begin FRulerColor := Value; Refresh; end; procedure TPCDrawBox.setCoordZ(const Value: Double); begin FCoordZ := Value; end; procedure TPCDrawBox.CollectFaces; begin end; procedure TPCDrawBox.SetDetail(const Value: Boolean); begin FDetail := Value; CalculateDetailMargins; Refresh; end; procedure TPCDrawBox.setDetailHeight(const Value: Integer); begin FDetailHeight := Value; FDetailPosX := SurfaceWidth-FDetailWidth-20; FDetailPosY := 20; CalculateDetailMargins; Refresh; end; procedure TPCDrawBox.setDetailWidth(const Value: Integer); begin FDetailWidth := Value; FDetailPosX := SurfaceWidth-FDetailWidth-20; FDetailPosY := 20; CalculateDetailMargins; Refresh; end; procedure TPCDrawBox.SetDetailScale(Value: Integer); begin if Value < 10 then Value := 10; if Value > MaxScale then Value := MaxScale; FDetailScale := Value; CalculateDetailMargins; Refresh; end; procedure TPCDrawBox.CenterLocation(x,y:Double); var xrect:TDoubleRect; FRefresh:Boolean; lMar: Integer; event:TScrollValuesEvent; Begin FbarsLocked := True; xRect := DoubleRect(x,y,x,y); SetDpm(FDpmOrig * (FScale/100)); FRefresh := AutoRefresh; AutoRefresh := False; event := FScrollValues; FScrollValues := nil; DoPageLocate; FScrollValues := event; FbarsLocked := True; If HorzBarVisible then begin lmar := Round(SurfaceWidth - abs(xRect.Right-xRect.Left)*DotsPermil) div 2; if HorizontalZero = vzRight then scHorzPos := round(((FWorkWidth-xRect.right))*DotsPerMil-lmar) else scHorzPos := round((xRect.Left)*DotsPerMil-lmar); end; If VertBarVisible then begin lmar := Round(SurfaceHeight - abs(xRect.Top-xRect.Bottom)*DotsPermil) div 2; if VerticalZero = vzBottom then scVertPos := round(((FWorkHeight - xRect.Top))*DotsPerMil-lmar) else scVertPos := round(((xRect.Bottom))*DotsPerMil-lmar); end; AutoRefresh := Frefresh;; if AutoRefresh then DoSurfacePaint(Surface); If assigned(SOnScale) then SOnScale(self); SyncEnv; FbarsLocked := False; end; function TPCDrawBox.PointInView(x, y: Double): Boolean; var vrect: TDoubleRect; pt : TPoint; irect: Trect; z: Double; begin z := 0; ConvertXY(x,y,z); pt := Point(round(x),round(y)); vrect := GetVisibleRect; ConvertXY(vrect.left,vrect.top,z); ConvertXY(vrect.right,vrect.bottom,z); irect := Rect(round(vrect.left),round(vrect.top),round(vrect.Right),round(vrect.Bottom)); result := ptInrect(irect,pt); end; procedure TPCDrawBox.SetRulerSytem(const Value: TRulerSystem); begin if Value <> FrulerSystem then begin if FrulerSystem = rsMetric then begin GridStep := (GridStep/10)*8; end else begin GridStep := (GridStep/8)*10; end; end; FRulerSystem := Value; Refresh; evRulerSys.RaiseEvent(ord(Value)); end; procedure TPCDrawBox.DetConvertDim(var Dim: double); begin Dim := Round(Dim * DotsPerMilOrig * (FDetailScale/100)); end; procedure TPCDrawBox.DetConvertXY(var X, Y,Z: double); var dx,dy: Double; p: TDoublePOint; begin if HorizontalZero = vzRight then x :=WorkWidth-x; if VerticalZero = vzBottom then y :=WorkHeight-y; if FDetailStyle = dsIsometry then begin p := Doublepoint(x,y,z); p := ConvertIsometricPoint(p,FWorkHeight,isoAngle,isoType); x := p.x-FDetMarX; y := p.y-FDetMarY; end; dx := x-FDetailLeft; dy := y-FDetailTop; DetConvertDim(dx); DetConvertDim(dy); x := FDetailPosX+dx; y := FdetailPosY+dy; end; procedure TPCDrawBox.DetDeConvertDim(var Dim: Double); begin Dim := Dim / (DotsPerMilOrig * (FDetailScale/100)); end; procedure TPCDrawBox.DetDeConvertXY(var X, Y,Z: Double); var dx,dy:Double; p: TDoublePoint; begin dy := y-FdetailPosY; dx := x-FDetailPosX; DetDeConvertDim(dx); DetDeConvertDim(dy); x := FDetailLeft+dx; y := FDetailTop+dy; if FDetailStyle = dsIsometry then begin x := x+FDetMarX; y := y+FDetMarY; p := Doublepoint(x,y,z); p := DeConvertIsometricPoint(p,FWorkHeight,isoAngle,isoType); x := p.x; y := p.y; end; if HorizontalZero = vzRight then x :=WorkWidth-x; if VerticalZero = vzBottom then y :=WorkHeight-y; end; procedure TPCDrawBox.ZoomDetailArea(ZoomRect: TDoubleRect); var zW,zH,scw,sch,dpw,dph:Double; begin zw := abs(ZoomRect.Left-ZoomRect.Right); zh := abs(Zoomrect.top-ZoomRect.bottom); dpW := FDetailWidth/zW; scw := 100*(dpw/DotsPermilOrig); dpH := FDetailHeight/zH; sch := 100*(dph/DotsPermilOrig); if scw < sch then FDetailScale := Round(scw) else FDetailScale := Round(sch); FDetailLeft := ZoomRect.Left; FDetailTop := ZoomRect.Top; if HorizontalZero = vzRight then FDetailLeft :=WorkWidth-ZoomRect.Left; if VerticalZero = vzBottom then FDetailTop :=WorkHeight-ZoomRect.Top; if FDetailStyle = dsIsometry then CalculateDetailMargins(True); Refresh; end; procedure TPCDrawBox.ZoomDetailPoint(ZoomCenter: TDoublePoint); var cx,cy,cz: Double; dw,dh: Double; p:TDoublePoint; begin cx := ZoomCenter.x; cy := ZoomCenter.y; cz := ZoomCenter.z; ZoomDp := ZoomCenter; if HorizontalZero = vzRight then cx :=WorkWidth-cx; if VerticalZero = vzBottom then cy :=WorkHeight-cy; if FDetailStyle = dsIsometry then begin p := Doublepoint(cx,cy,cz); p := ConvertIsometricPoint(p,FWorkHeight,isoAngle,isoType); cx := p.x-FDetMarX; cy := p.y-FDetMarY; end; dw := FDetailWidth/(DotsPermilOrig*(FDetailScale/100)); dh := FDetailHeight/(DotsPermilOrig*(FDetailScale/100)); FDetailLeft := cx-(dw/2); FDetailTop := cy-(dh/2); Refresh; end; function TPCDrawBox.PointInDetail(x, y: Double): Boolean; var Drect:TDoubleRect; begin result := false; if not Fdetail then exit; if (FDetailStyle = dsIsometry) and (ToolIdx <> toSelect) then exit; Drect := DoubleRect(SurfaceWidth-FDetailWidth-20,20,SurfaceWidth-20,FDetailHeight+20); result := PointInRect(DoublePOint(x,y),dRect); end; procedure TPCDrawBox.SetBufferEngine; begin if FISometric then begin SetEngine(TempBitmap.Canvas,IsoConvertXY,IsoDeConvertXY,IsoConvertDim,IsoDeConvertDim,false,nil); end else begin SetEngine(TempBitmap.Canvas,ConvertXY,DeConvertXY,ConvertDim,DeConvertDim,false,nil); end; end; procedure TPCDrawBox.SetBufferDetailEngine; begin SetEngine(TempBitmap.Canvas,DetConvertXY,DetDeConvertXY,DetConvertDim,DetDeConvertDim,false,nil); end; procedure TPCDrawBox.SetDetailStyle(const Value: TDetailStyle); begin FDetailStyle := Value; CalculateDetailMargins; Refresh; end; procedure TPCDrawBox.CalculateDetailMargins(ReScale:Boolean=False); var p1,p2,p3,p4: TDoublePoint; z,dw,dh: Double; x,y: Double; minx,miny,maxX,maxY,cx,cy,mx,my,scw,sch,dpW,dpH: Double; dRect:TDoubleRect; begin dw := FDetailWidth/(DotsPermilOrig*(FDetailScale/100)); dh := FDetailHeight/(DotsPermilOrig*(FDetailScale/100)); dRect := DoubleRect(FDetailLeft,FDetailTop,FDetailLeft+dw,FDetailTop+dh); z := GetZAvg(dRect); p1 := DoublePoint(FDetailLeft,FDetailTop,z); p2 := DoublePoint(FDetailLeft+dw,FDetailTop,z); p3 := DoublePoint(FDetailLeft+dw,FDetailTop+dh,z); p4 := DoublePoint(FDetailLeft,FDetailTop+dh,z); p1 := ConvertIsometricPoint(p1,FWorkHeight,isoAngle,isoType); p2 := ConvertIsometricPoint(p2,FWorkHeight,isoAngle,isoType); p3 := ConvertIsometricPoint(p3,FWorkHeight,isoAngle,isoType); p4 := ConvertIsometricPoint(p4,FWorkHeight,isoAngle,isoType); minX := p1.x; minY := p1.y; maxX := p1.x; maxY := p1.y; if p2.x < minX then minx := p2.x; if p3.x < minX then minx := p3.x; if p4.x < minX then minx := p4.x; if p2.y < minY then minY := p2.y; if p3.y < minY then minY := p3.y; if p4.y < minY then minY := p4.y; if p2.x > maxX then maxX := p2.x; if p3.x > maxX then maxX := p3.x; if p4.x > maxX then maxX := p4.x; if p2.y > maxY then maxY := p2.y; if p3.y > maxY then maxY := p3.y; if p4.y > maxY then maxY := p4.y; cx := (minX+MaxX)/2; cy := (minY+MaxY)/2; if ReScale then begin dpW := FDetailWidth/(maxX-minx); scw := 100*(dpw/DotsPermilOrig); dpH := FDetailHeight/(maxY-miny); sch := 100*(dph/DotsPermilOrig); if scw < sch then FDetailScale := Round(scw) else FDetailScale := Round(sch); dw := FDetailWidth/(DotsPermilOrig*(FDetailScale/100)); dh := FDetailHeight/(DotsPermilOrig*(FDetailScale/100)); end; mx := cx - (dw/2); my := cy - (dh/2); FDetMarX := mx-FDetailLeft; FDetMarY := mY-FDetailTop; end; function TPCDrawBox.GetZAvg(dRect: TDoubleRect): Double; begin result := 0; end; function TPCDrawBox.HitTestModPoint(x, y: Double): TModPoint; begin result := nil; end; function TPCDrawBox.HitTestModPointDetVal(x, y: Integer): TModPoint; begin result := nil; end; function TPCDrawBox.HitTestModPointInt(x, y: Double): Integer; begin result := 0; end; function TPCDrawBox.HitTestModPointIntVal(x, y: Integer): TModPoint; begin result := nil; end; function TPCDrawBox.CheckByPointInt(LayerNbr, x, y: Integer): TFigure; begin result := nil; end; Procedure TPCDrawBox.setActiveLayer(value:integer); Begin if value > GetLayerCount - 1 then messagedlg('Invalid Layer Number',mterror,[mbOK],0) else begin FActiveLayer := value; Updated := True; end; end; function TPCDrawBox.GetLayerCount: integer; begin result := 0; end; procedure TPCDrawBox.setIsometric(const Value: Boolean); begin FIsometric := Value; Refresh; end; procedure TPCDrawBox.IsoConvertDim(var Dim: double); begin Dim := Round(Dim * DotsPerMil*ConvertRatio); end; procedure TPCDrawBox.IsoConvertXY(var X, Y, Z: double); begin IsoTo2D(x,y,z); ConvertXY(x,y,z); end; procedure TPCDrawBox.IsoDeConvertDim(var Dim: Double); begin Dim := Dim / (DotsPerMil*ConvertRatio); end; procedure TPCDrawBox.IsoDeConvertXY(var X, Y, Z: Double); begin DeConvertXY(x,y,z); end; procedure TPCDrawBox.CalculateIsometricMargins; var Minx,MinY,MaxX,MaxY:Double; var dx,dy: Double; begin FIsoMarX := 0; FIsoMarY := 0; GetIsometricBounds(MinX,MinY,MaxX,MaxY); dx := (FWorkWidth - (MaxX-MinX))/2; dy := (FWorkHeight - (MaxY-MinY))/2; FIsoMarx := dx-Minx; FIsoMarY := dy-Miny; end; procedure TPCDrawBox.GetIsometricBounds(var MinX, MinY, MaxX, MaxY: Double); begin end; procedure TPCDrawBox.IsoTo2D(var x, y, z: Double); var dx,dy: Double; p: TDoublePOint; begin if HorizontalZero = vzRight then x :=WorkWidth-x; if VerticalZero = vzBottom then y :=WorkHeight-y; p := Doublepoint(x,y,z); p := ConvertIsometricPoint(p,FWorkHeight,isoAngle,isoType); if HorizontalZero = vzRight then x :=WorkWidth-x; if VerticalZero = vzBottom then y :=WorkHeight-y; p.x := p.x+FIsoMarX; p.y := p.y+FIsoMarY; x := p.x; y := p.y; end; procedure TPCDrawBox.SetForceDefaultEngine; begin if CustomSurface <> nil then begin SetEngine(CustomSurface,ConvertXY,DeConvertXY,ConvertDim,DeConvertDim,false,nil); end else begin SetEngine(Surface.Canvas,ConvertXY,DeConvertXY,ConvertDim,DeConvertDim,false,nil); end; end; procedure TPCDrawBox.SetForceBufferEngine; begin SetEngine(TempBitmap.Canvas,ConvertXY,DeConvertXY,ConvertDim,DeConvertDim,false,nil); end; procedure TPCDrawBox.MoveDetailArea(dx, dy: Double); begin FDetailLeft := FDetailLeft+dx; FDetailTop := FDetailTop+dy; Refresh; end; procedure TPCDrawBox.DrawTrace; begin // end; procedure TPCDrawBox.SurfaceWheel(Shift: TShiftState; WheelDelta: Integer; MousePos: TPoint); var z,dx,dy: Double; ar:Boolean; delta: Integer; zs: Double; begin ZoomPointFlag := False; ar := AutoRefresh; dx := MousePos.x; dy := MousePos.y; DeConvertXY(dx,dy,z); ZoomPoint := DoublePoint(dx,dy); if DetailActive then begin AutoRefresh := False; if wheelDelta > 0 then DetailScale := DetailScale+10 else DetailScale := DetailScale-10; AutoRefresh := ar; ZoomDetailPoint(zoomdp); end else begin delta := Round((((wheelDelta/120)*20)/100)*ZoomScale); if delta = 0 then delta := 1; DoZoomDelta(delta); //PrintMessage(inttostr(wheelDelta)+':'+inttostr(ZoomScale)); end; ZoomPointFlag := False; end; procedure TPCDrawBox.SurfaceWheelPull(Shift: TShiftState; X, Y: Integer); begin end; procedure TPCDrawBox.SurfaceWheelPush(Shift: TShiftState; X, Y: Integer); begin end; procedure TPCDrawBox.SurfaceMouseWheel(Sender: TObject; Shift: TShiftState; WheelDelta: Integer; MousePos: TPoint; var Handled: Boolean); begin //IGOR -- 12/04/2016 -- { // TODO проверить зачем это - на 2.3.0 не было комментов и не было Handled := false; //Handled := True; //DoSurfaceWheel(DelphiSetToOleShift(Shift),WheelDelta,MousePos.x,MousePos.y); } Handled := false; end; procedure TPCDrawBox.SurfaceMiddleDblClick(Sender: TObject); begin if self.name = 'PCad' then begin if ToolIdx = TPCTool(toFigure) then begin GIsMousePressed := GIsMousePressed; exit; end; if FSCS_Main.aExpertMode.Checked then begin FSCS_Main.tbPanExpert.Down := True; end else begin FSCS_Main.tbPanNoob.Down := True; end; FSCS_Main.aToolPan.Execute; exit; end else begin if DetailActive then begin DetailScale := 100; ZoomDetailPoint(ZoomDp); end else begin FitToWindow; end; end; end; procedure TPCDrawBox.CadMouseWheel(Sender: TObject; Shift: TShiftState; WheelDelta: Integer; MousePos: TPoint; var Handled: Boolean); begin //MousePos := Self.ClientToScreen(MousePos); MousePos := Surface.ScreenToClient(MousePos); SurfaceMouseWheel(Sender,Shift,WheelDelta,MousePos,Handled); end; procedure TPCDrawBox.ZoomIn; begin DoZoomIn; end; procedure TPCDrawBox.ZoomOut; begin DoZoomOut; end; procedure TPCDrawBox.DoZoomDelta(Delta: Integer); begin ZoomScale := ZoomScale + Delta; end; procedure TPCDrawBox.setPageborder(const Value: Boolean); begin FDrawPageBorder := Value; if autorefresh then DoSurfacePaint(Surface); end; procedure TPCDrawBox.GotFocus(Sender: TObject); begin if not Self.Focused then Self.SetFocus; end; procedure TPCDrawBox.SimulateTrace(x, y: Double); var z: Double; begin z := 0; ConvertXY(x,y,z); SurfaceMove(Self,[],round(x),round(y)); end; procedure TPCDrawBox.SimulateDown(x, y: Double); var z: Double; begin z := 0; ConvertXY(x,y,z); SurfacePush(Self,mbLeft,[],round(x),round(y)); end; procedure TPCDrawBox.SimulateUp(x, y: Double); var z: Double; begin z := 0; ConvertXY(x,y,z); SurfacePull(Self,mbLeft,[],round(x),round(y)); end; procedure TPCDrawBox.SetDrawInCursor(const Value: Boolean); begin FdrawInCursor := Value; Refresh; end; procedure TPCDrawBox.SimulateRightClick(x, y: Double); var z: Double; begin z := 0; ConvertXY(x,y,z); //SurfacePush(Self,mbRight,[],round(x),round(y)); SurfacePull(Self,mbRight,[],round(x),round(y)); end; Procedure TPCDrawBox.SnapToGrid(var x,y:Double); //01.10.2013 begin CalculateSnapPoint(x,y); end; procedure TPCDrawBox.SurfacePaint; //07.08.2012 begin DoSurfacePaint(Surface); end; procedure TPCDrawBox.SurfaceMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); begin SurfaceMOve(Sender,Shift,x,y); end; procedure TPCDrawBox.setPageGuide(const Value: Boolean); begin FPageGuide := Value; Refresh; end; procedure TPCDrawBox.SaveScroll; begin scHorzPosSave := scHorzPos; scVertPosSave := scVertPos; end; procedure TPCDrawBox.RestoreScroll; begin scHorzPos := scHorzPosSave; scVertPos := scVertPosSave; Refresh; end; procedure TPCDrawBox.SetDpmOrig(const Value: Double); begin FDpmOrig := Value; Refresh; end; procedure TPCDrawBox.GetPageRect(var left, top, right, bottom: Integer); var xrect:TRect; begin xRect := GetPageRect; left := xRect.left; right := xrect.right; top := xrect.Top; bottom := xrect.Bottom; end; procedure TPCDrawBox.DoSurfaceWheel(Shift: Integer; WheelDelta: Integer; x,y:Integer); begin SurfaceWheel(OleShiftToDelphiSet(shift),WheelDelta, point(x,y)); end; procedure TPCDrawBox.DoSurfaceWheelPull(Shift: Integer; X, Y: Integer); begin SurfaceWheelPull(OleShiftToDelphiSet(shift), x,y); end; procedure TPCDrawBox.DoSurfaceWheelPush(Shift: Integer; X, Y: Integer); begin SurfaceWheelPush(OleShiftToDelphiSet(shift), x,y); end; function TPCDrawBox.GetToolData: Integer; begin result := FToolData; end; class function TGuideLine.CreateFromStream(Stream: TStream): TGuideLine; var xCode: Byte; aType: TGuideType; aCoord: Double; intVal: Integer; dblVal: Double; xByte: Byte; aautoCr: boolean; begin aautoCr := false; repeat Stream.Read(xCode, 1); if xCode = 20 then begin Stream.Read(intVal, sizeof(intVal)); aType := TGuideType(intVal); end; if xCode = 220 then begin Stream.Read(dblVal, sizeof(dblVal)); aCoord := dblVal; end; if xCode = 221 then begin Stream.Read(xByte, sizeof(xByte)); if xByte = 1 then aautoCr := True else aautoCr := False; end; until Stream.Position = Stream.Size; // aType := gtHorz; // aCoord := 100; Result := Self.create(aType, aCoord, aautoCr); end; procedure TGuideLine.WriteToStream(Stream: TStream); var xInt: integer; xDbl: double; xByte: byte; begin xInt := Ord(Self.gType); WriteField(20, Stream, xInt, sizeof(xInt)); xDbl := Self.coord; if self.fautoCr then xByte := 1 else xByte := 0; WriteField(220, Stream, xDbl, sizeof(xDbl)); WriteField(221, Stream, xByte, sizeof(xByte)); end; function TPCDrawBox.CheckForExistGuide(x, y: double; guType:TGuideType): Boolean; var g : TGuideLine; gx,gy,z : Double; a : Integer; Begin result := False; z := 0; CalculateSnapPoint(x,y); Convertxy(x,y,z); try For a := 0 to Guides.Count -1 do begin g := TGuideLine(Guides[a]); gx := g.coord; gy := g.coord; z := 0; ConvertXY(gx,gy,z); if guType = gtHorz then if (g.gType = gtHorz) and (abs(y - gy) <= 6) then begin GuideYold := Round(gy); result := true; exit; end; if guType = gtVert then if (g.gType = gtVert) and (abs(x - gx) <= 6) then begin GuideXold := Round(gx); result := true; exit; end; end; except // on E: Exception do AddExceptionToLog(CPowerCadMessage + 'TPCDrawBox.CheckGuideLine' + E.Message); end; end; procedure TPCDrawBox.DestroyCreatedOnDropGuides; var i: Integer; GL: TGuideLine; begin Guides.Assign(GuidesCreatedOnDropCompon, laXor); for i := 0 to GuidesCreatedOnDropCompon.Count - 1 do begin TGuideLIne(GuidesCreatedOnDropCompon[i]).free; end; GuidesCreatedOnDropCompon.Clear; end; function TPCDrawBox.CheckAndGetGuideDrop(X, Y: Integer; var GuideLine: TGuideLine; autoCr: boolean = False): Boolean; var gutype: TGuideType; guidex: Double; guidey,z: Double; begin result := false; if (DragState = dsHRuler) or (DragState = dsVRuler) then begin if Assigned(GuideLine) then GuideLine := nil; result := true; if DragState = dsHRuler then guType := gtHorz else guType := gtVert; GuideX := x; GuideY:= y;z :=0; DeConvertXY(GuideX,GuideY,z); if guType = gtHorz then begin GuideLine := TGuideLine.create(gtHorz,GuideY,autoCr); Guides.Add(GuideLine); guideYold := -5000; end else begin GuideLine := TGuideLine.create(gtVert,GuideX,autoCr); Guides.Add(GuideLine); guideXold := - 5000; end; end; end; end.