//{$A+,B-,C+,D+,E-,F-,G+,H+,I-,J-,K-,L+,M-,N+,O-,P+,Q-,R-,S-,T-,U-,V+,W-,X+,Y+,Z1} //{$MINSTACKSIZE $00004000} //{$MAXSTACKSIZE $00100000} //{$IMAGEBASE $00400000} //{$APPTYPE GUI} unit U_CAD; interface uses Windows, U_LNG, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, ExtCtrls, PCPanel, PCDrawBox, PCDrawing, PowerCad, StdCtrls, pcMsbar, ComCtrls, ToolWin, PCTypesUtils,DrawObjects,Menus, DlgBase, ExtDlgs, CommCtrl, PCLayerDlg, OleCtnrs, Buttons, PCgui, GuiStrings, DrawEngine, U_ESCadClasess, U_BaseCommon, U_SCSEngineTest, U_SCSComponent, U_SCSLists, cxLookAndFeelPainters, cxButtons, Mask, Math, AppEvnts, ShellCtrls, cxControls, cxContainer, cxEdit, cxTextEdit, cxMemo, Clipbrd, FPlan, siComp, siLngLnk, Jpeg, ActnList, U_HouseClasses, U_ArchCommon, ImgList,{Tolik}RzPanel, RzSplit, RzTabs, U_Common_Classes, Registry,{Tolik 22/03/2018 }cxClasses, cxGraphics, cxLookAndFeels, RzBHints, IniFiles; type (* {$IF Defined(SCS_PE) or Defined(SCS_PANDUIT)} {$I ToolBarType.pas} {$IFEND} *) TProjectUndoAction = class; TListUndoAction = class; TLinkUndoObject = class; TListUndoActionType = (uat_None, uat_Floor); TCheckBySelectedType = (cst_Move, cst_Delete); TListStampFields = record Margins: TDoubleRect; Developer: string[255]; //15.11.2011 - разработал Checker: string[255]; //15.11.2011 - проверил ListSign: string[255]; //02.10.2012 - Обозначение док-та MainEngineer: string[255]; //02.10.2012 - Главный инженер проекта Approved: string[255]; //02.10.2012 - Утвердил DesignStage: string[255]; //02.10.2012 - Стадия проектир. end; TF_CAD = class(TForm) PCad: TPowerCad; HorScroll: TScrollBar; VerScroll: TScrollBar; panProtocol: TPanel; mProtocol: TcxMemo; sbView: TStatusBar; sDiv: TSplitter; ApplicationEvents1: TApplicationEvents; lng_Forms: TsiLangLinked; TimerFindSnap: TTimer; TimerMovePan: TTimer; PopupMenuDisconected: TPopupMenu; MItem_ConnPoints: TMenuItem; Highlightdisconnected1: TMenuItem; Listofconnecteddisconnected1: TMenuItem; MItem_ConnLine: TMenuItem; MItem_NotConnPoint: TMenuItem; MItem_NotConnLine: TMenuItem; MItem_CableNoCanal: TMenuItem; TimerDblClk: TTimer; panView: TRzPanel; tbView: TToolBar; tbShowRuler: TToolButton; tbShowGrid: TToolButton; tbShowGuides: TToolButton; tbSnapGrid: TToolButton; tbSnapGuides: TToolButton; tbSnapNearObject: TToolButton; ToolButton4: TToolButton; LabelHighlight: TLabel; tbShowConnFullness: TToolButton; tbShowCableFullness: TToolButton; tbShowCableChannelFullness: TToolButton; tbShowDefectObjects: TToolButton; tbShowDisconnectedObjects: TToolButton; ToolButton2: TToolButton; tbShowTracesLengthLimit: TToolButton; tbNoMoveConnectedObjects: TToolButton; ToolButton5: TToolButton; tbDecView: TToolButton; tbIncView: TToolButton; tbActualsize: TToolButton; ToolButton1: TToolButton; tbShowPathLengthType: TToolButton; tbShowPathTraceLengthType: TToolButton; tbShowTransparency: TToolButton; cbManualCableTracingMode: TToolButton; cbMagnetToWalls: TToolButton; cbMagnetWalls: TToolButton; TimerShowPopup: TTimer; // Обработчик на закрытии формы с КАДом procedure FormCreate(Sender: TObject); // Обработчик на активации формы с КАДом procedure FormActivate(Sender: TObject); // Обработчик при закрытии формы с КАДом procedure FormClose(Sender: TObject; var Action: TCloseAction); // Обработчик выдачи запроса при попытке закрыть форму с КАДом procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean); // Обработчик нажатия клавиши на КАДе procedure PCadKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); // Обработчик отжатия нажатой клавиши на КАДе procedure PCadKeyUp(Sender: TObject; var Key: Word; Shift: TShiftState); // Обработчик при клике на КАДе procedure PCadSurfaceClick(Sender: TObject); // Обработчик при двойном клике на КАде procedure PCadSurfaceDblClick(Sender: TObject); // Обработчик при попытке вызвать контекстное меню КАДа (специально перекрыто, так как у нас свое) procedure PCadPopMenuClicked(Sender: TObject; MenuIndex: Integer); // Обработчик нажатия кнопки мыши на КАДе procedure PCadSurfaceMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Double); // Обработчик отжатия нажатой кнопки мыши на КАДе procedure PCadSurfaceMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Double); // Обработчик скроллирования вниз на форме с КАДом procedure FormMouseWheelDown(Sender: TObject; Shift: TShiftState; MousePos: TPoint; var Handled: Boolean); // Обработчик скроллирования вверх на форме с КАДом procedure FormMouseWheelUp(Sender: TObject; Shift: TShiftState; MousePos: TPoint; var Handled: Boolean); // Обработчик при перемещении мыши на КАДе procedure PCadSurfaceMove(Sender: TObject; Shift: TShiftState; X, Y: Double); // Обработчик при перемещении объекта на КАДе procedure PCadFigureMoved(Sender: TObject; Figure: TFigure; dx, dy: Double); // Обработчик после модификации объекта на КАДе procedure PCadFigureModify(Sender: TObject; Figure: TFigure); // Обработчик после выделения объекта на КАДе procedure PCadFigureSelect(Sender: TObject; Figure: TFigure); // Обработчик после смены выделения на КАДе procedure PCadSelectionChange(Sender: TObject); // Обработчик после вставки объекта на КАД (или просто создание или скажем вставка картинки/блока) procedure PCadObjectInserted(Sender: TObject; Reason: TInsertReason); // Обработчик перед физическим удалением объекта с КАДа procedure PCadBeforeDelete(Sender: TObject; Figure: TFigure; var CanDelete: Boolean); // Обработчик при возникновения какого либо события на КАДе (оброботка по ID события) procedure PCadGUIEvent(Sender: TObject; EventId, Numval: Integer; StrVal: String; DblVal: Double; CEnable: Boolean); // Обработчик на ресайзе форма с КАДом procedure FormResize(Sender: TObject); // Обработчик DragOver (тащишь c НБ что то и ведешь над КАДом) procedure PCadSurfaceDragOver(Sender, Source: TObject; X, Y: Double; State: TDragState; var Accept: Boolean); // Обработчик DragDrop (Бросаешь на КАДом, то что ты тащил) procedure PCadSurfaceDragDrop(Sender, Source: TObject; X, Y: Double); // Обрабочик изменения масштаба КАДа procedure PCadScaleChanged(Sender: TObject); // Уставновка горизонтального скролла PowerCad procedure HorScrollScroll(Sender: TObject; ScrollCode: TScrollCode; var ScrollPos: Integer); // Уставновка вертикального скролла PowerCad procedure VerScrollScroll(Sender: TObject; ScrollCode: TScrollCode; var ScrollPos: Integer); // Обработчик на деактивации формы с КАДом procedure FormDeactivate(Sender: TObject); // Обработчик отлавливания событий на КАДе (прописаны нужные нам события) procedure ApplicationEvents1Message(var Msg: tagMSG; var Handled: Boolean); // Обработчик на скроллировании на форме с КАДом procedure FormMouseWheel(Sender: TObject; Shift: TShiftState; WheelDelta: Integer; MousePos: TPoint; var Handled: Boolean); // перемещение сплитера изменяющего размеры поля протокола procedure sDivMoved(Sender: TObject); // Обработчик на Refresh КАДа procedure FCADOnRefresh(Sender: TObject); // Обработчик при нажатии клавиши на КАДе (нажатие и отжатие) Procedure FCADOnKeyStroke(Sender:TObject;Key:Word;Shift:TShiftState; var CanHandle:Boolean); // Обработчик на изменении MapScale на КАДе procedure PCadMapScaleChanged(Sender: TObject); // Обработчик на проверке ресайза сплита для протокола procedure sDivCanResize(Sender: TObject; var NewSize: Integer; var Accept: Boolean); procedure FOnBeforeMove(Sender: TObject; Figure: TFigure; aDeltaX: double = -999999; aDeltaY: double = -999999); procedure FOnMoveByArrows(Sender: TObject; dx, dy: Double; var CanMove: Boolean); procedure PCadAfterDelete(Sender: TObject); procedure TimerFindSnapTimer(Sender: TObject); procedure tbDropDownClick(Sender: TObject); procedure TimerMovePanTimer(Sender: TObject); procedure FormDestroy(Sender: TObject); procedure FormCanResize(Sender: TObject; var NewWidth, NewHeight: Integer; var Resize: Boolean); procedure PopupMenuDisconectedPopup(Sender: TObject); procedure TimerDblClkTimer(Sender: TObject); procedure PCadSurfaceLeave(Sender: TObject); procedure PCadToolChanged(Sender: TObject); procedure tbShowTransparencyClick(Sender: TObject); procedure mProtocolPropertiesChange(Sender: TObject); procedure cbManualCableTracingModeClick(Sender: TObject); procedure PCadSurfaceEndDrag(Sender, Target: TObject; X, Y: Double); procedure cbMagnetToWallsClick(Sender: TObject); procedure FormShow(Sender: TObject); procedure TimerShowPopupTimer(Sender: TObject); // IGOR private //Tolik 26/02/2022 -- GpopupMenu: TPopupMenu; gx: Double; gy: Double; // { Private declarations } FCurrentLayer: Integer; // текущий слой, для чтения свойства FCurrX: Double; // drag-drop X FCurrY: Double; // drag-drop Y FDragX: Double; // drag-drop X FDragY: Double; // drag-drop Y FDeltaX: Double; // Mouse delta X FDeltaY: Double; // Mouse delta Y // Tolik 28/08/2019 -- //FPanLastRefeshTick: Cardinal; //FDragOverTick: Cardinal; FPanLastRefeshTick: DWord; FDragOverTick: Dword; // FFirstActivate: boolean; //Tolik OnceRefresh : boolean; CreateOnClick: Boolean; // // Tolik 05/05/2021 -- tbView_oldProc: TWndMethod; Procedure tbView_NewProc(var message: TMessage); // // установка текущего слоя procedure SetCurrentLayer(ALNbr: Integer); // при вызове контекстного меню на КАДе procedure FormCADPopupMenu(X, Y: Double; aAllowSelectInPM: Boolean); // Установка пунктов меню для контекстного меню Трассы procedure SetMenuItemsForOrthoLine(aLine: TOrthoLine); // Установка пунктов меню для контекстного меню коннектора procedure SetMenuItemsForConnector(aConn: TConnectorObject); // Установка пунктов меню для контекстного меню Объекта procedure SetMenuItemsForObject(aObject: TConnectorObject); //D0000006113 //Отмена выделениия объекта рамкой procedure UnSnapFigure; //Запись данных в переменную FCreateObjectOnClick procedure WriteOnClickParam(Const Value: Boolean); //Tolik procedure NewWndProc(var Message: TMessage); protected FClickSCSFiguresList: TList; //21.06.2013 - Список объектов под курсором на клике // FFiguresDelManual: TList; //02.08.2013 - ОБЪЕКТЫ УДАЛЯЕМЫЙ ВРУЧНУЮ ПОЛЬЗОВАТЕЛЕМ // Обработчик получения объекта для выделения procedure PCadGetFigureToSelect(Sender: Tobject; var Figure: TFigure; x, y: double); //#From Oleg# //04.10.2010 procedure PCadGetModPointToSelect(Sender: Tobject; var ModPoint: TModPoint; x, y: double); //#From Oleg# //23.08.2011 procedure PCadBeforeEndTrace(Sender: TObject); //25.11.2011 function PCadCheckPrnWithOffset(Sender: Tobject): Boolean; //29.11.2011 procedure PCadTraceDraw(Sender: TObject; Figure: TFigure; DeltaX: double = -999999; DeltaY: double = -999999); procedure PCadFigureEdit(Sender: TObject; Figure: TFigure; DeltaX: double = -999999; DeltaY: double = -999999); public { Public declarations } FFiguresDelManual: TList; //02.08.2013 - ОБЪЕКТЫ УДАЛЯЕМЫЙ ВРУЧНУЮ ПОЛЬЗОВАТЕЛЕМ // Tolik InGUIEvent: Boolean; GIsEventWaiting: Boolean; // FNeedDelete: Boolean; FWaitWork: Boolean; // приостановка работы, пока не выполниться цикл операций (применяется для удаления объектов) FShowLinesLength: Boolean; // показывать длинну линии FShowConnectorsCaptions: Boolean; // показывать подписи к коннекторам FShowLinesNotes: Boolean; // показывать выноски к линиям FShowConnectorsNotes: Boolean; // показывать выноски к коннекторам FShowLinesCaptions: Boolean; // показывать подписи к линиям FAutoSelectTrace: Boolean; // автовыделять трассу до сервера // показывать заполненность объектов на КАДе FShowConnFullness: Boolean; FShowCableFullness: Boolean; FShowCableChannelFullness: Boolean; FShowDefectObjects: Boolean; FShowDisconnectedObjects: Boolean; // показывать объекты, которые ни к чему не присоединены FShowTracesLengthLimit: Boolean; // показывать трассы с превышающей длиной FAutoTraceBySelected: Boolean; // автотрассировать по выбранным объектам FNoMoveConnectedObjects: Boolean; // Не перемещать подсоединенные объекты // FCreateObjectOnClick: Boolean; // Автосоздавать объекты при клике мышкой FGroupListObjectsByType: Boolean; // группировать FPutCableOnTrace: Boolean; // Ложить кабель на участки трассы FShowRaise: Boolean; // отображать/не отображать с-п //FShowRaiseDrawFigure: Boolean; // Отображать УГО на с-п FKeepLineTypesRules: Boolean; // соблюдать правила для всех трасс LastSnapGridStatus: Boolean; // последний сохраненный статус привязки к сетке FShowCabinetsNumbers: Boolean; // отображать номера кабинетов на КАД FShowCabinetsBounds: Boolean; // отображать границы кабинетов на КАД FCADListID: Integer; // ID КАД листа FCADListIndex: Integer; // Индекс КАД листа FJoinedBoxIDForDesignList: Integer; // для листа - Дизайна шкафа, ID Шкафа с которого сделан лист FJoinedListIDForDesignList: Integer; // для листа - Дизайна шкафа, ID листа с которого сделан лист FDesignListShowName: Boolean; // для листа - Дизайна шкафа, показывать наименование FDesignListShowSign: Boolean; // для листа - Дизайна шкафа, показывать обозначение FDesignListShowMark: Boolean; // для листа - Дизайна шкафа, показывать маркировку FShowCableChannelsOnly: Boolean; // показывать на КАДе только объекты с кабельными каналами FAllowSuppliesKind: Boolean; // учитывать вид поставки при прокладке кабеля (разделять трассы) FDefaultTraceWidth: Integer; // ширина трассы по умолчанию FDefaultTraceStepRotate: Integer; // шаг угла поворота по умолчанию FRoomHeight: Double; // высота этажа FFalseFloorHeight: Double; // высота подвесного потолка FConnHeight: Double; // высота ТО (точ. объект) FLineHeight: Double; // высота ЛО (лин. объект) FLengthKoef: Double; // процент запаса длины кабеля FCableChannelFullnessKoef: Double; // Коэффициент заполненности кабельных каналов FPortReserv: Double; // резерв со стороны порта FMultiportReserv: Double; // рензерв со стороны мультипорта FTwistedPairMaxLength: Double; // ограничение по длине кабеля для витой пары FDefaultBlockStep: Double; // шаг УГО трассы по умолчанию FCADProjectName: String; // имя проекта FCADListName: String; // имя листа FCADListFileName: String; // имя файла для отката FNotePrefix: string; // префикс отображения для кол-ва (в подписи) FFontName: string; // Имя шрифта FListSettings: TListSettingRecord; FRemFigures: TList; // лист удаленных объектов (удаляются объекты все вместе на обработчике из этого листа) FActiveNet: TNet; // текущий FPlan FListType: TListType; // Тип листа (обычный или дизайн шкафа) FLineTracingType: TLineTracingType; // Тип прокладки трассы/кабеля/короба // показ полные/краткие подписи к объектам FShowObjectCaptionsType: TShowType; FShowLineCaptionsType: TShowKind; // показ полные/краткие выноски к объектам FShowObjectNotesType: TShowType; FShowLineNotesType: TShowKind; FCadStampType: TStampType; // тип рамки листа (простой, расширенный ...) FCadStampLang: TStampLang; // язык для рамки листа (рус, укр) //FCadStampMargins: TDoubleRect; //10.11.2011 - отступы рамки листа //FCADStampDeveloper: string; //15.11.2011 - разработал //FCADStampChecker: String; //15.11.2011 - проверил FStampFields: TListStampFields; FShowNetworkTypes: TObjectNetworkTypes; // отображение по типам сетей FDefaultTraceColor: TColor; // текущий цвет отображения участков трассы FDefaultTraceStyle: TPenStyle; // текущий стиль отображения участков трассы FClickType: TClickType; // тип клика (уже не юзается) FDefaultCornerType: TCornerType; // тип уголка по умолчанию // рамка листа FFrameFileName: string; // имя файла с которого загружена рамка листа FFrameProjectName: TRichText; // на рамке листа, объект - название проекта FFrameListName: TRichText; // на рамке листа, объект - название листа FFrameCodeName: TRichText; // на рамке листа, объект - код FFrameIndexName: TRichText; // на рамке листа, объект - код FFrameStampDeveloper: TRichText; // на рамке листа, объект - разработал FFrameStampChecker: TRichText; // на рамке листа, объект - проверил FFrameObjects: TStringList; FShowMainStamp: Boolean; // показывать основной штамп на рамке листа FShowUpperStamp: Boolean; // показывать верхний штамп на рамке листа FShowSideStamp: Boolean; // показывать боковой штамп на рамке листа FShowPathLengthType: TShowPathLengthType; // sltPoints, sltInner, sltOuter FShowPathTraceLengthType: TShowPathLengthType; // --- FCurrPCadScrollX: Integer; // текущая позиция скролла по Х FCurrPCadScrollY: Integer; // текущая позиция скролла по Y FDimLinesType: TDimLinesType; // тип размерных линий FLinesCaptionsColor: Integer; // цвет подписей к линиям FConnectorsCaptionsColor: Integer; // цвет подписи к коннекторам FLinesNotesColor: Integer; // цвет выносок к линиям FConnectorsNotesColor: Integer; // цвет выносок к коннекторам FLinesCaptionsFontSize: Integer; // размер шрифта для подписей к линиям FConnectorsCaptionsFontSize: Integer; // размер шрифта для подписей к коннекторам FLinesNotesFontSize: Integer; // размер шрифта для выносок к линиям FConnectorsNotesFontSize: Integer; // размер шрифта для выносок к коннекторам FLinesCaptionsFontBold: Boolean; // жирность подписи к линиям FCrossATSFontSize: Integer; // размер шрифта для подписей к кросс АТС FCrossATSFontBold: Boolean; // жирность для подписи к кросс АТС FDistribCabFontSize: Integer; // размер шрифта для подписей к РШ FDistribCabFontBold: Boolean; // жирность для подписи к РШ FPrintType: TPrintType; // тип печати (цветная, ч-б) FSCSType: TSCSType; // тип СКС (внутренняя, внешняя) FNewTraceLengthType: TTraceLengthType; // новые фичи (Автокад) FAutoCadMouse: Boolean; // мышь автокад FScaleByCursor: Boolean; // позиционировать по курсору FAutoPosTraceBetweenRM: Boolean; // автопозиционирование трасс между двумя РМ (на их высоте) // для трассировки по отмеченным FTracingList: TList; // лист с текущим путем при трассировке FTracingListIndex: Integer; // текущий порядковый номер пути из всех возможных путей трассировки FIsDragOver: Boolean; // если сейчас режиим DragOver // кол-во листов FListCountX: Integer; // кол-во листов по горизонтали FListCountY: Integer; // кол-во листов по вертикали // для Ctrl+Z и Ctrl+Y // лист в котором хранятся слепки для Ctrl+Z FSCSUndoList: TList; // лист в котором хранятся слепки для Ctrl+Y FSCSRedoList: TList; FCheckedFigures: TList; FNeedUpdateCheckedFigures: boolean; // флаг, можно сейчас делать слепок FCanSaveForUndo: Boolean; FUndoCount: Integer; //10.09.2010 // директория для сохранения слепка FUndoDir: string; FRedoDir: string; // лист СКС объектов для поднятия со Стрима FUndoFiguresList: TList; // статус - поднимать с листа FUndoFiguresList FUndoStatus: Boolean; // текущее кол-во активных действий на КАДе FActiveActions: LongInt; // кол-во действий после которых следует делать слепок FSaveUndoCount: Integer; FWasDeleteQuery: Boolean; FDeleteOnlyUnuseRaisers: Boolean; FActiveHouse: THouse; FSCSFigures: TRapObjectList; //04.11.2011 //Tolik -- 02/12/2016-- список удаленных фигур с Када (нужен для того, чтобы перед закрытием листа убить // и те фигуры, которые перед закрытием листа удалил пользователь, потому что на Каде их нет, они будут просто висеть в памяти, // и с закрытием листа просто "потеряются", что практически приведет к утечке памяти во время работы приложения, если работать с несколькими проектами // или добалять/удалять листы в обном проекте -- ЭТО КАСАЕТСЯ ТОЛЬКО НЕ SCS ФИГУР типа простой линии, квадратика, круга и т.п., т.е. тех, которые // нарисованы на подложке) FNotSCSDeletedFiguresList: TList; // FSCSFiguresLockCount: Integer; //07.11.2011 FPopupScrPoint: TPoint;//04.05.2012 FContinueTrace: boolean; // Added by Tolik // флажок для отметки удаления/не удаления спусков-подъемов // из списка выделенных объектов // нужен при пересчете длины выбранных трасс FDeselectUpDown : boolean; FCadClose: boolean; // -- признак закрытия Када (чтобы не пошел рефреш) //Для определения, нужно ли перерисовывать кад или нет при движении XOld,YOld: Double; CadMove: Boolean; DownPoints: TDoublePOint; CanChangeDownCoord: Boolean; //Отвечает за возможность изменения координат при маусдауне,чтоб кака не получилась //23/10/2015 // флажки выполнения события на КАДе в текущий момент (нужно определять состояние при попытке // выполнения события, чтобы события не перекрывались) // события клавиатуры GisKeyDown: Boolean; GisKeyPress: Boolean; // события мыши GisMouseDown: Boolean; GisMouseMove: Boolean; //06/11/2015 GisDivideLine: Boolean; // true - идет разделение линии. Будет юзаться при разделении линии, чтобы понимать, // нужна ли полная/частичная чистка интерфейсов после операции копирования компонентов // Tolik -- 12/01/2017 -- GWin10GDIMessage: Boolean; // // GisAction: Boolean; GPCadPrevSelCount: integer; // Tolik 24/07/2021 -- GWallTracePointList: TList; // Tolik 14/01/2021 -- // property DeselectUpDown : boolean read FDeselectUpDown write FDeselectUpDown default false; property FCreateObjectOnClick: Boolean read CreateOnClick write WriteOnClickParam; // Автосоздавать объекты при клике мышкой property CurrentLayer: Integer read FCurrentLayer write SetCurrentLayer; // текущий слой property CurrX: Double read FCurrX write FCurrX; property CurrY: Double read FCurrY write FCurrY; property DragX: Double read FDragX write FDragX; // drag-drop X property DragY: Double read FDragY write FDragY; // drag-drop Y procedure UpdateCheckedFigures(aCheckUpdateCount: boolean = True); // === ScrollBars === // если есть горизонтальные скроллы Function IfVisibleHorScrollBar: Boolean; // если есть вертикальные скроллы Function ifVisibleVerScrollBar: Boolean; // максимальная позиция скроллов PCAD Function GetMaxScrollsPosition: TPoint; // получение размера скроллов PCAD Function GetPageSizesScrolls: TPoint; // установка позиции скроллов PCAD Procedure Set_PCad_HorScroll; Procedure Set_PCad_VerScroll; // установка позиции наших скроллов Procedure Set_SCS_HorScroll; Procedure Set_SCS_VerScroll; // изменение скролов при изменении размеров листа КАД Procedure ChangeScrollsOnChangeListSize; // перемещать КАД в режиме паноромирования Procedure MoveCADOnPan(ADeltaX, ADeltaY: double); // проверка на скроллирование КАДа при Шедоу трассы или перемещение за ТО, если подводит в краю КАДа Function CheckScrollingOnTracing(ax, ay: double): Boolean; // скроллирование КАДа при Шедоу трассы или перемещение за ТО, если подводит в краю КАДа Procedure ScrollCADOnTracing(adeltax, adeltay: double); // установить масштаб КАДа Procedure SetZoomScale(aScale: Integer); // Событие на выделение объекта на КАД (если вариантов несколько то выбор что именно выделить) procedure SelectFigureEvent(Sender: TObject); // Событие на Дропе объекта на КАД (с НБ) procedure DropFigureEvent(Sender: TObject); // Событие на привязке к Объекту procedure SnapFigureEvent(Sender: TObject); // процедура после DragDrop procedure DoDragDrop(X, Y: Double; aOnDropRoute: TFigure = nil; aTraceOnEntireRoute: boolean = False); procedure DoFragDropDesigList; procedure AutoDivideTraceOnAppendCable(aTrace: TOrthoLine; aLength: Double); // для масштабирования - получение коэффициентов для формулы function GetScaleKoefs: TDoublePoint; // получение угла объекта Function GetFigureAngle(AP1x, AP1y, AP2x, AP2y: Double): Double; // Tolik 13/07/2017 -- Function GetPieAngle(Fangle, SAngle: Double): Double; // // получить последний выделенный на КАДе СКС объект (орттолиния или коннектор) function GetLastSelectedSCSObject: TFigure; // повернуть группу объектов на 5 градусов вперед или назад через клаву procedure RotateObjectsByKeyboard(aObjects: TList; aAngle: Double); // Ctrl+Z ... // сохранить текущее состояние в темповый файл // Toilk 03/06/2021 - - здесь добавляем флажок, чтобы видеть, когда ундо приходит с применения свойств листа, // чтобы сделать одинаковый откат для всех типов листов, иначе не сможем откатить на всех схемах применение свойств листа //function SaveForUndo(aType: TListUndoActionType; aSavePM: Boolean; aIsProject: Boolean; aProjectIndex: Integer = 0): TListUndoAction; function SaveForUndo(aType: TListUndoActionType; aSavePM: Boolean; aIsProject: Boolean; aProjectIndex: Integer = 0; aFromMasterNewList: Boolean = false): TListUndoAction; // function SaveForUndoNormalList(aType: TListUndoActionType; aSavePM: Boolean; aIsProject: Boolean; aProjectIndex: Integer = 0): TListUndoAction; function SaveForUndoProjectPlan(aType: TListUndoActionType; aSavePM: Boolean; aIsProject: Boolean; aProjectIndex: Integer = 0): TListUndoAction; // Tolik 12/02/2021 function SaveForUndoELScheme(aType: TListUndoActionType; aSavePM: Boolean; aIsProject: Boolean; aProjectIndex: Integer = 0): TListUndoAction; // function SaveForUndoDesignList(aType: TListUndoActionType; aSavePM: Boolean; aIsProject: Boolean; aProjectIndex: Integer = 0): TListUndoAction; // поднять предыдущее состояние из темпового файла procedure SCSUndoNormalList; procedure SCSUndoProjectPlan; procedure SCSUndoDesignList; procedure SCSUndoElScheme; // Tolik 12/02/2021 -- procedure OnAfterUndo; // очистить UndoList procedure ClearUndoList(AFreeList: Boolean=true); function BeginSaveForUndo(aType: TListUndoActionType; aSavePM: Boolean; aIsProject: Boolean; aProjectIndex: Integer = 0): TListUndoAction; procedure EndSaveForUndo; // Ctrl+Y ... // сохранить текущее состояние в темповый файл function SaveForRedo(aType: TListUndoActionType; aSavePM: Boolean; aIsProject: Boolean; aProjectIndex: Integer = 0): TListUndoAction; function SaveForRedoNormalList(aType: TListUndoActionType; aSavePM: Boolean; aIsProject: Boolean; aProjectIndex: Integer = 0): TListUndoAction; function SaveForRedoProjectPlan(aType: TListUndoActionType; aSavePM: Boolean; aIsProject: Boolean; aProjectIndex: Integer = 0): TListUndoAction; function SaveForRedoDesignList(aType: TListUndoActionType; aSavePM: Boolean; aIsProject: Boolean; aProjectIndex: Integer = 0): TListUndoAction; // Tolik 12/02/2021 -- function SaveForRedoElScheme(aType: TListUndoActionType; aSavePM: Boolean; aIsProject: Boolean; aProjectIndex: Integer = 0): TListUndoAction; // procedure SetShowPathLengthType(AShowPathLengthType: TShowPathLengthType); procedure SetShowPathTraceLengthType(AShowPathLengthType: TShowPathLengthType); // Tolik 06/02/2017 -- // procedure SetParamsByShowPathLengthType(AToolButton: TToolButton; AShowPathLengthType: TShowPathLengthType; // APoints, AInner, AOuter: TCustomAction); procedure SetParamsByShowPathLengthType(AToolButton: TToolButton; AShowPathLengthType: TShowPathLengthType; APoints, AInner, AOuter: TCustomAction; ACaption: Integer); // // поднять предыдущее состояние из темпового файла procedure SCSRedoNormalList; procedure SCSRedoProjectPlan; procedure SCSRedoDesignList; //Tolik 12/02/2021 -- procedure SCSRedoElScheme; // // очистить UndoList procedure ClearRedoList(AFreeList: Boolean=true); // очистить все СКС объекты procedure ClearSCSFigures; procedure ClearPlanFigures; // проверить делать ли сейчас слепок function CheckMakeSaveForUndo: boolean; procedure BuildPopupFiguresByLevel(AFiguresList:TList; AOnClick: TNotifyEvent; AX: Double=-1; AY: Double=-1); function RemoveFigureFromSelected(AFigure: TFigure): Integer; procedure RemoveSelectedWithoutCheck; //13.03.2012 - удалить все выделенные, без проверки событием OnFigureDel //function OnGetShowPathLength(Sender: TObject): Double; //function OnGetShowPathTraceLength(Sender: TObject): Double; function OnGetShowPathLengthType(Sender: TObject): TShowPathLengthType; function OnGetShowPathTraceLengthType(Sender: TObject): TShowPathLengthType; procedure AddSCSFigure(AFigure: TFigure); procedure RemoveSCSFigure(AFigure: TFigure); procedure LockSCSFigures; procedure UnLockSCSFigures; procedure ClearFrameFigures; //17.11.2011 procedure SetFrameFigures; //18.11.2011 procedure DeleteLayerAllObjects(aLayerNumber: Integer; aQuast: Boolean); procedure DeleteSelection(aQuast: Boolean); procedure View3D; function Get3DModel: TObject; function GetMsgLengthToPoint(const aLen: Double): String; function CreateConnector(x,y,z: Double; aLayerHandle: Integer; aConnectorType: TConnectorType; const aName: string): TConnectorObject; function CreateConnForFloorRaise(x,y,z: Double; aLayerHandle: Integer): TConnectorObject; procedure SelectTracesAndRaisers; procedure SelectTraces; procedure InvertSCSSelection; procedure InvertAllSelection; procedure DrawGuidesOnDrop(X,Y: Double; aFromClick: boolean = false); Procedure ShowHintIFFigInsideCab(X,Y: Double); procedure FullEndUpdateCad(aNeedRefresh: Boolean = False); function CreateConnectorInPM(InsertedObject: TFigure): integer; Procedure ShowHideButtons; // Tolik 27/01/2022 -- end; TProjectUndoAction = class(TMyObject) FLinkUndoObject: TList; Constructor Create; Destructor Destroy; override; end; TListUndoAction = class(TMyObject) ActionType: TListUndoActionType; FIndex: Integer; FProjectUndoAction: TProjectUndoAction; FCadFileName: string; FBasePath: string; FIsProject: Boolean; FSavePM: Boolean; Constructor Create(aType: TListUndoActionType; aSavePM: Boolean); Destructor Destroy; override; end; TLinkUndoObject = class(TMyObject) FCad: TF_CAD; FListUndoAction: TListUndoAction; Constructor Create; Destructor Destroy; override; end; (* {$IF Defined(SCS_PE) or Defined(SCS_PANDUIT)} {$I ToolBarType2.pas} {$IFEND} *) var F_CAD: TF_CAD; GBeginPoint: TDoublePoint; // точка начала линии, при повороте линии позволяет автовычислять угол поворота GTracedFigure: boolean = False; // тащут ли сейчас какой то объект GListNode: TTreeNode = nil; // для МП - текущая ветвь в которую копируется объект (хз сильно ли оно щас надо) // Tolik // флажок ружен для определения С/П на коннекторе, когда дроп происходит, допустим не не КАДе, а в мереждере проектов // при перемещении объекта в объект (сработает DoDragDrop)/ Завязано в мастере автотрассировки, ковырять аккуратно!!! GDragOnCAD: Boolean = False; GCallAutoTraceElectricMaster: Boolean = false; // флажок вызова мастера автотрассировки из процедуры создания трасс implementation uses USCS_main, U_MAIN, Types, U_Navigator, U_SizePos, U_Layers, U_SCSObjectsProp, U_TrunkSCS, U_Constants, U_BaseConstants, U_Common, U_DimLineDialog, U_ObjsProp, U_BlockParams, U_InputMark, U_AutoTraceType, U_AutoTraceConnectOrder, U_Progress, {Tolik} U_CheckWinVer, cxScrollBar, U_ReportForm; {$R *.dfm} procedure TF_CAD.FormCreate(Sender: TObject); var CrLayer: TLayer; i: integer; //08.09.2011 Buffer: array[0..1023] of Char; begin try //Tolik 24/12/2023 -- //if GGlobalRichText = nil then // GGlobalRichText := TRichText.create(); //Tolik 26/02/2022 -- GPopupMenu := nil; gx := 0; gy := 0; // GWallTracePointList := TList.Create; // Tolik 14/01/2021 -- //Tolik 29/12/2021 -- //cbMagnetToWalls.Down := False; //cbMagnetToWalls.Hint := MagnetMsg2; cbMagnetToWalls.Down := True; cbMagnetToWalls.Hint := MagnetMsg1; cbMagnetWalls.Down := True; //Tolik 10/08/2021 -- GisUserDimLine := False; GuserScaleVal := 0; // GPCadPrevSelCount := 0; // Tolik 24/07/2021 -- //cbManualCableTracingMode.Down := False; cbManualCableTracingMode.Down := True; GAutoAddCableAfterDragDrop := True; // Tolik InGUIEvent := False; GisEventWaiting := False; FNotSCSDeletedFiguresList := TList.Create; FCadClose := False; tbShowTransparency.Down := True; // 28/06/2017 -- поддерживать прозрачность // CanChangeDownCoord := true; FContinueTrace := False; FSCSFigures := TRapObjectList.Create(false, false); FSCSFiguresLockCount := 0; FClickSCSFiguresList := TList.Create; FFiguresDelManual := TList.Create; //02.08.2013 //17.11.2011 объекты рамки листа FFrameProjectName := nil; FFrameListName := nil; FFrameCodeName := nil; FFrameIndexName := nil; FFrameStampDeveloper := nil; FFrameStampChecker := nil; FFrameObjects := TStringList.Create; FFirstActivate := True; for i := 1 to ctFrameTypeCount do FFrameObjects.Add(IntToStr(i*100)); // от 100 до 600 PCad.RangeCheck := True; WindowState := wsMinimized; GNowRefresh := False; GIsDrawShadow := False; FWaitWork := False; Self.Tag := Self.Handle; PCAD.MaxScale := cntCADMaxScale; // PCad.MapScale := 100; // Register Classes PCad.RegisterFigureClass(TOrthoLine); PCad.RegisterFigureClass(TConnectorObject); PCad.RegisterFigureClass(TFigureGrpMod); PCad.RegisterFigureClass(TFigureGrpNotMod); PCad.RegisterFigureClass(TTextMod); PCad.RegisterFigureClass(TFrame); PCad.RegisterFigureClass(TSCSHDimLine); PCad.RegisterFigureClass(TSCSVDimLine); PCad.RegisterFigureClass(TRichTextMod); PCad.RegisterFigureClass(TPlanTrace); PCad.RegisterFigureClass(TPlanObject); PCad.RegisterFigureClass(TPlanConnector); PCad.RegisterFigureClass(TInsertCol); PCad.RegisterFigureClass(TWallPath); //PCad.RegisterFigureClass(TWallDivPath); PCad.RegisterFigureClass(TWallRect); PCad.RegisterFigureClass(TCabinet); PCad.RegisterFigureClass(TCabinetExt); PCad.RegisterFigureClass(TCabinetNumber); PCad.RegisterFigureClass(TCadNorms); PCad.RegisterFigureClass(TSCSFigureGrp); PCad.RegisterFigureClass(THouse); PCad.RegisterFigureClass(THouseTool); PCad.RegisterFigureClass(TApproachTool); GCadForm := Self; //Tolik if SCSEngine = nil then SCSEngine := TSCSEngine.Create(self); // события клавиатуры GisKeyDown := False; GisKeyPress := False; // события мыши GisMouseDown := False; GisMouseMove := False; // GisDivideLine := False; // GisAction := False; FRemFigures := TList.Create; PCad.OnBeforeDelete := PCadBeforeDelete; PCad.OnGUIEvent := PCadGUIEvent; PCad.OnKeyDown := PCadKeyDown; PCad.OnKeyUp := PCadKeyUp; PCad.Font.Charset := ANSI_CHARSET; PCad.OnMouseWheel := nil; // при обновлении КАДа PCad.OnRefresh := FCADOnRefresh; // при нажатии клавиши PCad.OnKeyStroke := FCADOnKeyStroke; // перед тем как передвинуть группу объектов PCad.OnBeforeMove := FOnBeforeMove; // перед тем как передвинуть группу объектов стрелками курсора PCad.OnMoveByArrows := FOnMoveByArrows; // создать слои // Слой - подложка (для инструментов PowerCad) - 1 CrLayer := TLayer.create(cCad_Mes1); PCad.Layers.Add(CrLayer); // Слой - СКС (для инструментов СКС) - 2 CrLayer := TLayer.create(cCad_Mes2); PCad.Layers.Add(CrLayer); // Слой - подписи к линейным обьектам СКС - 3 CrLayer := TLayer.Create(cCad_Mes3); PCad.Layers.Add(CrLayer); // Слой - подписи к точечным обьектам СКС - 4 CrLayer := TLayer.Create(cCad_Mes4); PCad.Layers.Add(CrLayer); // Слой - выноски к линейным объектам СКС - 5 CrLayer := TLayer.Create(cCad_Mes5); PCad.Layers.Add(CrLayer); // Слой - выноски к точечным объектам СКС - 6 CrLayer := TLayer.Create(cCad_Mes6); PCad.Layers.Add(CrLayer); // Слой - рамка листа - 7 CrLayer := TLayer.create(cCad_Mes7); PCad.Layers.Add(CrLayer); // Слой - Архитектурное проектирование - 8 CrLayer := TLayer.create(cCad_Mes8); PCad.Layers.Add(CrLayer); FActiveNet := Tnet.create(8, PCTypesUtils.mydsNormal, PCad); PCad.AddCustomFigure(8, FActiveNet, False); ActiveNet := FActiveNet; // Слой - Кабинеты - 9 CrLayer := TLayer.create(cCad_Mes29); PCad.Layers.Add(CrLayer); // Engine if F_Navigator <> nil then begin F_Navigator.PCadNavigator.Figures := PCad.Figures; ReAssignNavigatorParams; end; GListNode := Nil; // Текущий удаленный обьект из МП GDeletedFromPMFigure := Nil; // GPopupFigure := Nil; GFigureSnap := Nil; GPrevFigureSnap := nil; GFigureTraceTo := Nil; GPrevFigureTraceTo := Nil; GClickIndex := 0; // ПАРАМЕТРЫ ЛИСТА FRoomHeight := GRoomHeight; FFalseFloorHeight := GFalseFloorHeight; FConnHeight := GConnHeight; FLineHeight := GLineHeight; FLineTracingType := ltt_FromFloor; // переменные для хранения настроек FShowLinesLength := True; FShowLinesCaptions := False; FShowConnectorsCaptions := True; FAutoSelectTrace := True; FShowConnFullness := False; FShowCableFullness := False; FShowCableChannelFullness := False; FShowDefectObjects := False; FShowTracesLengthLimit := False; FPutCableOnTrace := False; // показ полное/краткое название объектов FShowObjectCaptionsType := st_Short; // группировать FGroupListObjectsByType := False; FNoMoveConnectedObjects := False; FAutoTraceBySelected := False; // тип отображения сетей FShowNetworkTypes := [nt_All]; LastSnapGridStatus := True; FClickType := ct_Single; // отображать с-п FShowRaise := True; // FJoinedBoxIDForDesignList := -1; FJoinedListIDForDesignList := -1; FDesignListShowName := False; FDesignListShowSign := False; FDesignListShowMark := False; GSavedZoomScale := PCad.ZoomScale; // LIST // Tolik -- 25/03/2016 -- { GTempJoinedOrtholinesList := TList.Create; GTempJoinedConnectorsList := TList.Create; GTempJoinedLinesConnectors := TList.Create; GSnapFiguresList := TList.Create; } {if GTempJoinedOrtholinesList = nil then GTempJoinedOrtholinesList := TList.Create; {if GTempJoinedConnectorsList = nil then GTempJoinedConnectorsList := TList.Create; if GTempJoinedLinesConnectors = nil then GTempJoinedLinesConnectors := TList.Create;} if GSnapFiguresList = nil then GSnapFiguresList := TList.Create else GSnapFiguresList.Clear; // try PCad.RulerVisible := True; except end; FCadStampLang := stl_ukr; //FCadStampMargins := DoubleRect(20,5,5,5); //10.11.2011 //FCADStampDeveloper := ''; //15.11.2011 - разработал //FCADStampChecker := ''; //15.11.2011 - проверил ZeroMemory(@FStampFields, SizeOf(FStampFields)); //02.10.2012 - поля рамки - разработал, проверил ... //Tolik 17/08/2021 -- //FFontName := 'GOST'; {$IF DEFINED(SCS_PE)} FFontName := 'Tahoma'; {$ELSE} FFontName := 'GOST'; {$IFEND} Font.Name := FFontName; // // лист хранения выбранных объектов FCurrPCadScrollX := 0; // текущая позиция скролла по Х FCurrPCadScrollY := 0; // текущая позиция скролла по Y GLastTracedLinePoints1 := DoublePoint(-10000, -10000); GLastTracedLinePoints2 := DoublePoint(-10000, -10000); SetLength(GTempDrawFigureAP, 4); FTracingList := nil; FTracingListIndex := 0; FIsDragOver := False; FShowCableChannelsOnly := False; FListSettings := GetDefaultListSettings(true); //28.05.2013 - чтобы не переписывать набор параметров на объект листа FSCSUndoList := TList.Create; FSCSRedoList := TList.Create; FCheckedFigures := TList.Create; FNeedUpdateCheckedFigures := True; //08.09.2011 SetString(FUndoDir, Buffer, GetTempPath(Sizeof(Buffer) - 1, Buffer)); //08.09.2011 FUndoDir := FUndoDir + 'Undo\'; //08.09.2011 if not DirectoryExists(FUndoDir) then //08.09.2011 CreateDir(FUndoDir); FUndoDir := GetPathToUndoDir; //08.09.2011 SetString(FRedoDir, Buffer, GetTempPath(Sizeof(Buffer) - 1, Buffer)); //08.09.2011 FRedoDir := FRedoDir + 'Redo\'; //08.09.2011 if not DirectoryExists(FRedoDir) then //08.09.2011 CreateDir(FRedoDir); FRedoDir := GetPathToRedoDir; FCanSaveForUndo := True; FUndoCount := 0;//10.09.2010 FUndoFiguresList := TList.Create; FUndoStatus := False; FWasDeleteQuery := False; FAllowSuppliesKind := True; FNeedDelete := False; if (GCurrProjUnitOfMeasure = umSM) or (GCurrProjUnitOfMeasure = umM) then PCad.RulerSystem := rsMetric else if (GCurrProjUnitOfMeasure = umIn) or (GCurrProjUnitOfMeasure = umFt) then PCad.RulerSystem := rsWhitworth; FCADListFileName := GetUniqueFileName('', enTmp); tbShowConnFullness.PopupMenu := FSCS_Main.pmConnectedPoints; tbShowCableFullness.PopupMenu := FSCS_Main.pmConnectedLines; //FSCS_Main.XPMenu.Active := false; //FSCS_Main.XPMenu.Active := True; FActiveHouse := nil; FDragX := 0; FDragY := 0; FPanLastRefeshTick := 0; FDragOverTick := 0; PCad.OnGetFigureToSelect := PCadGetFigureToSelect; PCad.OnGetModPointToSelect := PCadGetModPointToSelect; PCad.OnBeforeEndTrace := PCadBeforeEndTrace; PCad.OnCheckPrnWithOffset := PCadCheckPrnWithOffset; //29.11.2011 PCad.OnTraceDraw := PCadTraceDraw; PCad.OnFigureEdit := PCadFigureEdit; // OPTIMIZATION //PCad.FResetRegionsOnZoomScroll := false; //PCad.Container.OnResize := nil; //07.08.2012 except on E: Exception do addExceptionToLogEx('TF_CAD.FormCreate', E.Message); end; {$if Defined(ES_GRAPH_SC)} tbShowConnFullness.Visible := False; tbShowCableFullness.Visible := False; tbShowCableChannelFullness.Visible := False; tbShowDefectObjects.Visible := False; tbShowDisconnectedObjects.Visible := False; tbShowTracesLengthLimit.Visible := False; tbNoMoveConnectedObjects.Visible := False; {$ifend} MItem_ConnPoints.Action := F_ProjMan.Act_ConnectedConCompons; MItem_ConnLine.Action := F_ProjMan.Act_ConnectedLineCompons; MItem_NotConnPoint.Action := F_ProjMan.Act_NoConnectedConCompons; MItem_NotConnLine.Action := F_ProjMan.Act_NoConnectedLineCompons; MItem_CableNoCanal.Action := F_ProjMan.Act_CablesNoHitToCanals; {$IF Defined(SCS_PE) or Defined(SCS_PANDUIT)} Listofconnecteddisconnected1.Caption := 'List of connected/disconnected'; FSCS_Main.aShowDisconnectedObjects.Caption := 'Highlight disconnected'; (* for i := 0 to tbView.ControlCount - 1 do begin if tbView.Controls[i].ClassName = 'TToolButton' then begin //if Assigned(TToolButton(tbView.Controls[i]).Action) then // TAction(TToolButton(tbView.Controls[i]).Action).Caption := ''; TToolButton(tbView.Controls[i]).Caption := ''; end; if tbView.Controls[i] <> LabelHighlight then begin TToolButton(tbView.Controls[i]).AutoSize := True; end; end; tbView.Font.Name := 'MS Sans Serif'; tbView.AutoSize := True; tbView.ShowCaptions := True; tbShowConnFullness.AutoSize := True; tbShowCableFullness.AutoSize := True; tbShowCableChannelFullness.AutoSize := True; tbShowDisconnectedObjects.AutoSize := True; tbShowConnFullness.Caption := 'Jacks'; tbShowCableFullness.Caption := 'Cables'; tbShowCableChannelFullness.Caption := 'Conduits'; //tbShowDisconnectedObjects.Caption := 'Disconnected'; // Tolik 24/01/2020 -- а то все кнопочки не помещаются в зону виидмо области ToolButton4.AutoSize := False; ToolButton4.Width := 8; ToolButton1.AutoSize := False; ToolButton1.Width := 8; ToolButton2.AutoSize := False; ToolButton2.Width := 8; ToolButton5.AutoSize := False; ToolButton5.Width := 8; *) LabelHighlight.Visible := False;//Tolik 19/08/2021 -- // Tolik 04/108/2017 -- для укр сборки учесть {$ELSE} (* for i := 0 to tbView.ControlCount - 1 do begin if tbView.Controls[i].ClassName = 'TToolButton' then begin TToolButton(tbView.Controls[i]).Caption := ''; end; if tbView.Controls[i] <> LabelHighlight then begin TToolButton(tbView.Controls[i]).AutoSize := True; end; end; tbView.AutoSize := True; tbView.ShowCaptions := True; tbShowConnFullness.AutoSize := True; tbShowCableFullness.AutoSize := True; tbShowCableChannelFullness.AutoSize := True; tbShowDisconnectedObjects.AutoSize := True; ToolButton4.AutoSize := False; ToolButton4.Width := 8; ToolButton1.AutoSize := False; ToolButton1.Width := 8; ToolButton2.AutoSize := False; ToolButton2.Width := 8; ToolButton5.AutoSize := False; ToolButton5.Width := 8; *) {$IF Defined(SCS_UKR)} FSCS_Main.aShowDisconnectedObjects.Caption := 'Виділити відключені'; Listofconnecteddisconnected1.Caption := 'Список підключених/не підключених'; LabelHighlight.Visible := False; {$ELSE} // // FSCS_Main.aShowDisconnectedObjects.Caption := 'Выделить отключенные'; Listofconnecteddisconnected1.Caption := 'Список подключенных/не подключенных'; LabelHighlight.Visible := False; {$IFEND} {$IFEND} tbShowTransparency.Hint := cTransParencyButtonCapt; // Tolik 24/01/2020 -- как-то без хинтика не комильфо... if GReadOnlyMode then begin PCad.OnSurfaceDragOver := nil; PCad.OnSurfaceDragDrop := nil; end; // Tolik 05/05/2021 -- tbView_OldProc := tbView.WindowProc; tbView.WindowProc := tbView_NewProc; // end; procedure TF_CAD.FormClose(Sender: TObject; var Action: TCloseAction); var i, j: integer; GetTag: integer; FileName: String; begin try //Tolik 14/01/2022 if GWallTracePointList.Count > 0 then begin for i := 0 to GWallTracePointList.Count - 1 do TCircle(GWallTracePointList[i]).free; end; GWallTracePointList.free; // FCadClose := True; // Tolik 29/04/2021 -- CheckCloseReportForm; // Toilk 30/04/2021 -- GetTag := Self.Tag; // Tolik 26/03/2021 -- if FSCS_Main.FCADsInProgress.Count > 0 then FSCS_Main.FCADsInProgress.remove(Self); // //06.08.2012 GrayedColor := DefGrayedColor; if F_LayersDialog.Showing then F_LayersDialog.Unload; // удалить переключатель листов for i := 0 to FSCS_Main.pageCADList.PageCount - 1 do begin if FSCS_Main.pageCADList.Pages[i].Tag = GetTag then break; end; if i < FSCS_Main.pageCADList.PageCount then begin if Assigned(FSCS_Main.pageCADList.Pages[i]) then begin try FSCS_Main.pageCADList.Pages[i].Free; except end; end; end; // удалить листы из меню for i := 0 to FSCS_Main.mainWindow.Count - 1 do begin if FSCS_Main.mainWindow.Items[i].Tag = GetTag then break; end; if i < FSCS_Main.mainWindow.Count then begin if Assigned(FSCS_Main.mainWindow.Items[i]) then begin try FSCS_Main.mainWindow.Delete(i); //TMenuItem(FSCS_Main.mainWindow.Items[i]).free; except end; end; end; // удалить все if Self <> nil then begin try // Tolik -- 21//12/2015 -- на закрытии приложения фигуры с листов можно // не удалять, чтобы закрылся сразу, а то на больших проектах будет висеть, // пока все не поудаляет -- нах не нужно //ClearFiguresOnListDelete(Self); if Not GExitProgEX then ClearFiguresOnListDelete(Self); // except end; if Self = GListWithEndPoint then begin GListWithEndPoint := Nil; GEndPoint := Nil; end; end; Action := caFree; // UndoList if FSCSUndoList <> nil then begin ClearUndoList; end; if FUndoFiguresList <> nil then FreeAndNil(FUndoFiguresList); // RedoList if FSCSRedoList <> nil then begin ClearRedoList; end; if FSCS_Main.MDIChildCount = 1 then begin FSCS_Main.cbLayers.Enabled := False; if FSCS_Main.tbCADToolsExpert.Visible then FSCS_Main.cbScaleExpert.Enabled := False else FSCS_Main.cbScaleNoob.Enabled := False end; //Tolik if FActiveNet <> nil then begin FActiveNet := nil; end; if Assigned(FFrameObjects) then begin //FFrameObjects.Clear; FreeAndNil(FFrameObjects); end; //GTempJoinedOrtholinesList.Clear; { if Assigned(GTempJoinedOrtholinesList) then GTempJoinedOrtholinesList.Clear; //GTempJoinedConnectorsList.Clear; if Assigned(GTempJoinedConnectorsList) then GTempJoinedConnectorsList.Clear; //GTempJoinedLinesConnectors.Clear; if Assigned(GTempJoinedLinesConnectors) then GTempJoinedLinesConnectors.Clear; //GSnapFiguresList.Clear; if Assigned(GSnapFiguresList) then GSnapFiguresList.Clear; } if Assigned(FTracingList) then FreeAndNil(FTracingList); if Assigned(FCheckedFigures) then begin //FCheckedFigures.Clear; FreeAndNil(FCheckedFigures); end; // // автозакрытие листа в МП AfterCloseListInCAD(FCADListID); except on E: Exception do addExceptionToLogEx('TF_CAD.FormClose', E.Message); end; end; procedure TF_CAD.FormCloseQuery(Sender: TObject; var CanClose: Boolean); var i: integer; ListStream: TMemoryStream; SavedGCadForm: TF_CAD; AListParams: TListParams; fFileName: string; begin // ручное закрытие if not GNotNeedCheckRaisesBeforeClose then if CheckExistBetweenFloorOnList(TF_CAD(Sender)) then begin ShowMessage(cCad_Mes32); CanClose := False; Exit; end; if Not GExitProg then begin CanClose := False; GExitProg := True; exit; end; ListStream := TMemoryStream.Create; // Tolik 18/05/2018 - - как-то понадежнее будет.... try if (F_NormBase <> nil) and (F_ProjMan <> nil) then begin //ListStream := TMemoryStream.Create; SavedGCadForm := GCadForm; GCadForm := Self; try if not ListToDeleting(FCADListID) then begin if Not GCloseProg then begin fFileName := GetCadFileNameForSaveToPM(FCADListID); PCad.SaveToFile(0, fFileName); //PCad.SaveToStream(ListStream); //SetCadDataToPM(FCADListID, ListStream); end; end; except on E: Exception do addExceptionToLogEx(cCad_Mes9 + Self.FCADListName + cCad_Mes10, E.Message); end; AListParams := GetListParams(FCADListID); AListParams.Settings.CADShowRuler := PCad.RulerVisible; AListParams.Settings.CADShowGrid := PCad.Grids; AListParams.Settings.CADShowGuides := PCad.GuidesVisible; AListParams.Settings.CADSnapGrid := PCad.SnapToGrids; AListParams.Settings.CADSnapGuides := PCad.SnapToGuides; AListParams.Settings.CADSnapNearObject := PCad.SnapToNearPoint; SaveCADListParams(FCADListID, AListParams); {if ListStream <> nil then FreeAndNil(ListStream);} GCadForm := SavedGCadForm; end; except on E: Exception do addExceptionToLogEx('TF_CAD.FormCloseQuery', E.Message); end; ListStream.free; //Tolik 18/05/2018 -- end; //////////////////////////////////////////////////////////////////////////////// //// ПРОЦЕДУРЫ В ПРОЕКТ /////////////////////////////////////////////////////// //////////////////////////////////////////////////////////////////////////////// procedure TF_CAD.PCadSurfaceMove(Sender: TObject; Shift: TShiftState; X, Y: Double); var i: integer; Len: String; LenSize: Double; FullLenSize: Double; Degree: Double; FigureOnMove: TFigure; deltax, deltay: double; coordX, coordY: double; HintStrList: TStringList; FullName: string; //ModListTmp: TList; ModListTmp: TMyList; k: integer; ModExist: boolean; DropPoints: TDoublePoint; // Tolik 13/07/2017 -- PieAngle, PieRadius: Boolean; // показать угол сектора (если рисуем его в данный момент) Radius: String; SavedFigureFromMod: TFigure; // function CheckDragElectricCable: Boolean; // Tolik 19/03/2021 -- begin Result := False; if (((PCad.ToolIdx = toFigure) and (PCad.ToolInfo = 'TOrthoLine')) or FisDragOver) then //if GCallElectricAutoTraceMaster then //if GAutoAddCableAfterDragDrop then if GDropComponent <> nil then if GDropComponent.Id <> 0 then if F_NormBase.GSCSBase.SCSComponent <> nil then if F_NormBase.GSCSBase.SCSComponent.ID <> 0 then if isCableComponent(F_NormBase.GSCSBase.SCSComponent) then if F_NormBase.GSCSBase.SCSComponent.IDNetType = 3 then Result := True; end; //Tolik 26/08/2021 -- отсеять фигуры, для которых не нужно в режиме трейса выводить радиус и угол в статус Бар(внизу на каде), // а то валит для всех подряд непонятно чего (нафиг показывать радиус прямоугольника, например?) function CheckTraceFigure(aFigure: TFigure): Boolean; begin Result := False; if aFigure <> nil then Result := ((aFigure.CName = 'TArcDimLine') or (aFigure.CName = 'TLine') or (aFigure.CName = 'TPie') or (aFigure.CName = 'TArc') or (aFigure.CName = 'TEllipse') or (aFigure.CName = 'TCircle') or (aFigure.CName = 'TElpArc') or (aFigure.CName = 'TPolyline') or (aFigure.CName = 'TWallPath')); end; // begin try GCurrMousePos.x := X; GCurrMousePos.y := Y; //Tolik 31/01/2021 -- if (GLastSurfaceMoveX = 0) and (GLastSurfaceMovey = 0) then begin GLastSurfaceMoveX := x; GLastSurfaceMoveY := y; end; // // Tolik 13/07/2017 -- PieAngle := False; PieRadius := False; Radius := ''; // //30.06.2010 FCurrX := X; FCurrY := Y; //Рисуем рамку объектов Митяй Д.В 04.02.2014г. if GCadForm.FCreateObjectOnClick then begin if (PCad.SnapToGrids)or(PCad.SnapToGuides) then DropPoints := GetCoordsWithSnapToGrid(X, Y) else DropPoints := DoublePoint(X,Y); // if (abs(XOld - X)> 0)or(abs(YOld - Y)> 0) then begin if Not Assigned(GShadowObject) then CreateShadowObject; GIsDrawShadow := True; //Tolik 05/01/2022 -- if (GCadForm.cbMagnetToWalls.Down and (not (ssShift in GGlobalShiftState))) then begin CalcShadowPoint(FCurrX, FCurrY); if GShadowMagnetPoint.x <> -100 then begin //GShadowObject.Move(GShadowMagnetPoint.x - GShadowObject.ShadowCP.x, GShadowMagnetPoint.y - GShadowObject.ShadowCP.y); GShadowObject.ShadowCP.x := GShadowMagnetPoint.x; GShadowObject.ShadowCP.y := GShadowMagnetPoint.y; end else begin //GShadowObject.Move(DropPoints.x - GShadowObject.ShadowCP.x, DropPoints.y - GShadowObject.ShadowCP.y); GShadowObject.ShadowCP.x := DropPoints.x; GShadowObject.ShadowCP.y := DropPoints.y; end; end else begin GShadowObject.ShadowCP.x := DropPoints.x; GShadowObject.ShadowCP.y := DropPoints.y; end; GShadowObject.draw(PCad.DEngine, False); RefreshCAD(PCad); end; XOld := X; YOld := Y; end; //mProtocol.Lines.Insert(0, 'x='+FloatToStr(X)+', y='+FloatToStr(Y)+''); FigureOnMove := nil; //#From Oleg# //14.09.2010 deltax := (X - GLastSurfaceMoveX); deltay := (Y - GLastSurfaceMoveY); FDeltaX := deltax; FDeltaY := deltay; // SELECT if (PCad.ToolIdx = toSelect) and not (FCreateObjectOnClick) then begin try if PCad.ActiveLayer <> 8 then begin if PCad.ActiveLayer = 2 then FigureOnMove := CheckBySCSObjects(X, Y) else FigureOnMove := PCad.CheckByPoint(PCad.ActiveLayer, X, Y); end else begin FigureOnMove := TFigure(GetNetObjInPoint(PCad, PCad.ActiveLayer, X, Y, true)); if FigureOnMove = nil then FigureOnMove := GCadForm.FActiveNet; end; except FigureOnMove := nil; end; if (FigureOnMove <> nil) and (FigureOnMove is TFigure) then begin if PCad.ActiveLayer = 2 then begin if CheckFigureByClassName(FigureOnMove, cTSCSFigureGrp) then PCad.SetCursor(crHandPoint) else if CheckFigureByClassName(FigureOnMove, cTConnectorObject) then PCad.SetCursor(crNewMoveCross) else if CheckFigureByClassName(FigureOnMove, cTOrthoLine) then begin ModExist := False; //if TOrthoLine(FigureOnMove).Select then if Not PCAD.IsDragging then begin //ModListTmp := TList.Create; ModListTmp := TMyList.Create; TOrthoLine(FigureOnMove).GetModPoints(ModListTmp); for k := 0 to ModListTmp.Count - 1 do begin if TModPoint(ModListTmp.Items[k]).IsPointIn(x, y, 0.3) then begin ModExist := True; PCad.SetCursor(crHandPoint); break; end; end; for k := 0 to ModListTmp.Count - 1 do begin PCad.UnRegisterModPoint(ModListTmp.Items[k]); end; ModListTmp.Free; end; if Not ModExist then PCad.SetCursor(crSizeAll); end else if CheckFigureByClassName(FigureOnMove, cTHouse) then PCad.SetCursor(crNewMoveCross) else PCad.SetCursor(crDefault); PCad.ShowHint := True; // считать StringList HintStrList := GetFigureComponNames(TFigure(FigureOnMove).ID); if HintStrList <> nil then begin if HintStrList.Count = 0 then PCad.Hint := GetFullFigureName(FigureOnMove, X,Y) else begin PCad.Hint := ''; for i := 0 to HintStrList.Count - 1 do begin PCad.Hint := PCad.Hint + HintStrList[i]; if i <> HintStrList.Count - 1 then PCad.Hint := PCad.Hint + #13#10; end; end; // Добавить стринг с номером магистрали if GCadForm.FShowLineCaptionsType = skExternalSCS then begin if CheckFigureByClassName(FigureOnMove, cTOrthoLine) then begin TOrthoLine(FigureOnMove).FTrunkNumber := GetTrunkNumber(TOrthoLine(FigureOnMove)); if TOrthoLine(FigureOnMove).FTrunkNumber <> '' then begin PCad.Hint := PCad.Hint + #13#10 + cCad_Mes31 + TOrthoLine(FigureOnMove).FTrunkNumber; end; end; end; // Tolik 09/03/2017 -- FreeAndNil(HintStrList); // end; end // else begin PCad.SetCursor(crHandPoint); PCad.ShowHint := False; // считать StringList HintStrList := GetFigureComponNames(FigureOnMove.ID); if HintStrList <> nil then begin if HintStrList.Count = 0 then PCad.Hint := FullName else begin PCad.Hint := ''; for i := 0 to HintStrList.Count - 1 do begin PCad.Hint := PCad.Hint + HintStrList[i]; if i <> HintStrList.Count - 1 then PCad.Hint := PCad.Hint + #13#10; end; end; // Tolik 09/03/2017 -- FreeAndNil(HintStrList); // end; if CheckFigureByClassName(FigureOnMove, cTPlanConnector) or CheckFigureByClassName(FigureOnMove, cTPlanObject) then PCad.SetCursor(crNewMoveCross) else if CheckFigureByClassName(FigureOnMove, cTPlanTrace) then PCad.SetCursor(crSizeAll); end; end else begin PCad.SetCursor(crDefault); PCad.ShowHint := False; end; end else if (PCad.ToolIdx = toSelect) and (FCreateObjectOnClick) then begin PCad.SetCursor(crDrag); end; {****************************************************************************} // Режим привязки в режиме трейса трассы или режим создания объекта при нажатии if ((PCad.ToolIdx = toFigure) and (PCad.ToolInfo = 'TOrthoLine')) AND Not(ssAlt in GGlobalShiftState) OR (FCreateObjectOnClick) or CheckDragElectricCable then begin if (GCurrShadowTraceX = -1) and (GCurrShadowTraceY = -1) then begin //Tolik 01/09/2021 -- if GisOrthoLineHadow then GFigureTraceTo := Nil else // begin try GFigureTraceTo := CheckBySCSObjects(X, Y); except GFigureTraceTo := Nil; end; end; end else begin //Tolik 01/09/2021 -- if GisOrthoLineHadow then GFigureTraceTo := Nil else // begin try if GOrthoStatus then begin GFigureTraceTo := CheckBySCSObjects(X, Y); if (GFigureTraceTo <> nil) and CheckFigureByClassName(GFigureTraceTo, cTOrthoLine) then GFigureTraceTo := CheckBySCSObjects(GCurrShadowTraceX, GCurrShadowTraceY); end else GFigureTraceTo := CheckBySCSObjects(GCurrShadowTraceX, GCurrShadowTraceY); except GFigureTraceTo := Nil; end; end; end; // Найденные объекты if GFigureTraceTo <> nil then begin // Коннектор if CheckFigureByClassName(GFigureTraceTo, cTConnectorObject) then begin if TConnectorObject(GFigureTraceTo).ConnectorType = ct_Clear then if (TConnectorObject(GFigureTraceTo).JoinedConnectorsList.Count > 0) then GFigureTraceTo := nil; if GFigureTraceTo <> nil then begin if CheckTrunkObject(TConnectorObject(GFigureTraceTo)) then GFigureTraceTo := nil; end; if GFigureTraceTo <> nil then begin if GFigureTraceTo <> nil then if not GCadForm.FShowRaise then if TConnectorObject(GFigureTraceTo).FConnRaiseType <> crt_None then GFigureTraceTo := nil; end; end // Линия else if CheckFigureByClassName(GFigureTraceTo, cTOrthoLine) then begin if (TOrthoLine(GFigureTraceTo).FIsRaiseUpDown) then GFigureTraceTo := nil; if FCreateObjectOnClick then if not FPutCableOnTrace then GFigureTraceTo := nil; if GFigureTraceTo <> nil then begin if not FCreateObjectOnClick then if TOrthoLine(GFigureTraceTo).FConnectingLine then GFigureTraceTo := nil; end; end // House else if CheckFigureByClassName(GFigureTraceTo, cTHouse) then begin end; end; ////////////// if (GPrevFigureTraceTo <> nil) and (GPrevFigureTraceTo <> GFigureTraceTo) then begin if CheckFigureByClassName(GPrevFigureTraceTo, cTConnectorObject) then begin TConnectorObject(GPrevFigureTraceTo).isSnap := false; TConnectorObject(GPrevFigureTraceTo).Draw(PCad.DEngine, false); end else if CheckFigureByClassName(GPrevFigureTraceTo, cTOrthoLine) then begin TOrthoLine(GPrevFigureTraceTo).isSnap := false; TOrthoLine(GPrevFigureTraceTo).Draw(PCad.DEngine, false); end else if CheckFigureByClassName(GPrevFigureTraceTo, cTHouse) then begin THouse(GPrevFigureTraceTo).isSnap := false; THouse(GPrevFigureTraceTo).Draw(PCad.DEngine, false); end; //D0000006113 //=============01.11.2013 самыков=================== { IGOR Уже не нужно - рефреш делается при снятии флажка isSnap if GFigureTraceTo=nil then GPrevFigureTraceTo:=nil; PCad.Refresh; } //=============01.11.2013 самыков=================== end; if GFigureTraceTo <> nil then begin if CheckFigureByClassName(GFigureTraceTo, cTConnectorObject) then begin //выделение объекта рамкой TConnectorObject(GFigureTraceTo).isSnap := true; //Эта рисовалка не нужна, потому как при записи свойства isSnap //Выполняется рисование //TConnectorObject(GFigureTraceTo).Draw(PCad.DEngine, false); end else if CheckFigureByClassName(GFigureTraceTo, cTOrthoLine) then begin TOrthoLine(GFigureTraceTo).isSnap := true; //См. предыдущее объяснение //TOrthoLine(GFigureTraceTo).Draw(PCad.DEngine, false); end else if CheckFigureByClassName(GFigureTraceTo, cTHouse) then begin THouse(GFigureTraceTo).isSnap := true; // THouse(GFigureTraceTo).Draw(PCad.DEngine, false); end; GPrevFigureTraceTo := GFigureTraceTo; end; end; {*****************************************} //Кусок выполняется при зажатой клавише ALT // Режим трейса и нет режима привязки, убрать выделение с предыдущих выделенных if ((PCad.ToolIdx = toFigure) and (PCad.ToolInfo = 'TOrthoLine')) AND (ssAlt in GGlobalShiftState) then begin // GReDrawAfterRefresh := True; GFigureTraceTo := nil; if GPrevFigureTraceTo <> nil then begin if CheckFigureByClassName(GPrevFigureTraceTo, cTConnectorObject) then begin TConnectorObject(GPrevFigureTraceTo).isSnap := false; TConnectorObject(GPrevFigureTraceTo).Draw(PCad.DEngine, false); end else if CheckFigureByClassName(GPrevFigureTraceTo, cTOrthoLine) then begin TOrthoLine(GPrevFigureTraceTo).isSnap := false; TOrthoLine(GPrevFigureTraceTo).Draw(PCad.DEngine, false); end else if CheckFigureByClassName(GPrevFigureTraceTo, cTHouse) then begin THouse(GPrevFigureTraceTo).isSnap := false; THouse(GPrevFigureTraceTo).Draw(PCad.DEngine, false); end; GPrevFigureTraceTo := nil; end; end; {****************************************************************************} //// Если режим трейса то выводить угол и размеры текущей фигуры if GTracedFigure then begin if PCad.ActiveLayer <> 2 then begin if CheckTraceFigure(PCad.TraceFigure) then // Tolik 26/08/2021 -- begin // --- размеры LenSize := SQRT(SQR(X - GBeginPoint.x) + SQR(Y - GBeginPoint.y)); FullLenSize := 0; // Tolik -- 13/07/2017 -- //if PCad.TraceFigure <> nil then if PCad.TraceFigure.ClassName = 'TPie' then begin PieAngle := True; PieRadius := True; end; if PieAngle then Degree := GetPieAngle(TPie(PCad.TraceFigure).Fangle, TPie(PCad.TraceFigure).SAngle) else // Degree := GetFigureAngle(GBeginPoint.x, GBeginPoint.y, X, Y); // if PCad.RulerMode = rmPage then // begin // LenSize := LenSize / 10; // Len := FormatFloat(ffMask, LenSize); // sbView.Panels[1].Text := cCadClasses_Mes4 + Len + cCadClasses_Mes6; // end; if PCad.RulerMode = rmWorld then begin LenSize := LenSize / 1000 * Pcad.MapScale; Len := FormatFloat(ffMask, MetreToUOM(LenSize)); sbView.Panels[1].Text := cCadClasses_Mes4 + Len + GetUOMString(GCurrProjUnitOfMeasure); end; // Tolik 13/07/2017 -- if PieRadius then Radius := '; '+cCadClasses_Mes33+': ' + FormatFloat(ffMask, MetreToUOM(TPie(PCad.TraceFigure).Radius) * GCadForm.PCad.MapScale / 1000) + ' '+GetUOMString(GCurrProjUnitOfMeasure) else Radius := '; '+cCadClasses_Mes33+': ' + FormatFloat(ffMask, MetreToUOM(GetLineLength(GBeginPoint, Doublepoint(X, Y)) * GCadForm.PCad.MapScale / 1000)) + ' '+GetUOMString(GCurrProjUnitOfMeasure); // sbView.Panels[2].Text := '> ' + FormatFloat(ffMask, Degree) + cCadClasses_Mes8 + // Радиус //Tolik -- 13/07/2017 -- // '; '+cCadClasses_Mes33+': ' + FormatFloat(ffMask, MetreToUOM(GetLineLength(GBeginPoint, Doublepoint(X, Y)) * GCadForm.PCad.MapScale / 1000)) + ' '+GetUOMString(GCurrProjUnitOfMeasure); Radius; end; // end; end // Tolik -- 13/07/2017 -- else if PCad.TraceFigure <> nil then begin if (PCad.TraceFigure.Info = '') and (CheckFigureByClassName(PCad.TraceFigure, cTOrthoLine) or CheckFigureByClassName(PCad.TraceFigure, cTConnectorObject)) then begin Pcad.Refresh; PCad.TraceFigure.Info := '1'; end; if CheckTraceFigure(PCad.TraceFigure) then // Tolik 26/08/2021 -- begin if PCad.TraceFigure.ClassName = 'TPie' then begin PieAngle := True; PieRadius := True; end; if PieAngle then Degree := GetPieAngle(TPie(PCad.TraceFigure).Fangle, TPie(PCad.TraceFigure).SAngle) else Degree := GetFigureAngle(GBeginPoint.x, GBeginPoint.y, X, Y); // Tolik 13/07/2017 -- if PieRadius then Radius := '; '+cCadClasses_Mes33+': ' + FormatFloat(ffMask, MetreToUOM(TPie(PCad.TraceFigure).Radius) * GCadForm.PCad.MapScale / 1000) + ' '+GetUOMString(GCurrProjUnitOfMeasure) else Radius := '; '+cCadClasses_Mes33+': ' + FormatFloat(ffMask, MetreToUOM(GetLineLength(GBeginPoint, Doublepoint(X, Y)) * GCadForm.PCad.MapScale / 1000)) + ' '+GetUOMString(GCurrProjUnitOfMeasure); // sbView.Panels[2].Text := '> ' + FormatFloat(ffMask, Degree) + cCadClasses_Mes8 + // Радиус //Tolik -- 13/07/2017 -- // '; '+cCadClasses_Mes33+': ' + FormatFloat(ffMask, MetreToUOM(GetLineLength(GBeginPoint, Doublepoint(X, Y)) * GCadForm.PCad.MapScale / 1000)) + ' '+GetUOMString(GCurrProjUnitOfMeasure); Radius; // end; end; //// Выводить координаты курсора на панель // if PCad.RulerMode = rmPage then // begin // sbView.Panels[0].Text := 'X=' + FormatFloat(ffMask, X) + ' ' + 'Y=' + FormatFloat(ffMask, Y); // end; if PCad.RulerMode = rmWorld then begin coordX := X * PCad.MapScale / 1000; coordY := Y * PCad.MapScale / 1000; if GDraggedFigureZOrder = -1 then begin sbView.Panels[0].Text := 'X=' + FormatFloat(ffMask, MetreToUOM(coordX)) + ' ' + 'Y=' + FormatFloat(ffMask, MetreToUOM(coordY)); end else begin sbView.Panels[0].Text := 'X=' + FormatFloat(ffMask, MetreToUOM(coordX)) + ' ' + 'Y=' + FormatFloat(ffMask, MetreToUOM(coordY)) + ' ' + 'Z=' + FormatFloat(ffMask, MetreToUOM(GDraggedFigureZOrder)); end; if FigureOnMove <> nil then begin if CheckFigureByClassName(FigureOnMove, cTConnectorObject) then begin sbView.Panels[0].Text := 'X=' + FormatFloat(ffMask, MetreToUOM(coordX)) + ' ' + 'Y=' + FormatFloat(ffMask, MetreToUOM(coordY)) + ' ' + 'Z=' + FormatFloat(ffMask, MetreToUOM(TConnectorObject(FigureOnMove).ActualZOrder[1])); end else if CheckFigureByClassName(FigureOnMove, cTOrthoLine) then if TOrthoLine(FigureOnMove).ActualZOrder[1] = TOrthoLine(FigureOnMove).ActualZOrder[2] then sbView.Panels[0].Text := 'X=' + FormatFloat(ffMask, MetreToUOM(coordX)) + ' ' + 'Y=' + FormatFloat(ffMask, MetreToUOM(coordY)) + ' ' + 'Z=' + FormatFloat(ffMask, MetreToUOM(TOrthoLine(FigureOnMove).ActualZOrder[1])); if PCad.SelectedCount = 0 then begin sbView.Panels[2].Text := GetFullFigureName(FigureOnMove, X,Y); if FigureOnMove is TNet then sbView.Panels[1].Text := GetFullFigureLenName(FigureOnMove, X,Y); end; end; end; // ПЕРЕТАСКИВАНИЕ КАДа if (FSCS_Main.tbPanExpert.Down) or (FSCS_Main.tbPanNoob.Down) then begin PCad.SetCursor(crHandPoint); if GIsMousePressed then begin //deltax := (X - GLastSurfaceMoveX); //deltay := (Y - GLastSurfaceMoveY); //MoveCADOnPan(deltax, deltay); //Tolik 26/08/2021 -- тут, чтобы таймер повторно не вызвался //TimerMovePan.Enabled := true; if TimerMovePan.Tag = 0 then TimerMovePan.Enabled := true; exit; // end; end; if (DragState = dsPan) then begin //if GIsMousePressed then begin // TimerMovePan.Enabled := true; end; end; //20.06.2013 if ((PCad.ToolIdx = toFigure) and (PCad.ToolInfo = 'TOrthoLine')) and (GClickIndex > 0) then //20.06.2013 CheckScrollingOnTracing(X, Y); if (PCad.ToolIdx = toFigure) and ((PCad.ToolInfo = TOrthoLine.ClassName) and (GClickIndex > 0)) or (PCad.ToolInfo = TBetweenFloorDownVertex.ClassName) or (PCad.ToolInfo = TBetweenFloorUpVertex.ClassName) then CheckScrollingOnTracing(X, Y); GLastSurfaceMoveX := X; GLastSurfaceMoveY := Y; { //Tolik 12/01/2021 if GArchLineH <> nil then begin GArchLineH.Move(0, y - GArchLineH.aP1.y); GArchLineV.Move(x - GArchLineV.Ap1.x, 0); if PCad.TraceFigure = nil then begin DrawShadowCrossPoints; if GCadForm.cbMagnetWalls.Down then DefineShadowCrossPoints(GCurrMousePos.x, GCurrMousePos.y); end; end; } except on E: Exception do addExceptionToLogEx('TF_CAD.PCadSurfaceMove', E.Message); end; end; // Tolik 01/12/2016 -- // procedure TF_CAD.PCadBeforeDelete(Sender: TObject; Figure: TFigure; // var CanDelete: Boolean); // procedure TF_CAD.PCadBeforeDelete(Sender: TObject; Figure: TFigure; var CanDelete: Boolean); var i, j: integer; mess: string; ObjFromRaise: TConnectorObject; vList: TList; vIntList: TIntList; old, new: Cardinal; ListID: Integer; FigID: Integer; InFigure: TFigure; SelectedList: TList; k: integer; aNeedRaiserDel: boolean; RaisersSelected: boolean; //Tolik SCSCatalog : TSCSCatalog; l: integer; FigClassName: string; DelComponMode: TDelComponMode; DelCableFromPoint: boolean; CableList: TList; begin FigClassName := ''; FigClassName := Figure.ClassName; // Tolik -- 07/02/2017 -- vList := nil; SelectedList := Nil; // try if CheckFigureByClassName(Figure, cTRichTextMod) or CheckFigureByClassName(Figure, cTFigureGrpMod) or CheckFigureByClassName(Figure, cTFigureGrpNotMod) or CheckFigureByClassName(Figure, cTCabinetNumber) then begin if Not (Figure.LayerHandle = LongInt(PCad.Layers[1])) then begin CanDelete := False; Exit; end; end; if GShadowObject = figure then begin CanDelete := False; Exit; end; if not ((Figure is TFigureGrp) and (GAutoDelete)) then begin if not FWasDeleteQuery then begin mess := cCad_Mes11; FDeleteOnlyUnuseRaisers := False; //if MessageBoxA(FSCS_Main.Handle, PAnsiChar(mess), cCad_Mes12, MB_YESNO) = IDYes then if MessageBox(FSCS_Main.Handle, PChar(mess), PChar(cCad_Mes12), MB_YESNO) = IDYes then begin GCanDeleteFigures := True; // Tolik 26/05/2021 -- удалить кабели if not FWasDeleteQuery then begin //if not CheckAllCadFiguresSelected then begin if CheckNeedInputBox then begin DelComponMode := F_ProjMan.F_InputBox.ChoiceDelComponMode(''{F_ProjMan.GSCSBase.SCSComponent.Name}); DelCableFromPoint := (F_ProjMan.F_InputBox.cbDelConnToPoinCable.Checked and F_ProjMan.F_InputBox.cbDelConnToPoinCable.Visible); end; end; end; // FWasDeleteQuery := True; mess := cCad_Mes11_1; RaisersSelected := False; for k := 0 to PCad.Selection.Count - 1 do begin if Assigned(TFigure(PCad.Selection[k])) then begin //Tolik {SCSCatalog := F_ProjMan.GSCSBase.CurrProject.CurrList.GetCatalogFromReferencesBySCSID(TFigure(PCad.Selection[k]).ID); if SCSCatalog <> nil then begin for l := 0 to SCSCatalog.ComponentReferences.Count -1 do begin SCSCatalog.ComponentReferences[l].ServToDelete := true; SCSCatalog.ComponentReferences[l].ApplyChanges; end; end; //} if CheckFigureByClassName(TFigure(PCad.Selection[k]), cTOrthoLine) then begin if TOrthoLine(TFigure(PCad.Selection[k])).FIsRaiseUpDown then begin RaisersSelected := True; break; end; end; end; end; if RaisersSelected then begin //if MessageBoxA(FSCS_Main.Handle, PAnsiChar(mess), cCad_Mes12, MB_YESNO) = IDYes then if MessageBox(FSCS_Main.Handle, PChar(mess), PChar(cCad_Mes12), MB_YESNO) = IDYes then FDeleteOnlyUnuseRaisers := True; end else FDeleteOnlyUnuseRaisers := True; end else begin GCanDeleteFigures := False; FWasDeleteQuery := True; end; end; end else GCanDeleteFigures := True; if GCanDeleteFigures then begin FFiguresDelManual.Add(Figure); //02.08.2013 if (PCad.ActiveLayer = lnArch) or CheckOneOfSCSlayers(PCad.ActiveLayer) then begin // *UNDO* if FCanSaveForUndo then begin if FListType = lt_Normal then begin vList := GetRelatedListsBySelected(PCad.Selection, cst_Delete); // !!! // vIntList := TIntList.Create; // for i := 0 to vList.Count - 1 do // begin // ListID := TF_CAD(vList[i]).FCADListID; // vIntList.Add(ListID); // end; // FigID := Figure.ID; // BeforeDelObjectFromPM(cfCAD, FCADListID, FigID, vIntList); // !!! { if vList.Count = 1 then SaveForUndo(uat_None, True, False) else begin // Tolik -- 09/03/2017 -- FreeAndNil(vList); // vIntList := GetListsIDRelatedToFigures(FCADListID, FiguresToIntFigures(PCad.Selection)); vList := IntCadsToCads(vIntList); SaveForProjectUndo(vList, True, False); // Tolik -- 09/03/2017 -- FreeAndNil(vIntList); // end; } if (vList.Count = 1) and (F_ProjMan.GSCSBase.CurrProject.ProjectLists.Count = 1) then SaveForUndo(uat_None, True, False) else begin VList.free; vIntList := GetListsIDRelatedToFigures(FCADListID, FiguresToIntFigures(PCad.Selection)); vList := IntCadsToCads(vIntList); CableList := GetListsByDeleteCable(DelCableFromPoint, DelComponMode); vList.Assign(CableList, laOr); SaveForProjectUndo(vList, True, False); // Tolik -- 09/03/2017 -- FreeAndNil(vIntList); FreeAndNil(CableList); // end; // Tolik 24/05/2021 -- удалить кабель, подключенный к удаляемым точечным объектам if DelCableFromPoint then DeleteConnectedToPointsCable; if DelComponMode = dmTrace then DelCableByAllLengthFromSelected; // Tolik 25/05/2021 -- удалить кабели по всей длине с удаляемых трасс end else if FListType = lt_ProjectPlan then begin SaveForUndo(uat_None, True, False); end; FCanSaveForUndo := False; end; if PCad.ActiveLayer = lnArch then begin if Figure is TFigureGrp then //26.09.2011 for i := 0 to TFigureGrp(Figure).InFigures.Count - 1 do begin InFigure := TFigure(TFigureGrp(Figure).InFigures[i]); if InFigure is TNet then TNet(InFigure).DoDelete; end; end; end; // Tolik -- 01/12/2016 -- вот это не делаем, иначе не сможем сохранить для УНДО групповую неSCS - фигуру // (RemoveInFigureGrp убьет все infigures) { if (Figure is TFigureGrp) and not CheckFigureByClassName(Figure, cTSCSFigureGrp) then begin RemoveInFigureGrp(TFigureGrp(Figure)); end;} if CheckFigureByClassName(Figure, cTConnectorObject) or CheckFigureByClassName(Figure, cTOrthoLine) or CheckFigureByClassName(Figure, cTCabinet) or CheckFigureByClassName(Figure, cTCabinetExt) or CheckFigureByClassName(Figure, cTPlanObject) or CheckFigureByClassName(Figure, cTPlanConnector) or CheckFigureByClassName(Figure, cTPlanTrace) or CheckFigureByClassName(Figure, cTSCSFigureGrp) or CheckFigureByClassName(Figure, cTHouse) then begin CanDelete := False; PCad.OnBeforeDelete := nil; try if Assigned(Figure) then begin if CheckFigureByClassName(Figure, cTConnectorObject) then begin if CheckCannotDelete(Figure) then begin CanDelete := False; Exit; end; TConnectorObject(Figure).Delete; end; end; if Assigned(Figure) then begin if CheckFigureByClassName(Figure, cTOrthoLine) then begin if CheckCannotDelete(Figure) then begin CanDelete := False; Exit; end; if TOrthoLine(Figure).FIsRaiseUpDown then begin ObjFromRaise := TOrthoLine(Figure).FObjectFromRaisedLine; if ObjFromRaise <> nil then begin SelectedList := TList.Create; for k := 0 to PCad.Selection.Count - 1 do begin if PCad.Selection[k] <> Figure then SelectedList.Add(PCad.Selection[k]); end; aNeedRaiserDel := True; if FDeleteOnlyUnuseRaisers then begin if isRaiseEmptyAndNotNeed(TOrthoLine(Figure)) then begin aNeedRaiserDel := True; end else begin aNeedRaiserDel := False; end end; if aNeedRaiserDel then begin if ObjFromRaise.ConnectorType = ct_Clear then DestroyRaiseOnConnector(ObjFromRaise) else DestroyRaiseOnPointObject(ObjFromRaise); for k := 0 to SelectedList.Count - 1 do begin if Assigned(SelectedList[k]) then if Not TFigure(SelectedList[k]).Deleted then TFigure(SelectedList[k]).Select; end; if SelectedList.Count > 0 then begin PCad.ResetRemoveSelection := True; end; PCad.RefreshSelection; end else begin Figure.Selected := False; PCad.RefreshSelection; end; if SelectedList.Count > 0 then begin FWasDeleteQuery := True; FCanSaveForUndo := False; end; SelectedList.Clear; FreeAndNil(SelectedList); Exit; end else TOrthoLine(Figure).Delete; end else TOrthoLine(Figure).Delete; end; end; if Assigned(Figure) then begin if CheckFigureByClassName(Figure, cTCabinet) then begin TCabinet(Figure).Delete; end; end; if Assigned(Figure) then begin if CheckFigureByClassName(Figure, cTCabinetExt) then begin TCabinetExt(Figure).Delete; end; end; if Assigned(Figure) then begin if CheckFigureByClassName(Figure, cTPlanObject) then begin Figure.Deleted := True; CanDelete := True; //TPlanObject(Figure).Delete; end; end; if Assigned(Figure) then begin if CheckFigureByClassName(Figure, cTPlanConnector) then begin Figure.Deleted := True; CanDelete := True; //TPlanConnector(Figure).Delete; end; end; if Assigned(Figure) then begin if CheckFigureByClassName(Figure, cTPlanTrace) then begin Figure.Deleted := True; CanDelete := True; //TPlanTrace(Figure).Delete; end; end; if Assigned(Figure) then begin if CheckFigureByClassName(Figure, cTSCSFigureGrp) then begin TSCSFigureGrp(Figure).Delete; end; end; if Assigned(Figure) then begin if CheckFigureByClassName(Figure, cTHouse) then begin THouse(Figure).Delete; end; end; finally PCad.OnBeforeDelete := PCadBeforeDelete; // Tolik 16/11/2020 -- if SelectedList <> Nil then SelectedList.free; if vList <> nil then FreeAndNil(vList); // end; end; if not GProjectChanged then // Tolik 28/08/2019 -- SetProjectChanged(True); end else begin CanDelete := False; end; except on E: Exception do addExceptionToLogEx('TF_CAD.PCadBeforeDelete', E.Message); end; // Tolik -- 07/02/2017 -- if vList <> nil then FreeAndNil(vList); // end; procedure TF_CAD.PCadKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); begin GisKeyDown := True; GGlobalShiftState := Shift; // if (GOrthoStatus) then // if (PCad.ToolInfo = 'TOrthoLine') and (PCad.TraceFigure <> nil) and CheckFigureByClassName(PCad.TraceFigure, cTOrthoLine) then // if (GFigureTraceTo <> nil) and CheckFigureByClassName(GFigureTraceTo, cTConnectorObject) then // if Key = VK_CONTROL then // begin // // end; end; procedure TF_CAD.PCadKeyUp(Sender: TObject; var Key: Word; Shift: TShiftState); var ShadowTrace: TFigure; canClick, droptool: Boolean; //Tolik -- 06/08/2021 -- begin droptool := True; //Tolik try try GGlobalShiftState := Shift; // сбросить привязку при нажатии Альт if ((PCad.ToolIdx = toFigure) and (PCad.ToolInfo = 'TOrthoLine')) and (ssAlt in GGlobalShiftState) then begin if GPrevFigureTraceTo <> nil then begin TConnectorObject(GPrevFigureTraceTo).DrawSnapFigures(GPrevFigureTraceTo, False); GPrevFigureTraceTo := nil; RefreshCAD(PCad); end; end; // в режиме Выборки нажатие Альт - сброс предыдущих выделенных объектов if (ssAlt in GGlobalShiftState) then begin if GPrevFigureSnap <> nil then begin TConnectorObject(GPrevFigureSnap).DrawSnapFigures(GPrevFigureSnap, False); GPrevFigureSnap := nil; RefreshCAD(PCad); end; end; if Key = VK_Escape then begin GNoTraceCable := False; FIsDragOver := False; //D0000006113 UnSnapFigure; //30.10.2013 самыков // если мувается объект if Pcad.IsDragging then begin PCad.CancelActions; if GLastConnector <> nil then begin GLastConnector.SkipConnectedLinesDrawShadow; end; RefreshCAD(PCad); end else // идет создание трассы // Tolik 18/11/2015 -- если GClickIndex = 1, это значит, что второй конец трассы пользователем не обозначен // (передумал и нажал ESCape ) -- в таком случае нечего создавать // if (PCad.ToolInfo = 'TOrthoLine') and (PCad.TraceFigure <> nil) then begin //Tolik 06/09/2021 -- (* if (PCad.ToolInfo = 'TOrthoLine') and (PCad.TraceFigure <> nil) and (GClickIndex > 1) then // begin begin // мышь автокад if GCadForm.FAutoCadMouse then begin GClickIndex := GClickIndex + 1; PCad.TraceFigure.ShadowClick(GClickIndex, GCurrMousePos.x, GCurrMousePos.y); ShadowTrace := TOrthoLine.CreateFromShadow(PCad, PCad.GetLayerHandle(2), PCad.TraceFigure); if ShadowTrace = nil then begin RefreshCAD(PCad); PCad.SetTool(toSelect, 'TSelected'); //GAutoAddCableAfterDragDrop := false; if FSCS_Main.tbCADToolsExpert.Visible then FSCS_Main.tbSelectExpert.Down := True else FSCS_Main.tbSelectNoob.Down := True; FCreateObjectOnClick := False; RestoreCadGridStatus; // Tolik 04/03/2021 -- GCurrShadowTraceX := -1; GCurrShadowTraceY := -1; if GSnapFiguresList <> nil then begin GSnapFiguresList.Clear; end; end; end else // мышь скс begin if GClickIndex >= 1 then begin GClickIndex := GClickIndex - 1; GSnapFiguresList.Delete(GSnapFiguresList.Count - 1); SetLength(GTempActualPoints, GClickIndex + 1); PCad.ClickIndex := GClickIndex; PCad.TraceFigure.OriginalPoints[3] := PCad.TraceFigure.ActualPoints[GClickIndex]; PCad.TraceFigure.OriginalPoints[2] := PCad.TraceFigure.ActualPoints[GClickIndex]; PCad.TraceFigure.OriginalPoints[1] := PCad.TraceFigure.OriginalPoints[3]; GReDrawAfterRefresh := True; // если последний !!! if GClickIndex <= 1 then begin PCad.SetTool(toSelect, 'TSelected'); //GAutoAddCableAfterDragDrop := false; if FSCS_Main.tbCADToolsExpert.Visible then FSCS_Main.tbSelectExpert.Down := True else FSCS_Main.tbSelectNoob.Down := True; FCreateObjectOnClick := False; RestoreCadGridStatus; // Tolik 04/03/2021 -- GCurrShadowTraceX := -1; GCurrShadowTraceY := -1; if GSnapFiguresList <> nil then begin GSnapFiguresList.Clear; end; end; RefreshCAD(Pcad); end; end; end; end else begin //if ActiveMDIChild <> nil then begin Self.FCreateObjectOnClick := False; PCad.SetTool(toSelect, 'TSelected'); GCadForm.FCreateObjectOnClick := False; RestoreCadGridStatus; // Tolik 04/03/2021 -- GCadForm.PCad.SetTool(toSelect, 'TSelected'); FSCS_Main.tbCreateOnClickModeExpert.Down := False; FSCS_Main.tbCreateOnClickModeNoob.Down := False; FSCS_Main.tbSelectExpert.Down := True; FSCS_Main.tbSelectNoob.Down := True; FSCS_Main.tbPrintRect.Down := False; end; Cursor := crDefault; RefreshCAD(PCad); PCad.SetTool(toSelect, 'TSelected'); if FSCS_Main.tbCADToolsExpert.Visible then // Tolik 09/02/2021 -- begin // FSCS_Main.tbCabinetExpert.Down := False; // FSCS_Main.tbCabinetExtExpert.Down := False; // FSCS_Main.tbSelectExpert.Down := True end else // Tolik 09/02/2021 -- begin //FSCS_Main.tbCabinetNoob.Down := False; //FSCS_Main.tbCabinetExtNoob.Down := False; DropDownNextToolbar; FSCS_Main.tbSelectNoob.Down := True; end; FCreateObjectOnClick := False; RestoreCadGridStatus; // Tolik 04/03/2021 -- GCurrShadowTraceX := -1; GCurrShadowTraceY := -1; if GSnapFiguresList <> nil then begin GSnapFiguresList.Clear; end; end; if PCad.TraceFigure <> nil then PCad.KillTraceFig; *) if (PCad.ToolInfo = 'TOrthoLine') then begin droptool := GClickIndex < 2; canClick := true; if (PCad.TraceFigure <> nil) and (((GClickIndex > 1) and (GFigureTraceTo = nil)) or ((GClickIndex > 0) and (GFigureTraceTo <> nil))) then begin if ((GCadForm.FAutoCadMouse = true) or ((GCadForm.FAutoCadMouse = false) and (GFigureTraceTo <> nil))) then begin //Tolik 06/09/2021 -- if (GOrthoStatus) and (GFigureTraceTo <> nil) and CheckFigureByClassName(GFigureTraceTo, cTConnectorObject) then begin if GSnapFiguresList.Count > 0 then if GSnapFiguresList[GSnapFiguresList.Count - 1] <> nil then if TFigure(GSnapFiguresList[GSnapFiguresList.Count - 1]).Id = GFigureTraceTo.Id then begin canClick := False; end; end; if CanClick then begin GClickIndex := GClickIndex + 1; droptool := GClickIndex < 2; if GClickIndex = 2 then begin if TFigure(GSnapFiguresList[0]) <> nil then begin if GFigureTraceTo.Id = TFigure(GSnapFiguresList[0]).Id then DropTool := True; end; end; PCad.TraceFigure.ShadowClick(GClickIndex, GCurrMousePos.x, GCurrMousePos.y); end; end; end; if PCad.TraceFigure <> nil then // 27/09/2021 -- PCad.EndTrace([]); if droptool then PCad.SetTool(toSelect, 'TSelected'); if GFigureTraceTo <> nil then begin if checkFigurebyClassNAme(GFigureTraceTo, cTOrthoLine) then TOrthoLine(GFigureTraceTo).isSnap := False else begin if CheckFigureByClassName(GFigureTraceTo, cTConnectorObject) then TConnectorObject(GFigureTraceTo).isSnap := False; end; GFigureTraceTo := nil; end; if GPrevFigureTraceTo <> nil then begin if checkFigurebyClassNAme(GPrevFigureTraceTo, cTOrthoLine) then TOrthoLine(GPrevFigureTraceTo).isSnap := False else begin if CheckFigureByClassName(GPrevFigureTraceTo, cTConnectorObject) then TConnectorObject(GPrevFigureTraceTo).isSnap := False; end; GPrevFigureTraceTo := nil; end; if droptool then begin GCadForm.PCad.SetTool(toSelect, ''); if FSCS_Main.tbCADToolsExpert.Visible then FSCS_Main.tbSelectExpert.Down := True else FSCS_Main.tbSelectNoob.Down := True; end; GCadForm.FCreateObjectOnClick := False; RestoreCadGridStatus; // Tolik 04/03/2021 -- RefreshCAD_T(PCad); end else begin begin Self.FCreateObjectOnClick := False; PCad.SetTool(toSelect, 'TSelected'); GCadForm.FCreateObjectOnClick := False; RestoreCadGridStatus; // Tolik 04/03/2021 -- GCadForm.PCad.SetTool(toSelect, 'TSelected'); FSCS_Main.tbCreateOnClickModeExpert.Down := False; FSCS_Main.tbCreateOnClickModeNoob.Down := False; FSCS_Main.tbSelectExpert.Down := True; FSCS_Main.tbSelectNoob.Down := True; FSCS_Main.tbPrintRect.Down := False; end; Cursor := crDefault; RefreshCAD(PCad); PCad.SetTool(toSelect, 'TSelected'); if FSCS_Main.tbCADToolsExpert.Visible then // Tolik 09/02/2021 -- begin // FSCS_Main.tbCabinetExpert.Down := False; // FSCS_Main.tbCabinetExtExpert.Down := False; // FSCS_Main.tbSelectExpert.Down := True end else // Tolik 09/02/2021 -- begin //FSCS_Main.tbCabinetNoob.Down := False; //FSCS_Main.tbCabinetExtNoob.Down := False; DropDownNextToolbar; FSCS_Main.tbSelectNoob.Down := True; end; FCreateObjectOnClick := False; RestoreCadGridStatus; // Tolik 04/03/2021 -- GCurrShadowTraceX := -1; GCurrShadowTraceY := -1; if GSnapFiguresList <> nil then begin GSnapFiguresList.Clear; end; if PCad.TraceFigure <> nil then PCad.KillTraceFig; { GCadForm.FCreateObjectOnClick := False; GCadForm.PCad.SetTool(toSelect, ''); if FSCS_Main.tbCADToolsExpert.Visible then FSCS_Main.tbSelectExpert.Down := True else FSCS_Main.tbSelectNoob.Down := True;} // end; end; end; //Tolik 06/09/2021-- if Key = VK_RETURN then begin if (PCad.ToolInfo = 'TOrthoLine') and (PCad.TraceFigure <> nil) and (((GClickIndex > 1) and (GFigureTraceTo = nil)) or ((GClickIndex > 0) and (GFigureTraceTo <> nil))) then begin begin canClick := true; if ((GCadForm.FAutoCadMouse = true) or ((GCadForm.FAutoCadMouse = false) and (GFigureTraceTo <> nil))) then begin //Tolik 06/09/2021 -- if (GOrthoStatus) and (GFigureTraceTo <> nil) and CheckFigureByClassName(GFigureTraceTo, cTConnectorObject) then begin if GSnapFiguresList.Count > 0 then if GSnapFiguresList[GSnapFiguresList.Count - 1] <> nil then if TFigure(GSnapFiguresList[GSnapFiguresList.Count - 1]).Id = GFigureTraceTo.Id then begin canClick := False; end; end; if CanClick then begin GClickIndex := GClickIndex + 1; PCad.TraceFigure.ShadowClick(GClickIndex, GCurrMousePos.x, GCurrMousePos.y); end; end; PCad.EndTrace([]); //PCad.SetTool(toSelect, 'TSelected'); if GFigureTraceTo <> nil then begin if checkFigurebyClassNAme(GFigureTraceTo, cTOrthoLine) then TOrthoLine(GFigureTraceTo).isSnap := False else begin if CheckFigureByClassName(GFigureTraceTo, cTConnectorObject) then TConnectorObject(GFigureTraceTo).isSnap := False; end; GFigureTraceTo := nil; end; if GPrevFigureTraceTo <> nil then begin if checkFigurebyClassNAme(GPrevFigureTraceTo, cTOrthoLine) then TOrthoLine(GPrevFigureTraceTo).isSnap := False else begin if CheckFigureByClassName(GPrevFigureTraceTo, cTConnectorObject) then TConnectorObject(GPrevFigureTraceTo).isSnap := False; end; GPrevFigureTraceTo := nil; end; //GAutoAddCableAfterDragDrop := false; {if FSCS_Main.tbCADToolsExpert.Visible then FSCS_Main.tbSelectExpert.Down := True else FSCS_Main.tbSelectNoob.Down := True; FCreateObjectOnClick := False; RestoreCadGridStatus; // Tolik 04/03/2021 --} { UnSnapFigure; ShadowTrace := TOrthoLine.CreateFromShadow(PCad, PCad.GetLayerHandle(2), PCad.TraceFigure); if ShadowTrace = nil then begin RefreshCAD(PCad); PCad.SetTool(toSelect, 'TSelected'); //GAutoAddCableAfterDragDrop := false; if FSCS_Main.tbCADToolsExpert.Visible then FSCS_Main.tbSelectExpert.Down := True else FSCS_Main.tbSelectNoob.Down := True; FCreateObjectOnClick := False; RestoreCadGridStatus; // Tolik 04/03/2021 -- GCurrShadowTraceX := -1; GCurrShadowTraceY := -1; if GSnapFiguresList <> nil then begin GSnapFiguresList.Clear; end; end; } //Pcad.Refresh; RefreshCAD_T(PCad); end; end; end; // // при DragOver и наведении на объект - по ТАБ переключать пути трассировки if Key = VK_TAB then begin if (FIsDragOver) and (GFigureSnap <> nil) then begin PCad.DeselectAll(2); FTracingListIndex := FTracingListIndex + 1; FSCS_Main.aSelectTracetoServer.Execute; RefreshCAD(PCad); end; end; if (ssCtrl in Shift) and (Key in [48,96]) then //22.09.2011 begin SetZoomScale(100); RefreshCAD_T(PCad); end; GMoveByArrow := False; // *UNDO* if not FCanSaveForUndo then FCanSaveForUndo := True; except on E: Exception do addExceptionToLogEx('TF_CAD.PCadKeyUp', E.Message); end; finally // Tolik GisKeyDown := False; // если отжата не Shift, Alt или Control, то вызываем EventEngine // вдруг было удаление, то он почистит FRemFigures и, при необходимости, // выполнит удаление фигур // Tolik 27/03/2019 -- { if not (Key in [VK_SHIFT, VK_CONTROL, VK_MENU]) then PCad.EventEngine(95,1,'',0);} // // end; end; procedure TF_CAD.PCadSurfaceMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Double); var CursorPos: TPoint; CursorX, CursorY: Integer; ClickedX, ClickedY: Double; MovedP: TPoint; MovedX, MovedY: Double; SetCur: TPoint; CurFigure: TFigure; begin // Tolik 23/10/2015 GisMouseDown := True; // CheckCloseReportForm; // Toilk 30/04/2021 -- try if not PCad.Focused then begin if PCad.ToolIdx = toSelect then begin SendMessage(Self.Handle, WM_ACTIVATE, MakewParam(WA_ACTIVE, 0), 0); SendMessage(Self.Handle, WM_SETFOCUS, 0, 0); end; end; if (CanChangeDownCoord)and(Button = mbLeft)and(FCreateObjectOnClick) then begin DownPoints.x := X; DownPoints.y := Y; CanChangeDownCoord := false; end; if Button = mbLeft then GIsMousePressed := True; if Button = mbRight then begin if GCadForm.FCreateObjectOnClick or Self.FCreateObjectOnClick then begin GCadForm.FCreateObjectOnClick := False; RestoreCadGridStatus; // Tolik 04/03/2021 -- Self.FCreateObjectOnClick := False; PCad.SetTool(toSelect, 'TSelected'); FSCS_Main.tbCreateOnClickModeExpert.Down := False; FSCS_Main.tbCreateOnClickModeNoob.Down := False; FSCS_Main.tbSelectExpert.Down := True; FSCS_Main.tbSelectNoob.Down := True; end; end; GTracedFigure := False; if PCad.ToolIdx = toFigure then begin GBeginPoint.X := X; GBeginPoint.Y := Y; sbView.Panels[1].Text := ''; sbView.Panels[2].Text := ''; GTracedFigure := True; end else if PCad.ToolIdx = toSelect then begin GBeginPoint.x := 0; GBeginPoint.y := 0; sbView.Panels[1].Text := ''; sbView.Panels[2].Text := ''; end; if ((PCad.ToolInfo = 'TOrthoLine') Or (PCad.ToolInfo = 'TConnectorObject')) and (GObjectStatus = False) then begin GObjectStatus := true; if F_LayersDialog.Showing then F_LayersDialog.lbCurLayer.Caption := PCad.GetLayerName(PCad.ActiveLayer); end else if (PCad.ToolIdx = toFigure) and (GObjectStatus = False) then begin GObjectStatus := true; if F_LayersDialog.Showing then F_LayersDialog.lbCurLayer.Caption := PCad.GetLayerName(PCad.ActiveLayer); end; // GlobalPos GMouseDownPos.x := X; GMouseDownPos.y := Y; except on E: Exception do addExceptionToLogEx('TF_CAD.PCadSurfaceMouseDown', E.Message); end; end; Procedure TF_CAD.ShowHideButtons; begin if Assigned(tbView) then begin if currentLayer = lnArch then begin tbShowPathTraceLengthType.visible := true; tbShowPathLengthType.Visible := true; cbMagnetWalls.Visible := true; end else begin tbShowPathTraceLengthType.visible := false; tbShowPathLengthType.Visible := false; cbMagnetWalls.Visible := false; end; if Assigned(FActiveNet) then begin if FActiveNet.Paths.Count > 0 then cbMagnetToWalls.Visible := True else cbMagnetToWalls.Visible := False; end; end; end; function TF_CAD.CreateConnectorInPM(InsertedObject: TFigure): integer; var GetIDFigure: Integer; ObjKind: TSCSObjectKind; ObjParams: TObjectParams; LHandle1: Integer; LHandle7: Integer; Cabinet: TFigure; CabinetID: Integer; Jpeg: TJpegImage; xStream: TmemoryStream; begin result := -1; CabinetID := -1; //#From Oleg# //14.09.2010 GTracedFigure := False; GObjectStatus := False; //PCadFigureSelect(nil, InsertedObject); // добавить Обьект в менеджер проектов if (F_NormBase <> Nil) and (F_ProjMan <> Nil) and (InsertedObject <> nil) then begin // добавить Конектор на CAD if CheckFigureByClassName(InsertedObject, cTConnectorObject) and (not TConnectorObject(InsertedObject).FIsApproach) then begin try //GetIDFigure := GenNewSCSObjectID; //InsertedObject.ID := GetIDFigure; GetIDFigure := InsertedObject.ID; //AddSCSFigure(InsertedObject); //07.11.2011 if TConnectorObject(InsertedObject).ConnectorType = ct_Clear then begin if (TConnectorObject(InsertedObject).FConnRaiseType <> crt_None (*crt_OnFloor*) ) then InsertedObject.Name := cCadClasses_Mes24 else InsertedObject.Name := cCadClasses_Mes12; ObjKind := okConnector; end else begin InsertedObject.Name := cCadClasses_Mes21; ObjKind := okPointObject; end; // Определить кабинет Cabinet := GetCabinetAtPos(TConnectorObject(InsertedObject).ActualPoints[1].x, TConnectorObject(InsertedObject).ActualPoints[1].y, False, InsertedObject); if Cabinet <> nil then begin if CheckFigureByClassName(Cabinet, cTCabinet) then CabinetID := TCabinet(Cabinet).FSCSID else if CheckFigureByClassName(Cabinet, cTCabinetExt) then CabinetID := TCabinetExt(Cabinet).FSCSID; end else CabinetID := -1; if (not TConnectorObject(InsertedObject).FIsApproach) and (not TConnectorObject(InsertedObject).FIsHouseJoined) then begin if GListNode = Nil then GListNode := SendObjectToPrjManager(InsertedObject.ID, FCADListID, CabinetID, InsertedObject.Name, ObjKind) else SendObjectToPrjManager(InsertedObject.ID, FCADListID, CabinetID, InsertedObject.Name, ObjKind); end; ObjParams := GetFigureParams(InsertedObject.ID); TConnectorObject(InsertedObject).Name := ObjParams.Name; TConnectorObject(InsertedObject).FIndex := ObjParams.MarkID; TConnectorObject(InsertedObject).FCabinetID := CabinetID; // поставить высоту для коннектора SetConFigureCoordZInPM(InsertedObject.ID, TConnectorObject(InsertedObject).ActualZOrder[1]); // это делается когда уже все созданы будут //SetProjectChanged(True); result := GetIDFigure; except on E: Exception do addExceptionToLogEx('TF_CAD.CreateConnectorInPM', E.Message); end; end; end; end; procedure TF_CAD.PCadObjectInserted(Sender: TObject; Reason: TInsertReason); var i: integer; InsertedObject: TFigure; GetIDFigure: Integer; ObjKind: TSCSObjectKind; ObjParams: TObjectParams; LHandle1: Integer; LHandle7: Integer; Cabinet: TFigure; CabinetID: Integer; Jpeg: TJpegImage; xStream: TmemoryStream; begin try CabinetID := -1; //#From Oleg# //14.09.2010 GTracedFigure := False; GObjectStatus := False; InsertedObject := TFigure(PCad.Figures[PCad.Figures.Count - 1]); PCadFigureSelect(Sender, InsertedObject); // добавить Обьект в менеджер проектов if (F_NormBase <> Nil) and (F_ProjMan <> Nil) and (InsertedObject <> nil) then begin {****************************************************************************} if (InsertedObject.Cname = 'TSCSHDimLine') or (InsertedObject.Cname = 'TSCSVDimLine') then begin RefreshCAD_T(PCad); if InsertedObject.Edit then RefreshCAD_T(PCad); end; // добавить Конектор на CAD if CheckFigureByClassName(InsertedObject, cTConnectorObject) and (not TConnectorObject(InsertedObject).FIsApproach) then begin GetIDFigure := GenNewSCSObjectID; InsertedObject.ID := GetIDFigure; AddSCSFigure(InsertedObject); //07.11.2011 if TConnectorObject(InsertedObject).ConnectorType = ct_Clear then begin InsertedObject.Name := cCadClasses_Mes12; ObjKind := okConnector; end else begin InsertedObject.Name := cCadClasses_Mes21; ObjKind := okPointObject; end; // Определить кабинет Cabinet := GetCabinetAtPos(TConnectorObject(InsertedObject).ActualPoints[1].x, TConnectorObject(InsertedObject).ActualPoints[1].y, False, InsertedObject); if Cabinet <> nil then begin if CheckFigureByClassName(Cabinet, cTCabinet) then CabinetID := TCabinet(Cabinet).FSCSID else if CheckFigureByClassName(Cabinet, cTCabinetExt) then CabinetID := TCabinetExt(Cabinet).FSCSID; end else CabinetID := -1; if (not TConnectorObject(InsertedObject).FIsApproach) and (not TConnectorObject(InsertedObject).FIsHouseJoined) then begin if GListNode = Nil then GListNode := SendObjectToPrjManager(InsertedObject.ID, FCADListID, CabinetID, InsertedObject.Name, ObjKind) else SendObjectToPrjManager(InsertedObject.ID, FCADListID, CabinetID, InsertedObject.Name, ObjKind); end; ObjParams := GetFigureParams(InsertedObject.ID); TConnectorObject(InsertedObject).Name := ObjParams.Name; TConnectorObject(InsertedObject).FIndex := ObjParams.MarkID; TConnectorObject(InsertedObject).FCabinetID := CabinetID; // поставить высоту для коннектора SetConFigureCoordZInPM(InsertedObject.ID, TConnectorObject(InsertedObject).ActualZOrder[1]); end // добавить Ортолинию на CAD else if CheckFigureByClassName(InsertedObject, cTOrthoLine) then begin GetIDFigure := GenNewSCSObjectID; InsertedObject.ID := GetIDFigure; InsertedObject.Name := cCadClasses_Mes20; AddSCSFigure(InsertedObject); //07.11.2011 ObjKind := okLine; // Определить кабинет Cabinet := GetCabinetAtPos(TOrthoLine(InsertedObject).ActualPoints[1].x, TOrthoLine(InsertedObject).ActualPoints[1].y, False, InsertedObject); if Cabinet <> nil then begin if CheckFigureByClassName(Cabinet, cTCabinet) then CabinetID := TCabinet(Cabinet).FSCSID else if CheckFigureByClassName(Cabinet, cTCabinetExt) then CabinetID := TCabinetExt(Cabinet).FSCSID; end else CabinetID := -1; if GListNode = Nil then GListNode := SendObjectToPrjManager(InsertedObject.ID, FCADListID, CabinetID, InsertedObject.Name, ObjKind) else SendObjectToPrjManager(InsertedObject.ID, FCADListID, CabinetID, InsertedObject.Name, ObjKind); ObjParams := GetFigureParams(InsertedObject.ID); TOrthoLine(InsertedObject).Name := ObjParams.Name; TOrthoLine(InsertedObject).FIndex := ObjParams.MarkID; TOrthoLine(InsertedObject).FCabinetID := CabinetID; // поставить высоту для линии SetLineFigureCoordZInPM(InsertedObject.ID, 1, TOrthoLine(InsertedObject).ActualZOrder[1]); SetLineFigureCoordZInPM(InsertedObject.ID, 2, TOrthoLine(InsertedObject).ActualZOrder[2]); SetLineFigureLengthInPM(InsertedObject.ID, TOrthoLine(InsertedObject).LineLength); end; {**************************************************************************} RefreshCAD_T(PCad); if F_Navigator <> nil then RefreshCAD(F_Navigator.PCadNavigator); end; if PCad.ToolInfo <> 'TOrthoLine' then // Tolik 21/09/2020 -- по просьбам телезрителей добавим сюда же и кабинетики .... if PCad.ToolInfo <> 'TCabinet' then if PCad.ToolInfo <> 'TCabinetExt' then if PCad.ToolInfo <> 'THouseTool' then // begin // IGOR 2017-05-05 Чтобы каждый раз не сбрасывалась тулза - это мы закоментим // и дополнительно это поможет обходу траблы из-за сброса PCad.KillTraceFig; на PCadToolChanged // хотя там уже проверка и есть. // IGOR 2017-05-12 пришлось таки раскоментить при добавлении коннектора так как потом при // расстановке без драг-дропа возникает ефект зажатого Шифта и типа выделять что то пытаемся когда возим мышку if (InsertedObject is TConnectorObject) or (InsertedObject.ClassName = 'TRichText') then begin //{ if Not (InsertedObject is TNet) then // Tolik 10/02/2021 -- //PCad.SetTool(toSelect, 'TSelected'); if FSCS_Main.tbCADToolsExpert.Visible then PCad.SetTool(toSelect, 'TSelected'); // if FSCS_Main.tbCADToolsExpert.Visible then begin if FSCS_Main.tbCreateOnClickModeExpert.Down = False then begin FSCS_Main.tbSelectExpert.Down := True; end; end else begin if FSCS_Main.tbCreateOnClickModeNoob.Down = False then begin FSCS_Main.tbSelectNoob.Down := True; end; end; end; //} end; if CheckFigureByClassName(InsertedObject, 'TWMFObject') then begin LHandle1 := PCad.GetLayerHandle(1); LHandle7 := PCad.GetLayerHandle(7); if PCad.ActiveLayer = 1 then InsertedObject.LayerHandle := LHandle1 else if PCad.ActiveLayer = 7 then InsertedObject.LayerHandle := LHandle7 else InsertedObject.LayerHandle := LHandle1; if InsertedObject.Selected then InsertedObject.Deselect; end else if CheckFigureByClassName(InsertedObject, 'TNet') then begin InsertedObject.Deselect; end // BMP Object Insert else if CheckFigureByClassName(InsertedObject, 'TBMPObject') then begin PCad.DeselectAll(1); InsertedObject.Select; RefreshCAD(PCad); PCad.OrderSelection(osBack); end; if not GProjectChanged then // Tolik 28/08/2019 -- SetProjectChanged(True); except on E: Exception do addExceptionToLogEx('TF_CAD.PCadObjectInserted', E.Message); end; end; procedure TF_CAD.PCadPopMenuClicked(Sender: TObject; MenuIndex: Integer); begin end; ///////////////////////////////////////////////////////// procedure TF_CAD.FormActivate(Sender: TObject); var i: integer; CurLayer: TLayer; //06.08.2012 Params: TListParams; RefreshFlag: Boolean; // Tolik 22/11/2019 -- begin FCadClose := False; // Tolik 29/04/2021 -- // Tolik 22/11/2019 -- не дать пока перерисовываться (а то захуячит несколько перерисовок сразу) // будет одна перерисовка после всех телодвижений RefreshFlag := GCanRefreshCad; GCanRefreshCad := False; // try Application.OnMessage := nil; GCadForm := Self; ActiveNet := FActiveNet; if GCadForm <> GLastCadForm then begin //06.08.2012 Params := GetListParams(Self.FCADListID); //06.08.2012 GrayedColor := Params.Settings.CADGrayedColor; // переключить переключатель листов for i := 0 to FSCS_Main.pageCADList.PageCount - 1 do begin if FSCS_Main.pageCADList.Pages[i].Tag = Self.Tag then FSCS_Main.pageCADList.ActivePage := FSCS_Main.pageCADList.Pages[i]; end; // переключить листы из меню for i := 0 to FSCS_Main.mainWindow.Count - 1 do begin if FSCS_Main.mainWindow.Items[i].Tag = Self.Tag then FSCS_Main.mainWindow.Items[i].Checked := True; end; if (F_NormBase <> nil) and (F_ProjMan <> nil) then if (FCADListID <> 0) and (FCADListName <> '') then SwitchListInPM(FCADListID, FCADListName); // последний CAD GLastCadForm := GCadForm; // восстоновить по параметры листа if FSCS_Main.ActiveMDIChild <> nil then ReturnListParams; // НАВИГАТОР if F_Navigator <> nil then begin F_Navigator.PCadNavigator.Figures := PCad.Figures; ReAssignNavigatorParams; end; // Перезаписать список слоев if FSCS_Main.cbLayers.Enabled = False then FSCS_Main.cbLayers.Enabled := True; FSCS_Main.cbLayers.Properties.BeginUpdate; try FSCS_Main.cbLayers.Properties.Items.Clear; for i := 1 to PCad.LayerCount - 1 do begin // CurLayer := TLayer(PCad.Layer[i]); // if not CurLayer.IsDxf then FSCS_Main.cbLayers.Properties.Items.Add(PCad.GetLayerName(i)); end; finally FSCS_Main.cbLayers.Properties.EndUpdate; end; if PCad.ActiveLayer > 0 then FSCS_Main.cbLayers.ItemIndex := PCad.ActiveLayer - 1; // Перезаписать масштабы if FSCS_Main.tbCADToolsExpert.Visible then begin if FSCS_Main.cbScaleExpert.Enabled = False then FSCS_Main.cbScaleExpert.Enabled := True; FSCS_Main.cbScaleExpert.Text := IntToStr(PCad.ZoomScale) + '%'; end else begin if FSCS_Main.cbScaleNoob.Enabled = False then FSCS_Main.cbScaleNoob.Enabled := True; FSCS_Main.cbScaleNoob.Text := IntToStr(PCad.ZoomScale) + '%'; end; if FListType = lt_Normal then begin EnableOptionsForNormalList; end else if FListType = lt_DesignBox then begin DisableOptionsForDesignList; end else if FListType = lt_ProjectPlan then begin DisableOptionsForProjectPlan; end // Tolik 10/02/2021 -- else //if FListType = lt_ElScheme then if ((FListType = lt_ElScheme) or (FListType = lt_AScheme)) then begin DisableOptionsForEl_Scheme; end; // обновить навигатор if F_Navigator <> nil then RefreshCAD(F_Navigator.PCadNavigator); // if F_LayersDialog.Showing then F_LayersDialog.LoadFromCADForm(Self); end; // FSCS_Main.cbLayers.Enabled := True; if FSCS_Main.tbCADToolsExpert.Visible then FSCS_Main.cbScaleExpert.Enabled := True else FSCS_Main.cbScaleNoob.Enabled := True; if CurrentLayer <> PCad.ActiveLayer then CurrentLayer := PCad.ActiveLayer; if FCreateObjectOnClick then begin if FSCS_Main.tbCADToolsExpert.Visible then begin FSCS_Main.tbSelectExpert.Down := False; FSCS_Main.tbCreateOnClickModeExpert.Down := True; end else begin FSCS_Main.tbSelectNoob.Down := False; FSCS_Main.tbCreateOnClickModeNoob.Down := True; end; FSCS_Main.SkipCADPanelChecked; end else begin if FSCS_Main.ActiveMDIChild <> nil then begin if (PCad.ToolInfo = 'TOrthoLine') or (PCad.ToolInfo = TBetweenFloorDownVertex.ClassName) or (PCad.ToolInfo = TBetweenFloorUpVertex.ClassName) then begin end else begin if FSCS_Main.tbCADToolsExpert.Visible then begin FSCS_Main.tbSelectExpert.Click; FSCS_Main.tbSelectExpert.Down := True; FSCS_Main.tbCreateOnClickModeExpert.Down := False; end else begin FSCS_Main.tbSelectNoob.Click; FSCS_Main.tbSelectNoob.Down := True; FSCS_Main.tbCreateOnClickModeNoob.Down := False; end; end; { if FFirstActivate then begin if FSCS_Main.tbCADToolsExpert.Visible then begin FSCS_Main.tbPanExpert.Click; FSCS_Main.tbPanExpert.Down := True; FSCS_Main.tbCreateOnClickModeExpert.Down := False; end else begin FSCS_Main.tbPanNoob.Click; FSCS_Main.tbPanNoob.Down := True; FSCS_Main.tbCreateOnClickModeNoob.Down := False; end; FSCS_Main.aToolPan.Execute; FFirstActivate := False; end else begin if FSCS_Main.tbCADToolsExpert.Visible then begin FSCS_Main.tbSelectExpert.Click; FSCS_Main.tbSelectExpert.Down := True; FSCS_Main.tbCreateOnClickModeExpert.Down := False; end else begin FSCS_Main.tbSelectNoob.Click; FSCS_Main.tbSelectNoob.Down := True; FSCS_Main.tbCreateOnClickModeNoob.Down := False; end; end; } end; end; except on E: Exception do addExceptionToLogEx('TF_CAD.FormActivate', E.Message); end; if GReadOnlyMode then begin //PCad.Enable := False; end; // Tolik 22/11/2019 -- тут перерисуем и вернем флажок на место GCanRefreshCad := True; GCadForm.PCad.Refresh; GCanRefreshCad := RefreshFlag; // end; procedure TF_CAD.PCadFigureMoved(Sender: TObject; Figure: TFigure; dx, dy: Double); var CurrPointObject: TConnectorObject; CheckedBreak: Boolean; i: integer; begin try if CheckFigureByClassName(Figure, cTConnectorObject) then begin if TConnectorObject(Figure).ConnectorType = ct_Clear then begin for i := 0 to TConnectorObject(Figure).JoinedConnectorsList.Count - 1 do begin CurrPointObject := TConnectorObject(TConnectorObject(Figure).JoinedConnectorsList[i]); if not CurrPointObject.Selected then begin CheckedBreak := CheckByBreakConnector(TConnectorObject(Figure), CurrPointObject); if CheckedBreak then UnsnapConnectorFromPointObject(TConnectorObject(Figure), CurrPointObject); end; end; end; end; if (FSCS_Main.aViewCADObjectsProp.Checked) OR (GObjectProperty = True) then F_SizePos.DefineObjectSizePos; if F_Navigator <> nil then RefreshCAD(F_Navigator.PCadNavigator); if not GProjectChanged then // Tolik 28/08/2019 -- SetProjectChanged(True); except on E: Exception do addExceptionToLogEx('TF_CAD.PCadFigureMoved', E.Message); end; end; procedure TF_CAD.PCadFigureModify(Sender: TObject; Figure: TFigure); begin try if (FSCS_Main.aViewCADObjectsProp.Checked) OR (GObjectProperty = True) then F_SizePos.DefineObjectSizePos; if F_Navigator <> nil then RefreshCAD(F_Navigator.PCadNavigator); // Tolik -- 30/11/2015 -- чтобы изменение проекта не перекрывало обновление КАДа по таймеру //RefreshCAD_T(PCad); //SetProjectChanged(True); if not GProjectChanged then // Tolik 28/08/2019 -- SetProjectChanged(True); RefreshCAD_T(PCad); // except on E: Exception do addExceptionToLogEx('TF_CAD.PCadFigureModify', E.Message); end; end; // При Драге найти линии на которые ложиться кабель! procedure TF_CAD.PCadSurfaceDragOver(Sender, Source: TObject; X, Y: Double; State: TDragState; var Accept: Boolean); var i: integer; DropPoints: TDoublePoint; vList: TF_CAD; vBox: TConnectorObject; SDDrawed: Boolean; begin try if Abs(GetTickCount - FDragOverTick) < 40 then Exit; ///// EXIT ///// FDragOverTick := GetTickCount; SDDrawed := false; FIsDragOver := True; FDragX := X; FDragY := Y; if not PCad.Focused then if PCad.ToolIdx = toSelect then begin SendMessage(Self.Handle, WM_ACTIVATE, MakewParam(WA_ACTIVE, 0), 0); SendMessage(Self.Handle, WM_SETFOCUS, 0, 0); end; if FListType <> lt_Normal then begin GCanCopyComponToCAD := False; if GDropComponent.IsLine = 0 then begin vList := GetListByID(FJoinedListIDForDesignList); if vList <> nil then begin vBox := TConnectorObject(GetFigureByID(vList, FJoinedBoxIDForDesignList)); if vBox <> nil then begin if ComplectNBComponToProjObj(vBox.ID, GDropComponent, True) then begin GCanCopyComponToCAD := True; exit; end; end; end; end; end; if not GCanCopyComponToCAD then begin if (GListWithEndPoint <> nil) and (GListWithEndPoint <> Self) then begin try GListWithEndPoint.PCad.DeselectAll(2); except end; RefreshCAD(GListWithEndPoint.PCad); end; try PCad.DeselectAll(2); except end; RefreshCAD(PCad); Accept := False; Exit; end; // при движении над CAD попытка привязки if GDropComponent <> Nil then begin Accept := True; // тянеться коннектор отобразить Shadow if GDropComponent.IsLine = 0 then begin { if GCadForm.PCad.SnapToGrids then DropPoints := GetCoordsWithSnapToGrid(X, Y) else DropPoints := DoublePoint(X, Y); } if (PCad.SnapToGuides)or(PCad.SnapToGrids) then begin DropPoints := GetCoordsWithSnapToGrid(X, Y) end else DropPoints := DoublePoint(X, Y); GIsDrawShadow := True; //Tolik 05/01/2022 -- if (GCadForm.cbMagnetToWalls.Down and (not (ssShift in GGlobalShiftState))) then begin CalcShadowPoint(x,y); if GShadowMagnetPoint.x <> -100 then begin GShadowObject.ShadowCP.x := GShadowMagnetPoint.x; GShadowObject.ShadowCP.y := GShadowMagnetPoint.y; end else begin GShadowObject.ShadowCP.x := DropPoints.x; GShadowObject.ShadowCP.y := DropPoints.y; end; end else begin GShadowObject.ShadowCP.x := DropPoints.x; GShadowObject.ShadowCP.y := DropPoints.y; end; /// -------------- GShadowObject.draw(PCad.DEngine, False); {GIsDrawShadow := False;} {PCad.DrawTrace; GShadowObject.Move(DropPoints.x - GShadowObject.ShadowCP.x, DropPoints.y - GShadowObject.ShadowCP.y); GShadowObject.ShadowCP.x := DropPoints.x; GShadowObject.ShadowCP.y := DropPoints.y; PCad.DrawTrace; } SDDrawed := true; //RefreshCAD(PCad); /// -------------- end; // искать обьект в режиме перетаскивания if not (ssAlt in GGlobalShiftState) then GFigureSnap := FindAutoSnapObject(X, Y, GDropComponent) else GFigureSnap := nil; if not SCSClassDetect(GFigureSnap) then GFigureSnap := nil; // убрать выделение всех трасс на которые мог проложиться кабель if (GPrevFigureSnap <> nil) AND (GPrevFigureSnap <> GFigureSnap) then begin TConnectorObject(GFigureSnap).DrawSnapFigures(GPrevFigureSnap, False); for i := 0 to PCad.SelectedCount - 1 do if CheckFigureByClassName(TFigure(PCad.Selection[i]), cTOrthoLine) then TConnectorObject(GFigureSnap).DrawSnapFigures(TFigure(PCad.Selection[i]), False); end; // Есть объект для дропа if GFigureSnap <> nil then begin // ложить обьект на ортолинию if CheckFigureByClassName(GFigureSnap, cTOrthoLine) then begin // поставить выделение для всех трасс на которые прокладываеться кабель TConnectorObject(GFigureSnap).DrawSnapFigures(GFigureSnap, True); RefreshCAD(PCad); GPrevFigureSnap := GFigureSnap; // Tolik 28/05/2021 -- if GDropComponent.IsLine = 1 then begin Accept := True; if isCableComponent(GDropComponent) then begin if GFigureSnap <> nil then begin if CheckFigurebyClassName(GFigureSnap, cTOrthoLine) then begin Accept := GAllowDropCableToRoute; end; end; end; end; // if GDropComponent.IsLine = 1 then // тянеться кабель begin for i := 0 to PCad.SelectedCount - 1 do if CheckFigureByClassName(TFigure(PCad.Selection[i]), cTOrthoLine) then begin if Accept then // Tolik 28/05/2021 -- TConnectorObject(GFigureSnap).DrawSnapFigures(TFigure(PCad.Selection[i]), True); end; end; if not Accept then // Tolik 28/05/2021 -- begin GFigureSnap := Nil; try PCad.DeselectAll(2); except end; RefreshCAD(PCad); Exit; end; end else if CheckFigureByClassName(GFigureSnap, cTConnectorObject) then begin TConnectorObject(GFigureSnap).DrawSnapFigures(GFigureSnap, True); if GDropComponent.IsLine = 1 then FSCS_Main.aSelectTracetoServer.Execute; RefreshCAD(PCad); GPrevFigureSnap := GFigureSnap; end; if GDropComponent.IsLine = 0 then if GShadowObject <> nil then GShadowObject.draw(PCad.DEngine, False); end else // Нет объекта для дропа begin if (GListWithEndPoint <> nil) and (GListWithEndPoint <> Self) then begin //if GListWithEndPoint.PCad.FAnySelected then begin try GListWithEndPoint.PCad.DeselectAll(2); except end; RefreshCAD(GListWithEndPoint.PCad); end; end; //if PCad.FAnySelected then begin try // PCad.DeselectAll(2); //Tolik commented 03/11/2021 -- except end; RefreshCAD(PCad); end; if GDropComponent.IsLine = 1 then Accept := True; end; if GFigureSnap = nil then GDraggedFigureZOrder := FConnHeight else begin if CheckFigureByClassName(GFigureSnap, cTConnectorObject) then GDraggedFigureZOrder := TConnectorObject(GFigureSnap).ActualZOrder[1] else if CheckFigureByClassName(GFigureSnap, cTOrthoLine) then GDraggedFigureZOrder := TOrthoLine(GFigureSnap).ActualZOrder[1]; end; end else Accept := False; // Tolik 19/05/2021 -- потому что по умолчанию приходит true except on E: Exception do addExceptionToLogEx('TF_CAD.PCadSurfaceDragOver', E.Message); end; end; procedure TF_CAD.PCadSurfaceEndDrag(Sender, Target: TObject; X, Y: Double); begin FIsDragOver := False; end; // Про Дропе объекта на CAD! procedure TF_CAD.PCadSurfaceDragDrop(Sender, Source: TObject; X, Y: Double); var i: integer; FiguresList: TList; Item: TMenuItem; FFigure: TFigure; Point: TPoint; FHeightStr: string; PortCount: integer; PartComponent: TSCSComponent; AList: TSCSList; CheckFigureClassName: string; begin try FIsDragOver := False; GIsDrawShadow := False; FDragX := X; FDragY := Y; FiguresList := nil; CheckFigure := nil; CheckFigureClassName := ''; if not GCanCopyComponToCAD then Exit; if GFigureSnap <> nil then if PCad.SelectedCount = 0 then begin FiguresList := GetFiguresByLevel(GFigureSnap, X, Y, False{True}, true); // формировать список объектов if FiguresList.Count > 1 then begin GFigureSnap := nil; GetCursorPos(Point); //07.02.2011 //FSCS_Main.pmFiguresByLevel.Items.Clear; // for i := 0 to FiguresList.Count - 1 do // begin // FFigure := TFigure(FiguresList[i]); // Item := TMenuItem.Create(FSCS_Main.pmFiguresByLevel); // FHeightStr := ''; // if CheckFigureByClassName(FFigure, cTOrthoLine) then // if TOrthoLine(FFigure).ActualZOrder[1] = TOrthoLine(FFigure).ActualZOrder[2] then // FHeightStr := FormatFloat(ffMask, MetreToUOM(TOrthoLine(FFigure).ActualZOrder[1])) // else // FHeightStr := FormatFloat(ffMask, MetreToUOM(TOrthoLine(FFigure).ActualZOrder[1])) + '-' + // FormatFloat(ffMask, MetreToUOM(TOrthoLine(FFigure).ActualZOrder[2])); // if CheckFigureByClassName(FFigure, cTConnectorObject) then // FHeightStr := FormatFloat(ffMask, MetreToUOM(TConnectorObject(FFigure).ActualZOrder[1])); // Item.Caption := GetFullFigureName(FFigure, X,Y) + ' (' + FHeightStr + GetUOMString(GCurrProjUnitOfMeasure) + ')'; // FSCS_Main.pmFiguresByLevel.Items.Add(Item); // Item.Tag := FFigure.ID; // Item.OnClick := DropFigureEvent; // end; // Tolik 12/04/2018 -- for i := FiguresList.Count - 1 downto 0 do begin if CheckFigureByClassName(TFigure(FiguresList[i]), cTOrthoLine) then if TOrthoLine(FiguresList[i]).FisVertical then FiguresList.delete(i); end; // BuildPopupFiguresByLevel(FiguresList, DropFigureEvent, X,Y); FSCS_Main.pmFiguresByLevel.Popup(Point.X, Point.Y); FreeAndNil(FiguresList); exit; end; if FiguresList <> nil then FreeAndNil(FiguresList); end; CheckFigure := CheckBySCSObjects(X, Y); if CheckFigure <> nil then begin CheckFigureClassName := CheckFigure.ClassName; end; DoDragDrop(X, Y); if not GProjectChanged then // Tolik 28/08/2019 -- SetProjectChanged(True); //*****Рисование направляющих при дропе фигуры на КАД*********************** //************* Митяй Д.В. ************************************ ShowHintIFFigInsideCab(X, Y); {$IF Not Defined(ES_GRAPH_SC)} if CheckFigureClassName = 'TOrthoLine' then CheckFigure := nil; if (GDropComponent <> nil) and (GDropComponent.IsLine <> 1) and (GFigureSnap = nil) and (CheckFigure = nil) then begin if GDropComponent.Interfaces <> nil then begin if GDropComponent.Interfaces.Count = 0 then GDropComponent.LoadInterfaces(-1, false); GDropComponent.LoadChildComplectsQuick(true, false, true, GDropComponent.IDTopComponent, GDropComponent.IDCompRel); //PortCount := GetPortsCountReadyToConnectByInterf(GDropComponent, 0, true); PortCount := GetPortsCount(GDropComponent, 0, true); // Tolik 02/03/2021 -- //if (PortCount < 10) and (PortCount > 0) then {if ((PortCount < 10) and (PortCount > 0)) or (GDropComponent.ComponentType.Sysname = ctsnLAMP) or (GDropComponent.ComponentType.Sysname = ctsnSocket) or (GDropComponent.ComponentType.Sysname = ctsnPlugSwitch) or (GDropComponent.ComponentType.Sysname = ctsnTerminalBox) then} if CheckNeedDrawGuides(PortCount) then // begin DrawGuidesOnDrop(X, Y); if PCad.SnapToGrids then // Tolik 04/03/2021 -- begin GSavedSnapGridStatus := 1; tbSnapGrid.Click; end; end; end; end; {$IFEND} if CheckFigure <> nil then CheckFigure := nil; except on E: Exception do addExceptionToLogEx('TF_CAD.PCadSurfaceDragDrop', E.Message); end; end; procedure TF_CAD.PCadSurfaceMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Double); var i: integer; Point: TPoint; FigureProperty: TFigure; CurrentWA: TConnectorObject; CurrentServer: TConnectorObject; AllTraceProp: TTraceWithProperties; LineLen: Double; FIsRaiseLineFigure: TFigure; AllCablesTraces: TList; //17.01.2013 AllCables: TList; begin try try //Tolik 16/08/2021 -- if Button = mbRight then begin UnSnapFigure; //Tolik 16/08/2021 -- //if (GClickIndex = 0) and (NewFigure = nil) then //if (GClickIndex = 0) and (PCad.ToolIdx <> toSelect) then if (PCad.TraceFigure = nil) and (PCad.ToolIdx <> toSelect) then begin //Settool(toSelect,''); // SetTool(toSelect, 'TSelected'); DropTool; end; end; // // // Tolik -- 21/04/2016 -- //if GLastConnector <> nil then // if GCadForm.PCad.Figures.IndexOf(GLastConnector) = -1 then // GLastConnector := Nil; // if (Button = mbMiddle) and (PCad.ToolIdx = TPCTool(toFigure)) then exit; GIsMousePressed := False; // Контекстное меню GListNode := Nil; CurrentServer := nil; //#From Oleg# //14.09.2010 if Button = mbRight then begin // сбросить Шедоу с перемещения if GLastConnector <> nil then begin if CheckFigureByClassName(GLastConnector, cTConnectorObject) then GLastConnector.SkipConnectedLinesDrawShadow; end; // сбросить выделенные для привязки if GPrevFigureSnap <> nil then begin TConnectorObject(GPrevFigureSnap).DrawSnapFigures(GPrevFigureSnap, False); GPrevFigureSnap := nil; end; // сбросить выделенные для привязки if GFigureSnap <> nil then begin TConnectorObject(GFigureSnap).DrawSnapFigures(GFigureSnap, False); GFigureSnap := nil; end; end; if PCad.IsDragging then begin if GLastConnector <> nil then begin if CheckFigureByClassName(GLastConnector, cTConnectorObject) then GLastConnector.SkipConnectedLinesDrawShadow; // Tolik 18/04/2018 -- if GFigureSnap <> nil then if CheckFigureByClassName(GFigureSnap, cTConnectorObject) then begin //TConnectorObject(GFigureSnap).IsSnap := False; //TConnectorObject(GFigureSnap).Draw(PCad.DEngine, false); //PCad.Refresh; end; // end; end; if (Button = mbRight) and (PCad.ToolIdx = toSelect) then begin FormCADPopupMenu(X, Y, true); //16.12.2011 - Выделяем объект в МП if GPopupFigure <> nil then begin if (GPopupFigure is TOrthoLine) or (GPopupFigure is TConnectorObject) then ShowObjectInPM(GPopupFigure.ID, '') else if GPopupFigure is TNet then SelectComponInPM(FCADListID, GPopupFigure.ID); end; end; // показ длинны отрезка трассы (old) if (Button = mbLeft) and (PCad.ToolIdx = toSelect) then begin if PCad.SelectedCount = 1 then if CheckFigureByClassName(TFigure(PCad.Selection[0]), cTOrthoLine) then begin LineLen := TOrthoLine(PCad.Selection[0]).LineLength; if TOrthoLine(PCad.Selection[0]).FIsRaiseUpDown then sbView.Panels[1].Text := cCad_Mes13 + FormatFloat(ffMask, MetreToUOM(LineLen)) + GetUOMString(GCurrProjUnitOfMeasure) else sbView.Panels[1].Text := cCad_Mes14 + FormatFloat(ffMask, MetreToUOM(LineLen)) + GetUOMString(GCurrProjUnitOfMeasure); end; end; // проверка - есть ли выделенный обьект if (FSCS_Main.aViewCADObjectsProp.Checked) OR (GObjectProperty = True) then begin if PCad.Selection.Count = 1 then begin FigureProperty := TFigure(PCad.Selection[0]); F_SizePos.DefineObjectSizePos; F_SizePos.edObjectName.Text := GetFullFigureName(FigureProperty, X,Y); end else begin F_SizePos.edWidth.Clear; F_SizePos.edHeight.Clear; F_SizePos.edAngle.Clear; F_SizePos.edX.Clear; F_SizePos.edY.Clear; F_SizePos.edZ.Clear; F_SizePos.edObjectName.Clear; end; end; if F_Navigator <> nil then RefreshCAD(F_Navigator.PCadNavigator); {********** ОБРАБОТКА ТРАССЫ (SELECT & UNSELECT) **************************} // Убрать предыдущее выделение трассы if GExistsSelectTrace then begin DeselectTraceInCAD; GExistsSelectTrace := False; end; // есть конечный объект if GEndPoint <> nil then begin // Выделить всю трассу если она есть if (PCad.ToolIdx = toSelect) and (FAutoSelectTrace = True) and (PCad.SelectedCount = 1) then begin if CheckFigureByClassName(TFigure(PCad.Selection[0]), cTConnectorObject) and (TFigure(PCad.Selection[0]) <> GEndPoint) then begin if TConnectorObject(PCad.Selection[0]).ConnectorType <> ct_Clear then begin CurrentWA := TConnectorObject(PCad.Selection[0]); if CheckFigureByClassName(GEndPoint, cTConnectorObject) then CurrentServer := TConnectorObject(GEndPoint) else if CheckFigureByClassName(GEndPoint, cTHouse) then CurrentServer := GetEndPointByHouse(THouse(GEndPoint), CurrentWA); // получить трассу if CurrentServer <> nil then begin AllTraceProp := GetAllTraceWithProperties(CurrentServer.ID, CurrentWA.ID); if AllTraceProp.Trace <> nil then begin AllTraceProp.Length := SelectTraceInCAD(AllTraceProp.Trace); sbView.Panels[1].Text := GetMsgLengthToPoint(AllTraceProp.Length); //cCad_Mes15 + FormatFloat(ffMask, MetreToUOM(AllTraceProp.Length)) + GetUOMString(GCurrProjUnitOfMeasure); end; FreeAndNil(AllTraceProp.Trace); GExistsSelectTrace := True; end; end; end; end; end else // нет конечного объекта begin // Выделить всю трассу если она есть if (PCad.ToolIdx = toSelect) and (FAutoSelectTrace = True) and (PCad.SelectedCount = 1) then begin if CheckFigureByClassName(TFigure(PCad.Selection[0]), cTConnectorObject) then begin if TConnectorObject(PCad.Selection[0]).ConnectorType <> ct_Clear then begin CurrentWA := TConnectorObject(PCad.Selection[0]); // получить трассу AllCablesTraces := GetConnectedTracesToConFigure(CurrentWA.ID); if AllCablesTraces <> nil then SelectTraceInCAD(AllCablesTraces); // Tolik -- 04/10/2017 -- //FreeAndNil(AllCablesTraces); -- утечка памяти FreeList(AllCablesTraces); // GExistsSelectTrace := True; end; end; end; end; // PCad.SnapToGrids := True; except on E: Exception do addExceptionToLogEx('TF_CAD.PCadSurfaceMouseUp', E.Message); end; finally GisMouseDown := False; end; end; procedure TF_CAD.PCadSurfaceDblClick(Sender: TObject); var i: integer; ClickFigure: TFigure; GlobalClickFigure: TFigure; GlobalClickFigureTmp: TFigure; Currline: TOrthoLine; CheckedFigure: TFigure; LNbr: Integer; OldLayer: Integer; TestLayer: TLayer; begin try if FCreateObjectOnClick then exit; if PCad.ToolIdx = TPCTool(toFigure) then begin GIsMousePressed := GIsMousePressed; exit; end; GIsMousePressed := False; if TimerDblClk.Enabled then exit; OldLayer := PCad.ActiveLayer; if PCad.ToolIdx = TPCTool(11) then begin TimerDblClk.Enabled := True; exit; end; GlobalClickFigureTmp := nil; GlobalClickFigure := nil; try ClickFigure := CheckBySCSObjects(GCurrMousePos.x, GCurrMousePos.y); except ClickFigure := nil; end; if ClickFigure = nil then begin try GlobalClickFigure := PCad.CheckByPoint(PCad.ActiveLayer, GCurrMousePos.x, GCurrMousePos.y); if GlobalClickFigure = nil then begin GlobalClickFigure := PCad.CheckByPoint(0, GCurrMousePos.x, GCurrMousePos.y); if GlobalClickFigure <> nil then begin if GlobalClickFigure is TBlock then begin GlobalClickFigureTmp := GlobalClickFigure; GlobalClickFigure := Nil; end; end; end; except GlobalClickFigure := nil; end; end else GlobalClickFigure := ClickFigure; if (ClickFigure = nil) and (GlobalClickFigure = nil) and (GlobalClickFigureTmp = nil) then begin TimerDblClk.Enabled := True; exit; end; { if (ClickFigure = nil) and (GlobalClickFigure <> nil) and (GlobalClickFigure.Selected) then begin LNbr := GLN(GlobalClickFigure.LayerHandle); if Lnbr = 1 then begin if (Not (GlobalClickFigure is TSCSHDimLine)) and (Not (GlobalClickFigure is TSCSVDimLine)) then begin GlobalClickFigure := nil; TimerDblClk.Enabled := True; exit; end; end; end; if (ClickFigure = nil) and (GlobalClickFigure = nil) then begin TimerDblClk.Enabled := True; exit; end; } if (GlobalClickFigure <> nil) and (not GlobalClickFigure.Selected) then begin LNbr := GLN(GlobalClickFigure.LayerHandle); try TestLayer := Tlayer(PCad.Layers[LNbr]); // если это ДХФ слой if TestLayer.IsDxf then LNbr := 1; except end; {$IF Not Defined(ES_GRAPH_SC)} //if LNbr <> 1 then //begin {$IFEND} if CurrentLayer <> LNbr then begin PCad.DeselectAll(CurrentLayer); RefreshCAD(PCad); CurrentLayer := LNbr; GlobalClickFigure.Select; RefreshCAD(PCad); end else begin CheckByCaptionsNotes(GCurrMousePos.x, GCurrMousePos.y); end; {$IF Not Defined(ES_GRAPH_SC)} //end //else //begin // ClickFigure := nil; // GlobalClickFigure := nil; //end; {$IFEND} end; if ClickFigure <> nil then begin if PCad.ActiveLayer = 2 then begin GPopupFigure := ClickFigure; if OldLayer = 2 then begin if not CheckFigureByClassName(GPopupFigure, cTHouse) then begin // Tolik 26/02/2022 -- { if CheckEmptyFigure(GPopupFigure.ID) then begin if CheckFigureByClassName(GPopupFigure, cTConnectorObject) then begin if not TConnectorObject(GPopupFigure).FIsApproach then FSCS_Main.aObjProperties.Execute; end else FSCS_Main.aObjProperties.Execute; end else FSCS_Main.aComponProperties.Execute; } if CheckEmptyFigure(GPopupFigure.ID) then begin if CheckFigureByClassName(GPopupFigure, cTConnectorObject) then begin if not TConnectorObject(GPopupFigure).FIsApproach then begin TimerShowPopup.Enabled := False; FSCS_Main.aObjProperties.Execute; end; end else begin TimerShowPopup.Enabled := False; FSCS_Main.aObjProperties.Execute; end; end else begin TimerShowPopup.Enabled := False; FSCS_Main.aComponProperties.Execute; end; end; end; end; // выделить всю трассу на CAD if CheckFigureByClassName(ClickFigure, cTConnectorObject) then begin if PCad.ActiveLayer = 2 then if FAutoSelectTrace then if GEndPoint <> nil then FSCS_Main.aSelectTracetoServer.Execute; end; end; if (ClickFigure = nil) and (GlobalClickFigure = nil) then begin {$IF Defined(ES_GRAPH_SC)} CurrentLayer := 8; {$else} if PCad.ActiveLayer <> 2 then CurrentLayer := 2 //else // TimerDblClk.Enabled := True; {$ifend} end; except on E: Exception do addExceptionToLogEx('TF_CAD.PCadSurfaceDblClick', E.Message); end; end; Function TF_CAD.GetPieAngle(Fangle, SAngle: Double): Double; var Angle1, Angle2: Integer; begin { if CompareValue(Fangle, SAngle) = 1 then Result := Round((FAngle*180)/PI - (SAngle*180)/PI) else if CompareValue(Fangle, SAngle) = -1 then Result := Round((SAngle*180)/PI - (FAngle*180)/PI) else Result := 0; } Angle1 := Round((180/pi)*Sangle); Angle2 := Round((180/pi)*Fangle); if Angle1 = 360 then Angle1 := 0; if Angle2 = 360 then Angle2 := 0; Result := 0; while Angle1 <> Angle2 do begin Result := Result + 1; angle1 := angle1 + 1; if angle1 = 360 then angle1 := 0; end; end; function TF_CAD.GetFigureAngle(AP1x, AP1y, AP2x, AP2y: Double): Double; var Len_X, Len_Y: Double; AngleRad: Double; AddAngle: Double; begin Result := 0; try Len_X := Abs(AP1x - AP2x); Len_Y := Abs(AP1y - AP2y); // проверки и вычиление угла в градусах AngleRad := 0; AddAngle := 0; // для неортогональных линий if (AP1x < AP2x) and (AP1y < AP2y) then // 1 begin AngleRad := ArcTan2(Len_Y, Len_X); // угол в радианах AddAngle := 0; end; if (AP1x > Ap2x) and (AP1y < AP2y) then //2 begin AngleRad := ArcTan2(Len_X, Len_Y); // угол в радианах AddAngle := 90; end; if (AP1x > AP2x) and (AP1y > AP2y) then //3 begin AngleRad := ArcTan2(Len_Y, Len_X); // угол в радианах AddAngle := 180; end; if (AP1x < AP2x) and (AP1y > AP2y) then //4 begin AngleRad := ArcTan2(Len_X, Len_Y); // угол в радианах AddAngle := 270; end; Result := Round(AngleRad * 180 / pi) + AddAngle; // для ортогональных линий if (AP1y = AP2y) and (AP1x < AP2x) then Result := 0; if (AP1y = AP2y) and (AP1x > AP2x) then Result := 180; if (AP1x = AP2x) and (AP1y < AP2y) then Result := 90; if (AP1x = AP2x) and (AP1y > AP2y) then Result := 270; except on E: Exception do addExceptionToLogEx('TF_CAD.GetFigureAngle', E.Message); end; end; procedure TF_CAD.PCadFigureSelect(Sender: TObject; Figure: TFigure); begin {//02.04.2012 try except on E: Exception do addExceptionToLogEx('TF_CAD.PCadFigureSelect', E.Message); end;} end; procedure TF_CAD.PCadGUIEvent(Sender: TObject; EventId, Numval: Integer; StrVal: String; DblVal: Double; CEnable: Boolean); var i, j: integer; RemJoinedFigure: TFigure; Joined1: TConnectorObject; Joined2: TConnectorObject; DelFigure, RemFigure: TFigure; IdxManualDel: Integer; //02.08.2013 IsManualDel: Boolean; aNeedEnd: boolean; //Tolik DelIndex: Integer; WasDel: Boolean; DelGrpFigure: TFigureGrpMod; UserQuotaReached : Integer; UserQuotaReached_Message: string; // //Tolik 24/01/2019 -- Procedure CheckRemFigures; var i, j, k: Integer; DelConn: TConnectorObject; DelRaise, RaiseLine: TOrthoLine; begin FRemFigures.Pack; // Tolik 13/01/2020 for i := 0 to FRemFigures.Count - 1 do begin if TFigure(FRemFigures[i]).ClassName = 'TOrthoLine' then begin if TOrthoLine(FRemFigures[i]).FisRaiseUpDown then begin delRaise := TOrthoLine(FRemFigures[i]); end; end else begin DelConn := TConnectorObject(FRemFigures[i]); for j := 0 to GCadForm.FSCSFigures.Count - 1 do begin if TFigure(GCadForm.FSCSFigures[j]).ClassName = 'TConnectorObject' then begin if TConnectorObject(GCadForm.FSCSFigures[j]).FObjectFromRaise <> nil then if TConnectorObject(GCadForm.FSCSFigures[j]).FObjectFromRaise.ID = delConn.ID then TConnectorObject(GCadForm.FSCSFigures[j]).FObjectFromRaise := Nil; end; end; //if DelConn.ConnectorType = ct_NB then begin for j := 0 to GCadForm.FSCSFigures.Count - 1 do begin if TFigure(GCadForm.FSCSFigures[j]).ClassName = 'TOrthoLine' then if TOrthoLine(GCadForm.FSCSFigures[j]).FisRaiseUpDown then begin RaiseLine := TOrthoLine(GCadForm.FSCSFigures[j]); if not RaiseLine.Deleted then begin if FRemFigures.IndexOf(RaiseLine) = -1 then if RaiseLine.FObjectFromRaisedLine <> nil then if RaiseLine.FObjectFromRaisedLine.ID = DelConn.ID then begin { for k := 0 to DelConn.JoinedConnectorsList.Count - 1 do begin if not TConnectorObject(DelConn.JoinedConnectorsList[k]).deleted then TOrthoLine(GCadForm.FSCSFigures[j]).FObjectFromRaisedLine := TConnectorObject(DelConn.JoinedConnectorsList[k]); end; } RaiseLine.FObjectFromRaisedLine := Nil; if TConnectorObject(RaiseLine.JoinConnector1).JoinedConnectorsList.IndexOf(DelConn) <> -1 then begin TConnectorObject(RaiseLine.JoinConnector1).FConnRaiseType := DelConn.FConnRaiseType; RaiseLine.FObjectFromRaisedLine := TConnectorObject(RaiseLine.JoinConnector1); end else if TConnectorObject(RaiseLine.JoinConnector2).JoinedConnectorsList.IndexOf(DelConn) <> -1 then begin TConnectorObject(RaiseLine.JoinConnector2).FConnRaiseType := DelConn.FConnRaiseType; RaiseLine.FObjectFromRaisedLine := TConnectorObject(RaiseLine.JoinConnector2); end; if RaiseLine.FObjectFromRaisedLine = nil then begin if TConnectorObject(RaiseLine.JoinConnector1).FConnRaiseType = crt_None then RaiseLine.FObjectFromRaisedLine := TconnectorObject(RaiseLine.JoinConnector1) end else RaiseLine.FObjectFromRaisedLine := TConnectorObject(RaiseLine.JoinConnector2); end; if TConnectorObject(RaiseLine.JoinConnector1).FObjectFromRaise = delConn then TConnectorObject(RaiseLine.JoinConnector1).FObjectFromRaise := TConnectorObject(RaiseLine.JoinConnector2) else if TConnectorObject(RaiseLine.JoinConnector2).FObjectFromRaise = delConn then TConnectorObject(RaiseLine.JoinConnector2).FObjectFromRaise := TConnectorObject(RaiseLine.JoinConnector1); end; end; end; end; end; end; end; // begin if Not InGUIEvent then begin // Tolik -- 22/12/2016 -- if not GCanRefreshCad then exit; InGUIEvent := True; try if EventId = 95 then begin // Tolik 24/02/2017 -- if GUserOBjectsQuotaLimit_Message_Counter < 3 then begin if GGuiEventCallCounter > 500 then begin GGuiEventCallCounter := 0; UserQuotaReached_Message := ''; UserQuotaReached_Message := GetQuotaMessage(CheckUserObjQuotaReached(1), cMess_Quota_PCADGuiEvent); if UserQuotaReached_Message <> '' then begin Showmessage(UserQuotaReached_Message); end; end else Inc(GGuiEventCallCounter); end; // // GCanRefreshCad := False; if ((not GisKeyDown) and (not GisKeyPress) and (not GisMouseDown)) then begin if assigned(FRemFigures) and (FRemFigures.Count > 0) and (GTraceStatus = False) (*important!!!*) then begin aNeedEnd := False; if GisProgressCount = 0 then begin aNeedEnd := True; BeginProgress; end; try PCad.OnGUIEvent := nil; i := 0; CheckRemFigures; // Tolik 24/01/2019 -- while i < FRemFigures.Count do begin FWaitWork := True; //Application.ProcessMessages; //02.08.2013 DelFigure := FRemFigures[i]; IdxManualDel := FFiguresDelManual.Remove(DelFigure); IsManualDel := IdxManualDel <> -1; if DelFigure.ClassName = 'TOrthoLine' then begin for j := i to FRemFigures.count - 1 do begin RemFigure := TFigure(FRemFigures[j]); if Assigned(RemFigure) then begin if RemFigure.ClassName = 'TConnectorObject' then if TConnectorObject(RemFigure).ConnectorType = ct_Clear then begin if TConnectorObject(RemFigure).JoinedOrthoLinesList.IndexOf(TOrthoLine(DelFigure)) <> -1 then TConnectorObject(RemFigure).JoinedOrtholinesList.Remove(TOrthoLine(DelFigure)); if TConnectorObject(TOrthoLine(DelFigure).JoinConnector1) <> nil then if TConnectorObject(TOrthoLine(DelFigure).JoinConnector1).ID = TConnectorObject(RemFigure).ID then TConnectorObject(TOrthoLine(DelFigure).JoinConnector1) := nil; if TConnectorObject(TOrthoLine(DelFigure).JoinConnector2) <> nil then if TConnectorObject(TOrthoLine(DelFigure).JoinConnector2).ID = TConnectorObject(RemFigure).ID then TConnectorObject(TOrthoLine(DelFigure).JoinConnector2) := nil; end; end; end; end else if DelFigure.ClassName = 'TConnectorObject' then begin for j := i to FRemFigures.Count - 1 do begin RemFigure := TFigure(FRemFigures[j]); if TConnectorObject(DelFigure).ConnectorType = ct_Clear then begin if RemFigure.ClassName = 'TOrthoLine' then begin if TConnectorObject(delFigure).JoinedOrthoLinesList.IndexOf(TOrthoLine(RemFigure)) <> -1 then TConnectorObject(DelFigure).JoinedOrtholinesList.Remove(TOrthoLine(RemFigure)); if TConnectorObject(TOrthoLine(RemFigure).JoinConnector1).ID = DelFigure.Id then TConnectorObject(TOrthoLine(RemFigure).JoinConnector1) := Nil else if TConnectorObject(TOrthoLine(RemFigure).JoinConnector2).ID = DelFigure.Id then TConnectorObject(TOrthoLine(RemFigure).JoinConnector2) := Nil; end else if RemFigure.ClassName = 'TConnectorObject' then if TConnectorObject(RemFigure).ConnectorType = ct_Nb then begin TConnectorObject(DelFigure).JoinedConnectorsList.remove(TConnectorObject(RemFigure)); TConnectorObject(RemFigure).JoinedConnectorsList.remove(TConnectorObject(DelFigure)); end; end else if TConnectorObject(DelFigure).ConnectorType = ct_Nb then begin if RemFigure.ClassName = 'TConnectorObject' then begin if TConnectorObject(RemFigure).JoinedConnectorsList.IndexOf(TConnectorObject(DelFigure)) <> -1 then TConnectorObject(RemFigure).JoinedConnectorsList.Remove(TConnectorObject(DelFigure)); if TConnectorObject(DelFigure).JoinedcOnnectorsList.IndexOf(TConnectorObject(RemFigure)) <> -1 then TConnectorObject(delFigure).JoinedConnectorsList.Remove(TConnectorObject(RemFigure)); end; end; end; end; if Assigned(FRemFigures[i]) and (TFigure(FRemFigures[i]).ID <> -1) then begin try // удалить связи конекторов с удаленными ортолиниями if CheckFigureByClassName(TFigure(FRemFigures[i]), cTOrthoLine) then begin // Tolik // нахер это здесь не нужно, т.к. выполнится на удалении ортолинии Joined1 := TConnectorObject(TOrthoLine(FRemFigures[i]).JoinConnector1); Joined2 := TConnectorObject(TOrthoLine(FRemFigures[i]).JoinConnector2); try if (Joined1 <> nil) and (Joined1.RemJoined <> nil) then begin for j := 0 to Joined1.RemJoined.Count - 1 do begin RemJoinedFigure := TFigure(Joined1.RemJoined[j]); Joined1.JoinedOrtholinesList.Remove(RemJoinedFigure); end; end; except end; try if (Joined2 <> nil) and (Joined2.RemJoined <> nil) then begin for j := 0 to Joined2.RemJoined.Count - 1 do begin RemJoinedFigure := TFigure(Joined2.RemJoined[j]); Joined2.JoinedOrtholinesList.Remove(RemJoinedFigure); end; end; except end; end; {******************************************************************} if (F_NormBase <> nil) and (F_ProjMan <> nil) then begin // Ortholine & Connector if CheckFigureByClassName(TFigure(FRemFigures[i]), cTOrthoLine) or (CheckFigureByClassName(TFigure(FRemFigures[i]), cTConnectorObject) and (not TConnectorObject(TFigure(FRemFigures[i])).fisApproach)) then DeleteObjectFromPM(TFigure(FRemFigures[i]).ID, TFigure(FRemFigures[i]).Name, IsManualDel) // Cabinet else if CheckFigureByClassName(TFigure(FRemFigures[i]), cTCabinet) then DeleteRoomFromCADToPM(TCabinet(FRemFigures[i]).FSCSID) // CabinetExt else if CheckFigureByClassName(TFigure(FRemFigures[i]), cTCabinetExt) then DeleteRoomFromCADToPM(TCabinetExt(FRemFigures[i]).FSCSID) // House else if CheckFigureByClassName(TFigure(FRemFigures[i]), cTHouse) then DeleteObjectFromPM(THouse(FRemFigures[i]).ID, THouse(FRemFigures[i]).Name, IsManualDel) // Approach else if CheckFigureByClassName(TFigure(FRemFigures[i]), cTConnectorObject) and (TConnectorObject(TFigure(FRemFigures[i])).fisApproach) then DeleteComponInPM(FCADListID, TConnectorObject(FRemFigures[i]).FComponID); end; try if CheckFigureByClassName(TFigure(FRemFigures[i]), cTFigureGrpMod) or CheckFigureByClassName(TFigure(FRemFigures[i]), cTFigureGrpNotMod) then RemoveInFigureGrp(TFigureGrp(FRemFigures[i])) // запомнить присоединенные коннекторы чтобы удалить (с-п) // (они не выделяются потому и не удаляются вместе с группой) else if CheckFigureByClassName(TFigure(FRemFigures[i]), cTOrthoLine) then begin Joined1 := TConnectorObject(TOrthoLine(FRemFigures[i]).JoinConnector1); Joined2 := TConnectorObject(TOrthoLine(FRemFigures[i]).JoinConnector2); if Joined1 <> nil then // Tolik begin // объекта Joined1 может уже и не быть, а сюда попадаем простопо ссылке, JoinedOrtholinesList - уже тоже // может не быть, поэтому ставим проверку if Joined1.JoinedOrtholinesList <> nil then begin // if Joined1.JoinedOrtholinesList.Count = 0 then begin if not Joined1.FIsHouseJoined then begin if Joined1.FGroupObject <> nil then Joined1.FGroupObject.RemoveFromGrp(Joined1); Joined1.Delete(False, False); end; end // Tolik --10/01/2017 -- else Joined1.RemJoined.Remove(TOrthoLine(FRemFigures[i])); // end; end; // if Joined2 <> nil then //Tolik // то же самое, что и для Joined1 if Joined2.JoinedOrtholinesList <> nil then begin // Tolik -- 22/11/2016-- {if Joined2.JoinedOrtholinesList.Count = 0 then if not Joined2.FIsHouseJoined then Joined2.Delete(False, False);} // if Joined2.JoinedOrtholinesList.Count = 0 then begin if not Joined2.FIsHouseJoined then begin if Joined2.FGroupObject <> nil then Joined2.FGroupObject.RemoveFromGrp(Joined2); Joined2.Delete(False, False); end; end // Tolik --10/01/2017 -- else Joined2.RemJoined.Remove(TOrthoLine(FRemFigures[i])); // end; end; PCad.Figures.Remove(FRemFigures[i]); TFigure(FRemFigures[i]).Destroy; FRemFigures[i] := Nil; except end; except on E: Exception do addExceptionToLogEx('TF_CAD.PCadGUIEvent', E.Message); end; end; i := i + 1; end; finally FWaitWork := False; // *UNDO* FCanSaveForUndo := True; if aNeedEnd then EndProgress; if FRemFigures <> nil then FRemFigures.Clear; PCad.OnGUIEvent := PCadGUIEvent; // if aNeedEnd then RefreshCAD(PCad); end; if F_Navigator <> nil then RefreshCAD(F_Navigator.PCadNavigator); end; if assigned(FRemFigures) and (FRemFigures.Count = 0) and (GTraceStatus = False) (*important!!!*) and (FFiguresDelManual.Count <> 0) then FFiguresDelManual.Clear; // RefreshCAD_T(PCad, true); GisAction := false; end else GisAction := True; { else begin if (PCad.UpdateCount = 0) and (assigned(FRemFigures) and (FRemFigures.Count > 0) and (GTraceStatus = False)) (*important!!!*) then begin WasDel := false; for i := FRemFigures.Count - 1 downto 0 do begin if Assigned(FRemFigures[i]) and (TFigure(FRemFigures[i]).ID <> -1) then begin try if (CheckFigureByClassName(TFigure(FRemFigures[i]), cTFigureGrpMod)) or (CheckFigureByClassName(TFigure(FRemFigures[i]), cTFigureGrpNotMod)) then begin WasDel := True; break; end; except end; end; end; if WasDel then begin aNeedEnd := False; if PCad.UpdateCount = 0 then begin aNeedEnd := True; end; PCad.BeginUpdate; try //PCad.OnGUIEvent := nil; for i := FRemFigures.Count - 1 downto 0 do begin if Assigned(FRemFigures[i]) and (TFigure(FRemFigures[i]).ID <> -1) then begin try // удалить связи конекторов с удаленными ортолиниями try if (CheckFigureByClassName(TFigure(FRemFigures[i]), cTFigureGrpMod)) or (CheckFigureByClassName(TFigure(FRemFigures[i]), cTFigureGrpNotMod)) then begin FWaitWork := True; DelGrpFigure := TFigureGrpMod(FRemFigures[i]); FFiguresDelManual.Remove(DelGrpFigure); PCad.Figures.Remove(DelGrpFigure); FRemFigures.Delete(i); DelGrpFigure.Free; DelGrpFigure := nil; end; except end; except on E: Exception do addExceptionToLogEx('TF_CAD.PCadGUIEvent', E.Message); end; end; end; finally FWaitWork := False; // *UNDO* //FCanSaveForUndo := True; FCanSaveForUndo := True; PCad.EndUpdate(false); //PCad.OnGUIEvent := PCadGUIEvent; if aNeedEnd and WasDel then RefreshCAD(PCad); end; if aNeedEnd and WasDel then if F_Navigator <> nil then RefreshCAD(F_Navigator.PCadNavigator); end; end; end; } // Tolik 10/01/2017 { GCanRefreshCad := True; RefreshCAD(PCad); if F_Navigator <> nil then RefreshCAD(F_Navigator.PCadNavigator);} // GisEventWaiting := False; end; except GisAction := False; end; InGUIEvent := False; end else begin if EventId = 95 then GisEventWaiting := True; end; end; (* procedure TF_CAD.PCadGUIEvent(Sender: TObject; EventId, Numval: Integer; StrVal: String; DblVal: Double; CEnable: Boolean); var i, j: integer; RemJoinedFigure: TFigure; Joined1: TConnectorObject; Joined2: TConnectorObject; DelFigure: TFigure; IdxManualDel: Integer; //02.08.2013 IsManualDel: Boolean; aNeedEnd: boolean; //Tolik DelIndex: Integer; aNeedRefresh: Boolean; CanDelFigures: Boolean; DelGrpFigure: TFigureGrpMod; // begin if EventId = 95 then begin //Tolik 23/10/2015 // разрешить событие Када, если нет текущей обработки нажатия клавиш или мышки, // чтобы не перекрывались события if ((not GisKeyDown) and (not GisKeyPress) and (not GisMouseDown)) then begin aNeedRefresh := False; // if assigned(FRemFigures) and (FRemFigures.Count > 0) and (GTraceStatus = False) {important!!!} then begin aNeedEnd := False; if GisProgressCount = 0 then begin aNeedEnd := True; BeginProgress; end; try PCad.OnGUIEvent := nil; i := 0; while i < FRemFigures.Count do begin FWaitWork := True; //Application.ProcessMessages; //02.08.2013 DelFigure := FRemFigures[i]; IdxManualDel := FFiguresDelManual.Remove(DelFigure); IsManualDel := IdxManualDel <> -1; if Assigned(FRemFigures[i]) and (TFigure(FRemFigures[i]).ID <> -1) then begin try // удалить связи конекторов с удаленными ортолиниями if CheckFigureByClassName(TFigure(FRemFigures[i]), cTOrthoLine) then begin Joined1 := TConnectorObject(TOrthoLine(FRemFigures[i]).JoinConnector1); Joined2 := TConnectorObject(TOrthoLine(FRemFigures[i]).JoinConnector2); try if (Joined1 <> nil) and (Joined1.RemJoined <> nil) then begin for j := 0 to Joined1.RemJoined.Count - 1 do begin RemJoinedFigure := TFigure(Joined1.RemJoined[j]); Joined1.JoinedOrtholinesList.Remove(RemJoinedFigure); end; end; except end; try if (Joined2 <> nil) and (Joined2.RemJoined <> nil) then begin for j := 0 to Joined2.RemJoined.Count - 1 do begin RemJoinedFigure := TFigure(Joined2.RemJoined[j]); Joined2.JoinedOrtholinesList.Remove(RemJoinedFigure); end; end; except end; end; {******************************************************************} if (F_NormBase <> nil) and (F_ProjMan <> nil) then begin // Ortholine & Connector if CheckFigureByClassName(TFigure(FRemFigures[i]), cTOrthoLine) or (CheckFigureByClassName(TFigure(FRemFigures[i]), cTConnectorObject) and (not TConnectorObject(TFigure(FRemFigures[i])).fisApproach)) then DeleteObjectFromPM(TFigure(FRemFigures[i]).ID, TFigure(FRemFigures[i]).Name, IsManualDel) // Cabinet else if CheckFigureByClassName(TFigure(FRemFigures[i]), cTCabinet) then DeleteRoomFromCADToPM(TCabinet(FRemFigures[i]).FSCSID) // CabinetExt else if CheckFigureByClassName(TFigure(FRemFigures[i]), cTCabinetExt) then DeleteRoomFromCADToPM(TCabinetExt(FRemFigures[i]).FSCSID) // House else if CheckFigureByClassName(TFigure(FRemFigures[i]), cTHouse) then DeleteObjectFromPM(THouse(FRemFigures[i]).ID, THouse(FRemFigures[i]).Name, IsManualDel) // Approach else if CheckFigureByClassName(TFigure(FRemFigures[i]), cTConnectorObject) and (TConnectorObject(TFigure(FRemFigures[i])).fisApproach) then DeleteComponInPM(FCADListID, TConnectorObject(FRemFigures[i]).FComponID); end; try if CheckFigureByClassName(TFigure(FRemFigures[i]), cTFigureGrpMod) or CheckFigureByClassName(TFigure(FRemFigures[i]), cTFigureGrpNotMod) then RemoveInFigureGrp(TFigureGrp(FRemFigures[i])) // запомнить присоединенные коннекторы чтобы удалить (с-п) // (они не выделяются потому и не удаляются вместе с группой) else if CheckFigureByClassName(TFigure(FRemFigures[i]), cTOrthoLine) then begin Joined1 := TConnectorObject(TOrthoLine(FRemFigures[i]).JoinConnector1); Joined2 := TConnectorObject(TOrthoLine(FRemFigures[i]).JoinConnector2); if Joined1 <> nil then // Tolik begin // объекта Joined1 может уже и не быть, а сюда попадаем простопо ссылке, JoinedOrtholinesList - уже тоже // может не быть, поэтому ставим проверку if Joined1.JoinedOrtholinesList <> nil then begin // if Joined1.JoinedOrtholinesList.Count = 0 then if not Joined1.FIsHouseJoined then Joined1.Delete(False, False); end; end; // if Joined2 <> nil then //Tolik // то же самое, что и для Joined1 if Joined2.JoinedOrtholinesList <> nil then begin // if Joined2.JoinedOrtholinesList.Count = 0 then if not Joined2.FIsHouseJoined then Joined2.Delete(False, False); end; end; PCad.Figures.Remove(FRemFigures[i]); TFigure(FRemFigures[i]).Destroy; FRemFigures[i] := Nil; except end; except on E: Exception do addExceptionToLogEx('TF_CAD.PCadGUIEvent', E.Message); end; end; i := i + 1; end; finally FWaitWork := False; // *UNDO* FCanSaveForUndo := True; if aNeedEnd then EndProgress; if FRemFigures <> nil then FRemFigures.Clear; PCad.OnGUIEvent := PCadGUIEvent; if aNeedEnd then RefreshCAD(PCad); end; if F_Navigator <> nil then RefreshCAD(F_Navigator.PCadNavigator); end; if assigned(FRemFigures) and (FRemFigures.Count = 0) and (GTraceStatus = False) {important!!!} and (FFiguresDelManual.Count <> 0) then FFiguresDelManual.Clear; end // если нажата клавиша, удаляем только фигуры отрисовки (ищем TFigureGRPMod) else begin aNeedRefresh := False; // if assigned(FRemFigures) and (FRemFigures.Count > 0) and (GTraceStatus = False) {important!!!} then begin aNeedEnd := False; if GisProgressCount = 0 then begin aNeedEnd := True; BeginProgress; end; try // PCad.OnGUIEvent := nil; i := 0; CanDelFigures := True; while CanDelFigures do begin CanDelFigures := False; for i := 0 to FRemFigures.Count - 1 do begin FWaitWork := True; //Application.ProcessMessages; //02.08.2013 { DelFigure := FRemFigures[i]; IdxManualDel := FFiguresDelManual.Remove(DelFigure); IsManualDel := IdxManualDel <> -1;} if Assigned(FRemFigures[i]) and (TFigure(FRemFigures[i]).ID <> -1) then begin try try if CheckFigureByClassName(TFigure(FRemFigures[i]), cTFigureGrpMod) then begin DelGrpFigure := TFigureGrpMod(FRemFigures[i]); FRemFigures.Remove(DelGrpFigure); PCad.Figures.Remove(DelGrpFigure); FFiguresDelManual.Remove(DelGrpFigure); //DelGrpFigure.Destroy; if DelGrpFigure <> nil then FreeAndNil(DelGrpFigure); if FRemFigures.Count > 0 then CanDelFigures := True; break; end; except on E: Exception do addExceptionToLogEx('TF_CAD.PCadGUIEvent', E.Message); end; except on E: Exception do addExceptionToLogEx('TF_CAD.PCadGUIEvent', E.Message); end; end; end; end; finally FWaitWork := False; // *UNDO* FCanSaveForUndo := True; if aNeedEnd then EndProgress; // PCad.OnGUIEvent := PCadGUIEvent; if aNeedEnd then RefreshCAD(PCad); end; if F_Navigator <> nil then RefreshCAD(F_Navigator.PCadNavigator); end; end; end; end; *) procedure TF_CAD.FullEndUpdateCad(aNeedRefresh: Boolean = False); begin if (Not GIsProgress) then begin if PCad.UpdateCount > 0 then begin PCad.EnableAlign; while PCad.UpdateCount > 0 do begin PCad.EndUpdate(False); mProtocol.Lines.EndUpdate; end; end; mProtocol.Properties.LockUPdate(false); while mProtocol.Properties.ChangedLocked do mProtocol.Properties.EndUpdate; if aNeedRefresh then begin GCanRefreshCad:= True; PCad.Refresh; end; end; end; // Tolik -- возвертаю скролл када вправо-влево при отрисовке трассы // (по просьбе трудящихся), поэтому как было -- закомментил и поправил немножко совсем, // чтобы при включенной тулзе создания трассы не сработало масштабирование КАДа по клавише CTRL (* procedure TF_CAD.FormMouseWheelUp(Sender: TObject; Shift: TShiftState; MousePos: TPoint; var Handled: Boolean); var X, Y: Integer; ShiftState: TShiftState; KeyState: TKeyboardState; begin try //FullEndUpdateCad; сделаем пока только по изм.масштаба скролом Handled := True; if PCad.ToolIdx = TPCTool(toFigure) then exit; PCad.AutoRefresh := False; // Масштаб //if ssCtrl in Shift then //GetKeyboardState(KeyState); //ShiftState := KeyboardStateToShiftState(KeyState); //if (ShiftState = [ssCtrl]) then if ssCtrl in Shift then begin FullEndUpdateCad; FSCS_Main.aInc1pt.Execute; //Tolik -- 12/04/2016 //ShowMessage('MouseWheel + Ctrl'); end else // Scrolls (Horiz) if (ssShift in Shift) and not (ssCtrl in Shift) then begin X := PCad.HSCBarPosition; PCad.SetHScrollPosition(X - 10, True); end else // Scrolls (Vert) if Shift = [] then begin Y := PCad.VSCBarPosition; PCad.SetVScrollPosition(Y - 10, True); end; // скролл Set_SCS_HorScroll; Set_SCS_VerScroll; PCad.AutoRefresh := True; RefreshCAD_T(PCad); except on E: Exception do addExceptionToLogEx('TF_CAD.FormMouseWheelUp', E.Message); end; end; procedure TF_CAD.FormMouseWheelDown(Sender: TObject; Shift: TShiftState; MousePos: TPoint; var Handled: Boolean); var X, Y: Integer; ShiftState: TShiftState; KeyState: TKeyboardState; begin try Handled := True; if PCad.ToolIdx = TPCTool(toFigure) then exit; PCad.AutoRefresh := False; // Масштаб //if ssCtrl in Shift then //GetKeyboardState(KeyState); //ShiftState := KeyboardStateToShiftState(KeyState); //if (ShiftState = [ssCtrl]) then if ssCtrl in Shift then begin FullEndUpdateCad; FSCS_Main.aDec1pt.Execute; // Tolik 12/04/2016 -- //ShowMessage('MouseWhee + Ctrl'); end else // Scrolls (Horiz) if (ssShift in Shift) and not (ssCtrl in Shift) then begin X := PCad.HSCBarPosition; PCad.SetHScrollPosition(X + 10, True); end else // Scrolls (Vert) if Shift = [] then begin Y := PCad.VSCBarPosition; PCad.SetVScrollPosition(Y + 10, True); end; // сколл Set_SCS_HorScroll; Set_SCS_VerScroll; PCad.AutoRefresh := True; RefreshCAD_T(PCad); except on E: Exception do addExceptionToLogEx('TF_CAD.FormMouseWheelDown', E.Message); end; end; *) procedure TF_CAD.FormMouseWheelUp(Sender: TObject; Shift: TShiftState; MousePos: TPoint; var Handled: Boolean); var X, Y: Integer; ShiftState: TShiftState; KeyState: TKeyboardState; begin try //FullEndUpdateCad; сделаем пока только по изм.масштаба скролом Handled := True; // TODO - зум по контролу перепроверить см. код выше {if PCad.ToolIdx = TPCTool(toFigure) then exit;} PCad.AutoRefresh := False; // Масштаб //if ssCtrl in Shift then //GetKeyboardState(KeyState); //ShiftState := KeyboardStateToShiftState(KeyState); //if (ShiftState = [ssCtrl]) then //Tolik 10/08/2021 -- //if ((ssCtrl in Shift) and (PCad.ToolIdx <> TPCTool(toFigure))) then if (ssCtrl in Shift) then // begin FullEndUpdateCad; FSCS_Main.aInc1pt.Execute; //Tolik -- 12/04/2016 //ShowMessage('MouseWheel + Ctrl'); end else // Scrolls (Horiz) if (ssShift in Shift) and not (ssCtrl in Shift) then begin X := PCad.HSCBarPosition; PCad.SetHScrollPosition(X - 10, True); end else // Scrolls (Vert) if Shift = [] then begin Y := PCad.VSCBarPosition; PCad.SetVScrollPosition(Y - 10, True); end; // скролл Set_SCS_HorScroll; Set_SCS_VerScroll; PCad.AutoRefresh := True; RefreshCAD_T(PCad); except on E: Exception do addExceptionToLogEx('TF_CAD.FormMouseWheelUp', E.Message); end; end; procedure TF_CAD.FormMouseWheelDown(Sender: TObject; Shift: TShiftState; MousePos: TPoint; var Handled: Boolean); var X, Y: Integer; ShiftState: TShiftState; KeyState: TKeyboardState; begin try //Tolik 08/11/2017 -- if not GCanRefreshCad then exit; // Handled := True; // TODO - зум по контролу перепроверить см. код выше {if PCad.ToolIdx = TPCTool(toFigure) then exit;} PCad.AutoRefresh := False; // Масштаб //if ssCtrl in Shift then //GetKeyboardState(KeyState); //ShiftState := KeyboardStateToShiftState(KeyState); //if (ShiftState = [ssCtrl]) then //Tolik 10/08/2021 -- //if ((ssCtrl in Shift) and (PCad.ToolIdx <> TPCTool(toFigure))) then if (ssCtrl in Shift) then // begin FullEndUpdateCad; FSCS_Main.aDec1pt.Execute; // Tolik 12/04/2016 -- //ShowMessage('MouseWhee + Ctrl'); end else // Scrolls (Horiz) if (ssShift in Shift) and not (ssCtrl in Shift) then begin X := PCad.HSCBarPosition; PCad.SetHScrollPosition(X + 10, True); end else // Scrolls (Vert) if Shift = [] then begin Y := PCad.VSCBarPosition; PCad.SetVScrollPosition(Y + 10, True); end; // сколл Set_SCS_HorScroll; Set_SCS_VerScroll; PCad.AutoRefresh := True; //Tolik -- 08/11/2017 -- //FSCS_Main.TimerRefresh.Interval := 200; FSCS_Main.TimerRefresh.Interval := 100; // RefreshCAD_T(PCad); except on E: Exception do addExceptionToLogEx('TF_CAD.FormMouseWheelDown', E.Message); end; end; // procedure TF_CAD.FormResize(Sender: TObject); begin //26.12.2011 try ChangeScrollsOnChangeListSize; //26.12.2011 except //26.12.2011 on E: Exception do addExceptionToLogEx('TF_CAD.FormResize', E.Message); //26.12.2011 end; end; procedure TF_CAD.FormShow(Sender: TObject); begin ShowHideButtons; end; procedure TF_CAD.PCadSelectionChange(Sender: TObject); var i: integer; LineLen : double; CurFigure: TFigure; CheckUnselectFigure: TFigure; LastFigure: TFigure; FigureHeightStr: String; CurrParams : TProjectParams; //Tolik PointSelectedCount: Integer; LineSelectedCount: Integer; CanShow_Act_Magistral_Channel_Index: Boolean; begin try //Tolik FSCS_Main.Act_ConnectSelectedPoints.Visible := false; FSCS_Main.Act_ReindexMaster.Visible := false; // 02/11/2016-- FSCS_Main.Act_AlignSelection.Visible := False; // FSCS_Main.Act_Magistral_Channel_Index.Visible := False; CanShow_Act_Magistral_Channel_Index := true; // // убрать выделения с посторонних объектов if not assigned(PCad) then exit; PCad.AutoRefresh := False; UnSelectFiguresOnSelectedChange(PCad.Selection); PCad.AutoRefresh := True; if PCad.SelectedCount > 0 then begin // LastFigure := TFigure(PCad.Selection[PCad.Selection.Count - 1]); LastFigure := GetLastSelectedSCSObject; if not CheckFigureByClassName(LastFigure, cTFigureGrpMod) and not CheckFigureByClassName(LastFigure, cTFigureGrpNotMod) then begin //08.08.2012 sbView.Panels[1].Text := ''; //08.08.2012 sbView.Panels[2].Text := ''; end; // Выводить имя обьекта! if CheckFigureByClassName(LastFigure, cTConnectorObject) or CheckFigureByClassName(LastFigure, cTOrthoLine) or (LastFigure is TNet) then begin sbView.Panels[2].Text := ''; FigureHeightStr := ''; if CheckFigureByClassName(LastFigure, cTOrthoLine) then begin if TOrthoLine(LastFigure).ActualZOrder[1] = TOrthoLine(LastFigure).ActualZOrder[2] then FigureHeightStr := '(' + FormatFloat(ffMask, MetreToUOM(TOrthoLine(LastFigure).ActualZOrder[1])) + ')' else FigureHeightStr := '(' + FormatFloat(ffMask, MetreToUOM(TOrthoLine(LastFigure).ActualZOrder[1])) + '-' + FormatFloat(ffMask, MetreToUOM(TOrthoLine(LastFigure).ActualZOrder[2])) + ')'; end else if CheckFigureByClassName(LastFigure, cTConnectorObject) then begin FigureHeightStr := '(' + FormatFloat(ffMask, MetreToUOM(TConnectorObject(LastFigure).ActualZOrder[1])) + ')'; end; if FigureHeightStr <> '' then FigureHeightStr := ' '+ FigureHeightStr; sbView.Panels[2].Text := GetFullFigureName(LastFigure) + FigureHeightStr; if LastFigure is TNet then sbView.Panels[1].Text := GetFullFigureLenName(LastFigure); end; end else begin LastFigure := nil; // Tolik -- 21/03/2017 -*- сбросить выделение в ПМ, если ничего не выбрано // F_ProjMan.Tree_Catalog.ClearSelection; end; if GCanRefreshProperties then begin // при открытом окне свойств заполнить их if FSCS_Main.aViewSCSObjectsProp.Checked then begin if PCad.SelectedCount > 0 then begin GPropertiesObject := LastFigure; if GPropertiesObject <> nil then begin if CheckFigureByClassName(GPropertiesObject, cTConnectorObject) then begin if not TConnectorObject(GPropertiesObject).FIsApproach then F_SCSObjectsProp.Execute(GPropertiesObject); end else F_SCSObjectsProp.Execute(GPropertiesObject); end else begin F_SCSObjectsProp.Height := F_SCSObjectsProp.FNormalModeSize + 10; F_SCSObjectsProp.ClearAllProperties; end; end else begin GPropertiesObject := nil; F_SCSObjectsProp.Height := F_SCSObjectsProp.FNormalModeSize + 10; F_SCSObjectsProp.gbTypes.Visible := False; F_SCSObjectsProp.ClearAllProperties; end; end; end; // //Added by Tolik // пересчет длин выбранных трасс сработает, если не выбран // путь до конечного объекта // if not GCadForm.FDeselectUpDown then if GCadForm <> nil then begin if not GCadForm.FDeselectUpDown then begin if PCad.SelectedCount > 1 then begin sbView.Panels[1].Text := ''; LineLen := 0; for i := 0 to PCad.SelectedCount - 1 do begin if CheckFigureByClassName(TFigure(PCad.Selection[i]), cTOrthoLine) then LineLen := LineLen + TOrthoLine(PCad.Selection[i]).LineLength; end; if LineLen > 0 then sbView.Panels[1].Text := cCad_Mes14_1 + FormatFloat(ffMask, MetreToUOM(LineLen)) + GetUOMString(GCurrProjUnitOfMeasure); end; end; end; if PCad.ActiveLayer in [lnSubstrate, lnSCSCommon, lnArch] then //30.05.2011 if PCad.ActiveLayer = 2 then begin if FSCS_Main.tbCADToolsExpert.Visible then begin FSCS_Main.tbBlkUpExpert.Enabled := True; FSCS_Main.tbBlkDownExpert.Enabled := True; FSCS_Main.tbBlkLeftExpert.Enabled := True; FSCS_Main.tbBlkRightExpert.Enabled := True; end else begin FSCS_Main.tbBlkUpNoob.Enabled := True; FSCS_Main.tbBlkDownNoob.Enabled := True; FSCS_Main.tbBlkLeftNoob.Enabled := True; FSCS_Main.tbBlkRightNoob.Enabled := True; end; end else begin if FSCS_Main.tbCADToolsExpert.Visible then begin FSCS_Main.tbBlkUpExpert.Enabled := False; FSCS_Main.tbBlkDownExpert.Enabled := False; FSCS_Main.tbBlkLeftExpert.Enabled := False; FSCS_Main.tbBlkRightExpert.Enabled := False; end else begin FSCS_Main.tbBlkUpNoob.Enabled := False; FSCS_Main.tbBlkDownNoob.Enabled := False; FSCS_Main.tbBlkLeftNoob.Enabled := False; FSCS_Main.tbBlkRightNoob.Enabled := False; end; end; PointSelectedCount := 0; LineSelectedCount := 0; if PCad.Selection.Count > 0 then begin for i := 0 to PCad.Selection.Count - 1 do begin if CheckFigureByClassName(PCad.Selection[i], cTConnectorObject) then INC(PointSelectedCount); if CheckFigureByClassName(PCad.Selection[i], cTOrthoLine) then INC(LineSelectedCount); end; end; if PointSelectedCount > 1 then begin FSCS_Main.Act_ConnectSelectedPoints.Visible := true; // Tolik 02/11/2016 -- FSCS_Main.Act_AlignSelection.Visible := True; end; if (LineSelectedCount + PointSelectedCount) > 1 then begin {if F_ProjMan.GSCSBase.CurrProject.CurrList.Setting.GroupListObjectsByType = False then} FSCS_Main.Act_ReindexMaster.Visible := true; end; // если нажата правая клавиша мыши на спуске/подъеме, не показывать меню индекса магистрального маршрута, // если С/П присоединен к точечному объекту if ((LineSelectedCount = 1) and (PointSelectedCount = 0)) then begin curFigure := TFigure(PCad.Selection[0]); if TOrthoLine(curFigure).FIsRaiseUpDown then begin if TConnectorObject(TOrthoLine(curFigure).JoinConnector1) <> nil then begin for i := 0 to TConnectorObject(TOrthoLine(curFigure).JoinConnector1).JoinedConnectorsList.Count - 1 do begin if TConnectorObject(TConnectorObject(TOrthoLine(curFigure).JoinConnector1).JoinedConnectorsList[i]).ConnectorType = ct_NB then begin CanShow_Act_Magistral_Channel_Index := False; break; end; end; end; if CanShow_Act_Magistral_Channel_Index then begin if TConnectorObject(TOrthoLine(curFigure).JoinConnector1) <> nil then begin for i := 0 to TConnectorObject(TOrthoLine(curFigure).JoinConnector2).JoinedConnectorsList.Count - 1 do begin if TConnectorObject(TConnectorObject(TOrthoLine(curFigure).JoinConnector2).JoinedConnectorsList[i]).ConnectorType = ct_NB then begin CanShow_Act_Magistral_Channel_Index := False; break; end; end; end; end; end; end else CanShow_Act_Magistral_Channel_Index := False; if CanShow_Act_Magistral_Channel_Index then FSCS_Main.Act_Magistral_Channel_Index.Visible := True; except on E: Exception do addExceptionToLogEx('TF_CAD.PCadSelectionChange', E.Message); end; end; procedure TF_CAD.PCadScaleChanged(Sender: TObject); var NewScrollPosX: Double; NewScrollPosY: Double; SetScrollPosX: Integer; SetScrollPosY: Integer; NewZoomScale: Integer; CalcedZoomKoef: Double; CalcedZoomDelta: Double; Koefs: TDoublePoint; begin try // Гориз. скролл есть NewZoomScale := PCad.ZoomScale; CalcedZoomKoef := (GSavedZoomScale / NewZoomScale); CalcedZoomDelta := (NewZoomScale - GSavedZoomScale); Koefs := GetScaleKoefs; if IfVisibleHorScrollBar then begin // CORRECT!!! if PCad.SelectedCount = 0 then begin if (GSavedScrollPosX <> -1) then begin SetScrollPosX := Round(GSavedScrollPosX / CalcedZoomKoef + Koefs.x / GSavedZoomScale * CalcedZoomDelta); PCad.SetHScrollPosition(SetScrollPosX, PCad.AutoRefresh); end; end; HorScroll.Visible := True; Set_SCS_HorScroll; end else HorScroll.Visible := False; // Вертик. скролл есть if ifVisibleVerScrollBar then begin if PCad.SelectedCount = 0 then begin if (GSavedScrollPosY <> -1) then begin SetScrollPosY := Round(GSavedScrollPosY / CalcedZoomKoef + Koefs.y / GSavedZoomScale * CalcedZoomDelta); PCad.SetVScrollPosition(SetScrollPosY, PCad.AutoRefresh); end; end; VerScroll.Visible := True; Set_SCS_VerScroll; end else VerScroll.Visible := False; HorScroll.Anchors := [akLeft,akBottom]; // отвязать от привязки и алигина на правый край VerScroll.Anchors := [akRight,akTop]; // отвязать от привязки и алигина на правый край // подредактировать скролбары // только гориз. if IfVisibleHorScrollBar and not ifVisibleVerScrollBar then begin HorScroll.Constraints.MaxWidth := PCad.Width - 15 - 7; if HorScroll.Width <> (PCad.Width - 7) then HorScroll.Width := PCad.Width - 7; end; // только вертик. if not IfVisibleHorScrollBar and ifVisibleVerScrollBar then begin VerScroll.Constraints.MaxHeight := PCad.Height - 15 - 7; if VerScroll.Height <> (PCad.Height - 7) then VerScroll.Height := PCad.Height - 7; end; // оба if IfVisibleHorScrollBar and ifVisibleVerScrollBar then begin HorScroll.Constraints.MaxWidth := PCad.Width - 15 - 7; VerScroll.Constraints.MaxHeight := PCad.Height - 15 - 7; if HorScroll.Width <> (PCad.Width - 15 - 7) then HorScroll.Width := PCad.Width - 15 - 7; if VerScroll.Height <> (PCad.Height - 15 - 7) then VerScroll.Height := PCad.Height - 15 - 7; end; if FSCS_Main.tbCADToolsExpert.Visible then FSCS_Main.cbScaleExpert.Text := IntToStr(PCad.ZoomScale) + '%' else FSCS_Main.cbScaleNoob.Text := IntToStr(PCad.ZoomScale) + '%' except on E: Exception do addExceptionToLogEx('TF_CAD.PCadScaleChanged', E.Message); end; end; function TF_CAD.IfVisibleHorScrollBar: Boolean; var Client_Width: Integer; Page: TRect; begin Result := False; try Client_Width := PCad.ClientWidth; Page := PCad.GetPageRect; if (Page.Left < 0) or (Page.Right > Client_Width) then Result := True else Result := False; except on E: Exception do addExceptionToLogEx('TF_CAD.IfVisibleHorScrollBar', E.Message); end; end; function TF_CAD.IfVisibleVerScrollBar: Boolean; var Client_Height: Integer; Page: TRect; begin Result := False; try Client_Height := PCad.ClientHeight; Page := PCad.GetPageRect; if (Page.Top < 0) or (Page.Bottom > Client_Height) then Result := True else Result := False; except on E: Exception do addExceptionToLogEx('TF_CAD.IfVisibleVerScrollBar', E.Message); end; end; procedure TF_CAD.HorScrollScroll(Sender: TObject; ScrollCode: TScrollCode; var ScrollPos: Integer); begin try FullEndUpdateCad; if ScrollCode = scEndScroll then Set_PCad_HorScroll; PCad.SetFocus; except on E: Exception do addExceptionToLogEx('TF_CAD.HorScrollScroll', E.Message); end; end; procedure TF_CAD.VerScrollScroll(Sender: TObject; ScrollCode: TScrollCode; var ScrollPos: Integer); begin try FullEndUpdateCad; if ScrollCode = scEndScroll then Set_PCad_VerScroll; PCad.SetFocus; except on E: Exception do addExceptionToLogEx('TF_CAD.VerScrollScroll', E.Message); end; end; function TF_CAD.GetMaxScrollsPosition: TPoint; var Page: TRect; PageX, PageY: Integer; ClientX, ClientY: Integer; begin try Result := Point(0, 0); Page := PCad.GetPageRect; PageX := abs(Page.Right - Page.Left); PageY := abs(Page.Bottom - page.Top); ClientX := PCad.ClientWidth; ClientY := PCad.ClientHeight; Result.x := PageX - ClientX + 59; Result.y := PageY - ClientY + 59; except on E: Exception do addExceptionToLogEx('TF_CAD.GetMaxScrollsPosition', E.Message); end; end; function TF_CAD.GetPageSizesScrolls: TPoint; var Page: TRect; PageX, PageY: Integer; ClientX, ClientY: Integer; begin try Result := Point(0, 0); Page := PCad.GetPageRect; PageX := abs(Page.Right - Page.Left); PageY := abs(Page.Bottom - page.Top); ClientX := PCad.ClientWidth; ClientY := PCad.ClientHeight; Result.x := Round(ClientX / PageX * 100); Result.y := Round(ClientY / PageY * 100); except on E: Exception do addExceptionToLogEx('TF_CAD.GetPageSizesScrolls', E.Message); end; end; procedure TF_CAD.Set_PCad_HorScroll; var Koef_ScrollPos_X: Double; MaxCADScroll_X: Integer; SetScrollPos_X: Integer; begin try // позиция CAD MaxCADScroll_X := GetMaxScrollsPosition.X; // Sets if (HorScroll.Max - HorScroll.PageSize) > 0 then begin Koef_ScrollPos_X := HorScroll.Position / (HorScroll.Max - HorScroll.PageSize); SetScrollPos_X := round(MaxCADScroll_X * Koef_ScrollPos_X); PCad.SetHScrollPosition(SetScrollPos_X, True); //PCad.SetHScrollPosition(SetScrollPos_X, False); //PCad.SurfacePaint; //Tolik 02/02/2022 -- //FCurrPCadScrollX := SetScrollPos_X; end; except on E: Exception do addExceptionToLogEx('TF_CAD.Set_PCad_HorScroll', E.Message); end; end; procedure TF_CAD.Set_PCad_VerScroll; var Koef_ScrollPos_Y: Double; MaxCADScroll_Y: Integer; SetScrollPos_Y: Integer; begin try // позиция CAD MaxCADScroll_Y := GetMaxScrollsPosition.Y; // Sets if (VerScroll.Max - VerScroll.PageSize) > 0 then begin Koef_ScrollPos_Y := VerScroll.Position / (VerScroll.Max - VerScroll.PageSize); SetScrollPos_Y := round(MaxCADScroll_Y * Koef_ScrollPos_Y); PCad.SetVScrollPosition(SetScrollPos_Y, True); //PCad.SetVScrollPosition(SetScrollPos_Y, false); //PCad.SurfacePaint; //Tolik 02/02/2022 -- //FCurrPCadScrollY := SetScrollPos_Y; end; except on E: Exception do addExceptionToLogEx('TF_CAD.Set_PCad_VerScroll', E.Message); end; end; procedure TF_CAD.Set_SCS_HorScroll; var MaxCADScroll_X: Integer; CurScrollPos_X: Integer; begin try // позиция CAD CurScrollPos_X := PCad.HSCBarPosition; MaxCADScroll_X := GetMaxScrollsPosition.X; // Sets HorScroll.PageSize := GetPageSizesScrolls.X; if MaxCADScroll_X > 0 then begin HorScroll.Position := round(CurScrollPos_X / MaxCADScroll_X * (HorScroll.Max - HorScroll.PageSize + 1)); try if Self.Visible then PCad.SetFocus; except end; { PCad.Refresh; if (CheckFigureByClassName(PCad.TraceFigure, 'TOrthoLine')) then PCad.TraceFigure.NotNeedToDraw := True; PCad._DrawTrace; //для отрисовки новой trace shadow if (CheckFigureByClassName(PCad.TraceFigure, 'TOrthoLine')) then PCad.TraceFigure.NotNeedToDraw := false; } end; except on E: Exception do addExceptionToLogEx('TF_CAD.Set_SCS_HorScroll', E.Message); end; end; procedure TF_CAD.Set_SCS_VerScroll; var MaxCADScroll_Y: Integer; CurScrollPos_Y: Integer; begin try // позиция CAD CurScrollPos_Y := PCad.VSCBarPosition; MaxCADScroll_Y := GetMaxScrollsPosition.Y; // Sets pos VerScroll.PageSize := GetPageSizesScrolls.Y; if MaxCADScroll_Y > 0 then begin VerScroll.Position := round(CurScrollPos_Y / MaxCADScroll_Y * (VerScroll.Max - VerScroll.PageSize + 1)); try if self.Visible then PCad.SetFocus; except end; { PCad.Refresh; if (CheckFigureByClassName(PCad.TraceFigure, 'TOrthoLine')) then PCad.TraceFigure.NotNeedToDraw := True; PCad._DrawTrace; //для отрисовки новой trace shadow if (CheckFigureByClassName(PCad.TraceFigure, 'TOrthoLine')) then PCad.TraceFigure.NotNeedToDraw := false; } end; except on E: Exception do addExceptionToLogEx('TF_CAD.Set_SCS_VerScroll', E.Message); end; end; // Tolik 05/05/2021 -- Procedure TF_Cad.tbView_NewProc(var message: TMessage); var CControl: TControl; begin case message.Msg of WM_LBUTTONDOWN, WM_LBUTTONDBLCLK: begin CControl := tbView.ControlAtPos(SmallPointToPoint(TWMMouse(Message).Pos), False); if Assigned(CControl) then if CControl is TToolButton then CheckCloseReportForm; end; end; tbView_OldProc(Message); end; // procedure TF_CAD.SetCurrentLayer(ALNbr: Integer); var OldActLayer: integer; LayerName: string; PrjCaption: string; ListCaption: string; Item: TListItem; Layer: TLayer; // Tolik 21/03/2018 -- Protocol_Message: String; // begin try OldActLayer := PCad.ActiveLayer; if OldActLayer <> ALNbr then//Tolik 20/09/2021 -- //Tolik 30/11/2021 - - // PCad.DeselectAll(OldActLayer); begin ClearTreeSelection; PCad.DeselectAll(OldActLayer); end; // PCad.ActiveLayer := ALNbr; if F_LayersDialog.Showing then begin F_LayersDialog.lbCurLayer.Caption := PCad.GetLayerName(ALNbr); Layer := PCad.GetLayer(ALNbr); Item := F_LayersDialog.FinditemByLayer(ALNbr, Layer); if Item <> nil then Item.Selected := true; end; LayerName := PCad.GetLayerName(PCad.ActiveLayer); try PrjCaption := GetCurrProjectParams.Caption; ListCaption := GetListParams(FCADListID).Caption; Caption := PrjCaption + ' - ' + ListCaption + cCad_Mes17 + LayerName; except Caption := ''; end; if OldActLayer <> ALNbr then begin // Tolik 21/03/2018 -- чтобы корректно отображалось на каде, а то иначе не видно... Protocol_Message := ''; if ALNbr = 0 then Protocol_Message := cCad_Mes18; if ALNbr = 1 then Protocol_Message := cCad_Mes19; if ALNbr = 2 then Protocol_Message := cCad_Mes20; if ALNbr = 3 then Protocol_Message := cCad_Mes21; if ALNbr = 4 then Protocol_Message := cCad_Mes22; if ALNbr = 5 then Protocol_Message := cCad_Mes23; if ALNbr = 6 then Protocol_Message := cCad_Mes24; if ALNbr = 7 then Protocol_Message := cCad_Mes25; if ALNbr = 8 then Protocol_Message := cCad_Mes26; if ALNbr = 9 then Protocol_Message := cCad_Mes30; if Protocol_Message <> '' then begin mProtocol.Lines.Add(Protocol_Message); end; {if ALNbr = 0 then mProtocol.Lines.Add(cCad_Mes18); if ALNbr = 1 then mProtocol.Lines.Add(cCad_Mes19); if ALNbr = 2 then mProtocol.Lines.Add(cCad_Mes20); if ALNbr = 3 then mProtocol.Lines.Add(cCad_Mes21); if ALNbr = 4 then mProtocol.Lines.Add(cCad_Mes22); if ALNbr = 5 then mProtocol.Lines.Add(cCad_Mes23); if ALNbr = 6 then mProtocol.Lines.Add(cCad_Mes24); if ALNbr = 7 then mProtocol.Lines.Add(cCad_Mes25); if ALNbr = 8 then mProtocol.Lines.Add(cCad_Mes26); if ALNbr = 9 then mProtocol.Lines.Add(cCad_Mes30); } // if (ALNbr >= 0) and (ALNbr <= 1) then begin FSCS_Main.UnRegisteredCADHotKeys; FSCS_Main.aSnaptoGrid.Enabled := True; FSCS_Main.aSnaptoGrid.Checked := LastSnapGridStatus; tbSnapGrid.Down := LastSnapGridStatus; PCad.SnapToGrids := LastSnapGridStatus; end; // SCS if (ALNbr >= 2) and (ALNbr <= 9) then begin FSCS_Main.RegisteredCADHotKeys; // FSCS_Main.aSnaptoGrid.Checked := True; // PCad.SnapToGrids := True; end; if (ALNbr = lnSCSCommon) or (ALNbr = lnSubstrate) or (ALNbr = lnArch) then begin FSCS_Main.aShiftUpObject.Enabled := True; FSCS_Main.aShiftDownObject.Enabled := True; FSCS_Main.aShiftLeftObject.Enabled := True; FSCS_Main.aShiftRightObject.Enabled := True; end else begin FSCS_Main.aShiftUpObject.Enabled := False; FSCS_Main.aShiftDownObject.Enabled := False; FSCS_Main.aShiftLeftObject.Enabled := False; FSCS_Main.aShiftRightObject.Enabled := False; end; if (ALNbr = 1) or (ALNbr = 7) or (ALNbr >= 10) then begin PCad.RecordUndo := True; PCad.UndoCount := 0; end else begin PCad.RecordUndo := False; PCad.UndoCount := 0; end; // if PCad.ToolIdx <> toSelect then begin RefreshCAD(PCad); PCad.SetTool(toSelect, 'TSelected'); // if FSCS_Main.tbCADToolsExpert.Visible then // FSCS_Main.tbSelectExpert.Down := True // else // FSCS_Main.tbSelectNoob.Down := True; FCreateObjectOnClick := False; RestoreCadGridStatus; // Tolik 04/03/2021 -- end; end; if ALNbr > 0 then FSCS_Main.cbLayers.ItemIndex := ALNbr - 1; FCurrentLayer := ALNbr; ShowHideButtons; // Tolik 27/01/2022 -- except on E: Exception do addExceptionToLogEx('TF_CAD.SetCurrentLayer', E.Message); end; end; procedure TF_CAD.FormDeactivate(Sender: TObject); begin try GGlobalShiftState := []; FCurrPCadScrollX := PCad.HSCBarPosition; FCurrPCadScrollY := PCad.VSCBarPosition; except on E: Exception do addExceptionToLogEx('TF_CAD.FormDeactivate', E.Message); end; end; procedure TF_CAD.ChangeScrollsOnChangeListSize; var PCadAutoRefresh: Boolean; begin if PCad.UpdateCount <> 0 then Exit; ///// EXIT ///// PCadAutoRefresh := PCad.AutoRefresh; //DisableAlign; //26.12.2011 try PCad.Color := PCad.PageColor; //07.08.2012 - чтобы при растягивании не появлялись внизу/справа серые поля PCad.DisableAlign; try PCad.AutoRefresh := False; PCad.SetHScrollPosition(FCurrPCadScrollX, False); PCad.SetVScrollPosition(FCurrPCadScrollY, False); HorScroll.Anchors := [akLeft,akBottom]; // отвязать от привязки и алигина на правый край VerScroll.Anchors := [akRight,akTop]; // отвязать от привязки и алигина на правый край // Гориз. скролл есть if IfVisibleHorScrollBar then begin HorScroll.Visible := True; Set_SCS_HorScroll; end else HorScroll.Visible := False; // Вертик. скролл есть if ifVisibleVerScrollBar then begin VerScroll.Visible := True; Set_SCS_VerScroll; end else VerScroll.Visible := False; // подредактировать скролбары // только гориз. if IfVisibleHorScrollBar and not ifVisibleVerScrollBar then begin HorScroll.Constraints.MaxWidth := PCad.Width - 15 - 7; if HorScroll.Width <> (PCad.Width - 7) then HorScroll.Width := PCad.Width - 7; end; // только вертик. if not IfVisibleHorScrollBar and ifVisibleVerScrollBar then begin VerScroll.Constraints.MaxHeight := PCad.Height - 15 - 7; if VerScroll.Height <> (PCad.Height - 7) then VerScroll.Height := PCad.Height - 7; end; // оба if IfVisibleHorScrollBar and ifVisibleVerScrollBar then begin HorScroll.Constraints.MaxWidth := PCad.Width - 15 - 7; VerScroll.Constraints.MaxHeight := PCad.Height - 15 - 7; if HorScroll.Width <> (PCad.Width - 15 - 7) then HorScroll.Width := PCad.Width - 15 - 7; if VerScroll.Height <> (PCad.Height - 15 - 7) then VerScroll.Height := PCad.Height - 15 - 7; end; finally PCad.EnableAlign; end; //PCad.BeginUpdate; //PCad.SurfacePaint; //PCad.EndUpdate; PCad.AutoRefresh := PCadAutoRefresh; SetZoomScale(Pcad.ZoomScale); RefreshCAD_T(PCad); //RefreshCAD(PCad); except on E: Exception do addExceptionToLogEx('TF_CAD.ChangeScrollsOnChangeListSize', E.Message); end; //EnableAlign; //26.12.2011 end; // Tolik -- 29/03/2017 -- переписана с учетом мастера комплектации компонента (* procedure TF_CAD.MoveCADOnPan( ADeltaX, ADeltaY: double); var hscroll, vscroll: integer; begin aPCad := Nil; if Self.ClassName = 'TF_CAD' then aPCad := TPowerCad(Self.PCad) else begin for i := 0 to Self.ControlCount - 1 do begin if TControl(Self.Controls[i]).Name = 'Shelf_Cad' then begin aPCad := TPowerCad(Self.Controls[i]); Break; //// BREAK ////; end; end; end; if aPCad <> nil then begin try aPCad.AutoRefresh := False; //PCad.DisableAlign; hscroll := aPCad.HSCBarPosition; vscroll := aPCad.VSCBarPosition; aPCad.SetHScrollPosition(hscroll + round(-adeltax * aPCad.ZoomScale / 25), true); aPCad.SetVScrollPosition(vscroll + round(-adeltay * aPCad.ZoomScale / 25), true); if aPCad.Name <> 'Shelf_Cad' then begin // Гориз. скролл есть if IfVisibleHorScrollBar then begin HorScroll.Visible := True; Set_SCS_HorScroll; end else HorScroll.Visible := False; // Вертик. скролл есть if ifVisibleVerScrollBar then begin VerScroll.Visible := True; Set_SCS_VerScroll; end else VerScroll.Visible := False; // подредактировать скролбары // только гориз. if IfVisibleHorScrollBar and not ifVisibleVerScrollBar then if HorScroll.Width <> (PCad.Width - 7) then HorScroll.Width := PCad.Width - 7; // только вертик. if not IfVisibleHorScrollBar and ifVisibleVerScrollBar then if VerScroll.Height <> (PCad.Height - 7) then VerScroll.Height := PCad.Height - 7; // оба if IfVisibleHorScrollBar and ifVisibleVerScrollBar then begin if HorScroll.Width <> (PCad.Width - 15 - 7) then HorScroll.Width := PCad.Width - 15 - 7; if VerScroll.Height <> (PCad.Height - 15 - 7) then VerScroll.Height := PCad.Height - 15 - 7; end; //HorScroll.Refresh; //VerScroll.Refresh; end; aPCad.AutoRefresh := True; if Abs(FPanLastRefeshTick - GetTickCount) > 50 then begin FPanLastRefeshTick := GetTickCount; //PCad.Repaint; //RefreshCAD(PCad); //RefreshCAD_T(PCad); //PCad.ManualRefresh; //PCad.RefreshSelection; end; aPCad.ManualRefresh; //PCad.EnableAlign; //////ChangeScrollsOnChangeListSize; except on E: Exception do addExceptionToLogEx('TF_CAD.MoveCADOnPan', E.Message); end; end; end; *) procedure TF_CAD.MoveCADOnPan(ADeltaX, ADeltaY: double); var hscroll, vscroll: integer; TCount, RCount: DWord; begin try //Tolik 26/08/2021 -- if not PCad.IsDragging then PCad.IsDragging := True; PCad.AutoRefresh := False; //PCad.DisableAlign; hscroll := PCad.HSCBarPosition; vscroll := PCad.VSCBarPosition; (* PCad.SetHScrollPosition(hscroll + {round(-adeltax * 5)}round(-adeltax) * round(PCad.ZoomScale / 25), true); PCad.SetVScrollPosition(vscroll + {round(-adeltay * 5)}round(-adeltay) * round(PCad.ZoomScale / 25), true); *) PCad.SetHScrollPosition(hscroll + round(-adeltax * PCad.ZoomScale / 25), true); PCad.SetVScrollPosition(vscroll + round(-adeltay * PCad.ZoomScale / 25), true); // Гориз. скролл есть if IfVisibleHorScrollBar then begin HorScroll.Visible := True; Set_SCS_HorScroll; end else HorScroll.Visible := False; // Вертик. скролл есть if ifVisibleVerScrollBar then begin VerScroll.Visible := True; Set_SCS_VerScroll; end else VerScroll.Visible := False; // подредактировать скролбары // только гориз. if IfVisibleHorScrollBar and not ifVisibleVerScrollBar then if HorScroll.Width <> (PCad.Width - 7) then HorScroll.Width := PCad.Width - 7; // только вертик. if not IfVisibleHorScrollBar and ifVisibleVerScrollBar then if VerScroll.Height <> (PCad.Height - 7) then VerScroll.Height := PCad.Height - 7; // оба if IfVisibleHorScrollBar and ifVisibleVerScrollBar then begin if HorScroll.Width <> (PCad.Width - 15 - 7) then HorScroll.Width := PCad.Width - 15 - 7; if VerScroll.Height <> (PCad.Height - 15 - 7) then VerScroll.Height := PCad.Height - 15 - 7; end; //HorScroll.Refresh; //VerScroll.Refresh; PCad.AutoRefresh := True; // Tolik 01/10/2019 -- тут разница в числах может превысить величину числа, возвращаемого функцией ABS...тогда // получим Integer Overflow... чтобы этого не было ... // if Abs(FPanLastRefeshTick - GetTickCount) > 50 then if ((GetTickCount - FPanLastRefeshTick) > 50) then // begin FPanLastRefeshTick := GetTickCount; //PCad.Repaint; //RefreshCAD(PCad); //RefreshCAD_T(PCad); //PCad.ManualRefresh; //PCad.RefreshSelection; end; PCad.ManualRefresh; //PCad.EnableAlign; //////ChangeScrollsOnChangeListSize; except on E: Exception do addExceptionToLogEx('TF_CAD.MoveCADOnPan', E.Message); end; end; procedure TF_CAD.ApplicationEvents1Message(var Msg: tagMSG; var Handled: Boolean); begin try if Msg.message = WM_MOUSEWHEEL then begin Handled := True; ApplicationEvents1.OnMessage := nil; SendMessage(Self.Handle, msg.message, Msg.wParam, msg.lParam); ApplicationEvents1.OnMessage := ApplicationEvents1Message; end; if FWaitWork then Handled := True else inherited; except on E: Exception do addExceptionToLogEx('TF_CAD.ApplicationEvents1Message', E.Message); end; end; Function TF_CAD.CheckScrollingOnTracing(ax, ay: double): Boolean; var //top, bottom, left, right: double; deltax, deltay: double; scrollw, scrollh: integer; step: double; VRect: TDoubleRect; begin Result := False; try deltax := 0; deltay := 0; // if PCad.ZoomScale < 50 then // SetZoomScale(50); (* step := 10 * 100 / PCad.ZoomScale; if step < 1 then step := 1; *) step := 10;// / (PCad.ZoomScale / 100); if step < 1 then step := 1; if IfVisibleHorScrollBar and ifVisibleVerScrollBar then begin //20.06.2013 //top := PCad.GetVisibleRect.Top; //bottom := PCad.GetVisibleRect.Bottom; //left := PCad.GetVisibleRect.Left; //right := PCad.GetVisibleRect.Right; //if (ax < left + 5{ * 100 / PCad.ZoomScale}) then // deltax := - step; //if (ax > right - 5{ * 100 / PCad.ZoomScale}) then // deltax := step; //if (ay < top + 5{ * 100 / PCad.ZoomScale}) then // deltay := - step; //if (ay > bottom - 5{ * 100 / PCad.ZoomScale}) then // deltay := step; (* VRect := PCad.GetVisibleRect; if (ax < VRect.Left + 5{ * 100 / PCad.ZoomScale}) then deltax := - step; if (ax > VRect.Right - 5{ * 100 / PCad.ZoomScale}) then deltax := step; if (ay < VRect.Top + 5{ * 100 / PCad.ZoomScale}) then deltay := - step; if (ay > VRect.Bottom - 5{ * 100 / PCad.ZoomScale}) then deltay := step; if (deltax <> 0) or (deltay <> 0) then begin ScrollCADOnTracing(deltax, deltay); Result := True; end; *) VRect := PCad.GetVisibleRect; if (ax < (VRect.Left + 5/(PCad.ZoomScale/100))) then deltax := - step; if (ax > (VRect.Right - 5/(PCad.ZoomScale/100))) then deltax := step; if (ay < (VRect.Top + 5/(PCad.ZoomScale/100))) then deltay := - step; if (ay > (VRect.Bottom - 5/(PCad.ZoomScale/100))) then deltay := step; if (deltax <> 0) or (deltay <> 0) then begin ScrollCADOnTracing(deltax, deltay); Result := True; end; end; except on E: Exception do addExceptionToLogEx('TF_CAD.CheckScrollingOnTracing', E.Message); end; end; procedure TF_CAD.FormMouseWheel(Sender: TObject; Shift: TShiftState; WheelDelta: Integer; MousePos: TPoint; var Handled: Boolean); var Res1: TWinControl; Pt: TPoint; ks: TKeyboardState; begin try GetCursorPos(Pt); Res1 := FindControl(WindowFromPoint(Pt)); if not PCad.Focused then if Res1.Parent.Name = 'PCad' then begin if (PCad.ToolIdx = toSelect) and (PCad.SelectedCount = 0) then begin SendMessage(Self.Handle, WM_ACTIVATE, MakewParam(WA_ACTIVE, 0), 0); SendMessage(Self.Handle, WM_SETFOCUS, 0, 0); RefreshCAD_T(PCAd); end; end; except end; if ((PCad.ToolIdx = toFigure) and (PCad.ToolInfo = 'TOrthoLine')) and (GClickIndex > 0) then GReDrawAfterRefresh := True; end; procedure TF_CAD.SetZoomScale(aScale: Integer); var r1: TRect; Rect: TDoubleRect; pt: TPoint; ConvX, ConvY, ConvZ, DeconvX, DeconvY, DeconvZ: double; ConvX1, ConvY1, ConvZ1, DeconvX1, DeconvY1, DeconvZ1: double; begin try // ShowMessage('zoom'); if aScale <> PCad.ZoomScale then begin GSavedScrollPosX := PCad.HSCBarPosition; GSavedScrollPosY := PCad.VSCBarPosition; GSavedZoomScale := PCad.ZoomScale; if PCad.AutoRefresh then begin PCad.AutoRefresh := False; try PCad.ZoomScale := aScale; except end; PCad.AutoRefresh := True; end else begin try PCad.ZoomScale := aScale; except end; end; GSavedScrollPosX := -1; GSavedScrollPosY := -1; GSavedZoomScale := PCad.ZoomScale; end else PCad.ResetRegions; except on E: Exception do addExceptionToLogEx('TF_CAD.SetZoomScale', E.Message); end; end; procedure TF_CAD.sDivMoved(Sender: TObject); begin try ChangeScrollsOnChangeListSize; GCadForm.PCad.AutoRefresh := True; except on E: Exception do addExceptionToLogEx('TF_CAD.FormResize', E.Message); end; end; procedure TF_CAD.ScrollCADOnTracing(adeltax, adeltay: double); var hscroll, vscroll: integer; begin try PCad.AutoRefresh := False; hscroll := PCad.HSCBarPosition; vscroll := PCad.VSCBarPosition; if adeltax <> 0 then PCad.SetHScrollPosition(hscroll + round(adeltax), true); if adeltay <> 0 then PCad.SetVScrollPosition(vscroll + round(adeltay), true); // Гориз. скролл есть if IfVisibleHorScrollBar then begin HorScroll.Visible := True; Set_SCS_HorScroll; end else HorScroll.Visible := False; // Вертик. скролл есть if ifVisibleVerScrollBar then begin VerScroll.Visible := True; Set_SCS_VerScroll; end else VerScroll.Visible := False; // подредактировать скролбары // только гориз. if IfVisibleHorScrollBar and not ifVisibleVerScrollBar then if HorScroll.Width <> (PCad.Width - 7) then HorScroll.Width := PCad.Width - 7; // только вертик. if not IfVisibleHorScrollBar and ifVisibleVerScrollBar then if VerScroll.Height <> (PCad.Height - 7) then VerScroll.Height := PCad.Height - 7; // оба if IfVisibleHorScrollBar and ifVisibleVerScrollBar then begin if HorScroll.Width <> (PCad.Width - 15 - 7) then HorScroll.Width := PCad.Width - 15 - 7; if VerScroll.Height <> (PCad.Height - 15 - 7) then VerScroll.Height := PCad.Height - 15 - 7; end; PCad.AutoRefresh := True; RefreshCAD(PCad); if PCad.TraceFigure <> nil then begin if (CheckFigureByClassName(PCad.TraceFigure, 'TOrthoLine')) then PCad.TraceFigure.NotNeedToDraw := True; PCad._DrawTrace; //для отрисовки новой trace shadow if (CheckFigureByClassName(PCad.TraceFigure, 'TOrthoLine')) then PCad.TraceFigure.NotNeedToDraw := false; end; except on E: Exception do addExceptionToLogEx('TF_CAD.ScrollCADOnTracing', E.Message); end; end; procedure TF_CAD.FCADOnRefresh(Sender: TObject); begin try if PCad <> nil then begin if FWasDeleteQuery then FWasDeleteQuery := False; if ((PCad.ToolIdx = toFigure) and (PCad.ToolInfo = 'TOrthoLine')) and (GClickIndex > 0) then begin GReDrawAfterRefresh := True; end; end; except on E: Exception do addExceptionToLogEx('TF_CAD.OnRefreshCAD', E.Message); end; end; procedure TF_CAD.FCADOnKeyStroke(Sender: TObject; Key: Word; Shift: TShiftState; var CanHandle: Boolean); var i: Integer; ObjList: TList; //Tolik ShadowTrace: TFigure; // begin try GisKeyPress := True; GisKeyDown := True; //inGuiEvent := True; try // When the user press DEL key, you should bypass it from Powercad and // send to TNet just to delete the selected element of the figure CanHandle := True; if (Key = vk_Delete) and (ssCtrl in Shift) then begin if PCad.ActiveLayer = lnArch then begin if PCad.SelectedCount > 0 then begin if CheckFigureByClassName(TFigure(PCad.Selection[0]), 'TNet') then begin CanHandle := False; FSCS_Main.aDeleteWallRect.Execute; RefreshCAD(PCad); end; end; end; end else if Key = vk_Delete then begin // Tolik 26/10/2015 // ???? нах проверка для каждой фигуры ???? {for i := 0 to PCad.Selection.Count - 1 do begin if PCad.ActiveLayer = lnArch then begin if CheckFigureByClassName(TFigure(PCad.Selection[i]), 'TNet') then begin CanHandle := False; FSCS_Main.aDeleteWallPath.Execute; FSCS_Main.aDeleteColumn.Execute; RefreshCAD(PCad); end; end; end;} if PCad.ActiveLayer = lnArch then begin for i := 0 to PCad.Selection.Count - 1 do begin if CheckFigureByClassName(TFigure(PCad.Selection[i]), 'TNet') then begin CanHandle := False; FSCS_Main.aDeleteWallPath.Execute; FSCS_Main.aDeleteColumn.Execute; RefreshCAD(PCad); end; end; end; end; // Если на Арх.плане Ctrl+Z или Ctrl+Y - перевести в режим селекта, чтобы отработать if (PCad.ToolIdx = toFigure) and (PCad.ActiveLayer = lnArch) then if ((Key = 89) or (Key = 90)) and (ssCtrl in Shift) then PCad.SetTool(toSelect, 'TSelected'); // Tolik 03/08/2018 -- if (PCad.ToolIdx <> toSelect) then if (Key = 90) and (ssCtrl in Shift) then PCad.Undo; // if (PCad.ToolIdx = toSelect) then begin // CTRL + A if (Key = 65) and (ssCtrl in Shift) then begin PCad.DrawFigures; RefreshCAD_T(PCad); GCanRefreshProperties := True; CanHandle := True; if PCad.ActiveLayer = lnSCSCommon then begin if (not (ssAlt in Shift)) and (ssShift in Shift) then begin CanHandle := False; SelectTracesAndRaisers; end else if (ssAlt in Shift) and (ssShift in Shift) then begin CanHandle := False; SelectTraces; end else if (ssAlt in Shift) and (not (ssShift in Shift)) then begin CanHandle := False; InvertSCSSelection; end; end else begin if ssAlt in Shift then begin CanHandle := False; InvertAllSelection; end; end; end; // CTRL + X if (Key = 88) and (ssCtrl in Shift) then begin if (FListType <> lt_Normal) or (PCad.ActiveLayer = lnArch) or CheckOneOfSCSlayers(PCad.ActiveLayer) then begin Clipboard.Clear; CanHandle := False; end else begin if not GProjectChanged then // Tolik 28/08/2019 -- SetProjectChanged(True); end; end; // CTRL + C if (Key = 67) and (ssCtrl in Shift) then begin if (FListType <> lt_Normal) or (PCad.ActiveLayer = lnArch) or CheckOneOfSCSlayers(PCad.ActiveLayer) then begin Clipboard.Clear; CanHandle := False; end else begin if not GProjectChanged then // Tolik 28/08/2019 -- SetProjectChanged(True); end; end; // CTRL + V if (Key = 86) and (ssCtrl in Shift) then begin if (FListType <> lt_Normal) or ((PCad.ActiveLayer <> 1) and (PCad.ActiveLayer <> 7)) then begin CurrentLayer := 1; end; end; // CTRL + Y if (Key = 89) and (ssCtrl in Shift) then begin {if GCadForm.FCreateObjectOnClick then Exit; } // CTRL + Y для слоя СКС if (FListType = lt_Normal) and ((PCad.ActiveLayer = lnArch) or CheckOneOfSCSlayers(PCad.ActiveLayer)) then begin SCSRedoNormalList; if not GProjectChanged then // Tolik 28/08/2019 -- SetProjectChanged(True); end else // CTRL + Y для листа схемы проекта if (FListType = lt_ProjectPlan) then begin SCSRedoProjectPlan; if not GProjectChanged then // Tolik 28/08/2019 -- SetProjectChanged(True); CanHandle := False; end else // CTRL + Y для листа дизайна шкафа if (FListType = lt_DesignBox) then begin SCSRedoDesignList; if not GProjectChanged then // Tolik 28/08/2019 -- SetProjectChanged(True); CanHandle := False; end // Tolik 12/02/2021 -- электрическая однолинейная схема {else if (FListType = lt_ElScheme) then begin SCSRedoElScheme; if not GProjectChanged then // Tolik 28/08/2019 -- SetProjectChanged(True); CanHandle := False; end} // это не обычный лист и слои на нем левые else if (FListType <> lt_Normal) or ((PCad.ActiveLayer <> 1) and (PCad.ActiveLayer <> 7) and (PCad.ActiveLayer < 10)) then begin CanHandle := False; end else begin if not GProjectChanged then // Tolik 28/08/2019 -- SetProjectChanged(True); end; end; // CTRL + Z if (Key = 90) and (ssCtrl in Shift) then begin { if GCadForm.FCreateObjectOnClick then Exit;} // CTRL + Z для слоя СКС if (FListType = lt_Normal) and ((PCad.ActiveLayer = lnArch) or CheckOneOfSCSlayers(PCad.ActiveLayer)) then begin SCSUndoNormalList; if not GProjectChanged then // Tolik 28/08/2019 -- SetProjectChanged(True); end else // CTRL + Z для листа схемы проекта if (FListType = lt_ProjectPlan) then begin // commented by Tolik 25/06/2021 -- { SCSUndoProjectPlan; if not GProjectChanged then // Tolik 28/08/2019 -- SetProjectChanged(True); CanHandle := False; } end else // CTRL + Z для листа дизайна шкафа if (FListType = lt_DesignBox) then begin //Tolik 23/06/2021 -- {SCSUndoDesignList; if not GProjectChanged then // Tolik 28/08/2019 -- SetProjectChanged(True); CanHandle := False;} end // Tolik 12/02/2021 -- { else if (FListType = lt_ElScheme) then begin SCSUndoElScheme; if not GProjectChanged then // Tolik 28/08/2019 -- SetProjectChanged(True); //CanHandle := False; end } // это не обычный лист и слои на нем левые else if (FListType <> lt_Normal) or ((PCad.ActiveLayer <> 1) and (PCad.ActiveLayer <> 7) and (PCad.ActiveLayer < 10)) then begin if ((FListType <> lt_ElScheme) or (FListType <> lt_AScheme)) then // Tolik 02/06/2021 -- CanHandle := False; end else begin if not GProjectChanged then // Tolik 28/08/2019 -- SetProjectChanged(True); end; end; // CTRL + D // Создать дубликаты выделенных объектов if (Key = 68) and (ssCtrl in Shift) then begin if FListType = lt_Normal then begin if (PCad.ActiveLayer = lnSCSCommon) or (PCad.ActiveLayer = lnArch) then begin FSCS_Main.aCreateDuplicates.Execute; end; end; end; // Увеличить масштаб "+" if (Key = 187) or (Key = 107) then begin FSCS_Main.aInc1pt.Execute; end; // Уменьшить масштаб "-" if (Key = 189) or (Key = 109) then begin FSCS_Main.aDec1pt.Execute; end; // поворот выделенных объектов на +-5 грудусов if (ssCtrl in Shift) and ((Key = VK_NUMPAD6) or (Key = VK_NUMPAD4)) then begin if (PCad.ActiveLayer = 2) then begin ObjList := TList.Create; for i := 0 to PCad.SelectedCount - 1 do begin if CheckFigureByClassName(TFigure(PCad.Selection[i]), cTConnectorObject) then if TConnectorObject(PCad.Selection[i]).ConnectorType <> ct_Clear then ObjList.Add(TConnectorObject(PCad.Selection[i])); end; if ObjList.Count > 0 then begin if Key = VK_NUMPAD6 then RotateObjectsByKeyboard(ObjList, 5); if Key = VK_NUMPAD4 then RotateObjectsByKeyboard(ObjList, -5); end; FreeAndNil(ObjList); end; end; //Tolik 23/07/2021 -- if (ssCtrl in Shift) and (ssShift in Shift) and ((Key = 37) or (Key = 39)) then begin if (PCad.ActiveLayer = 2) then begin ObjList := TList.Create; for i := 0 to PCad.SelectedCount - 1 do begin if CheckFigureByClassName(TFigure(PCad.Selection[i]), cTConnectorObject) then if TConnectorObject(PCad.Selection[i]).ConnectorType <> ct_Clear then ObjList.Add(TConnectorObject(PCad.Selection[i])); end; if ObjList.Count > 0 then begin if Key = 39 then RotateObjectsByKeyboard(ObjList, 90); if Key = 37 then RotateObjectsByKeyboard(ObjList, -90); end; FreeAndNil(ObjList); end; end; // end; if (Key >=37) and (Key <= 40) then begin GMoveByArrow := True; end; except on E: Exception do addExceptionToLogEx('TF_CAD.FCADOnKeyStroke', E.Message); end; //Tolik 31/10/2015 finally GisKeyPress := False; //InGuiEvent := False; if not ((Key >=37) and (Key <= 40)) then begin try GMoveByArrow := False; finally GisKeyDown := False; GisMouseDown := False; // если отжата не Shift, Alt или Control, то вызываем EventEngine // вдруг было удаление, то он почистит FRemFigures и, при необходимости, // выполнит удаление фигур { if not (Key in [VK_SHIFT, VK_CONTROL, VK_MENU]) then begin // if GisAction then if GisEventWaiting then PCad.EventEngine(95,1,'',0); end;} // end; end; // Tolik 24/12/2015 if GisEventWaiting then begin //PCad.EventEngine(95,1,'',0); // Tolik 27/03/2019 -- PCad.OnGUIEvent := PCadGUIEvent; end; end; // end; procedure TF_CAD.PCadMapScaleChanged(Sender: TObject); begin try ReCalcAllLinesLength; if Assigned(FActiveNet) and Not FActiveNet.Deleted then FActiveNet.SetMapScale(PCad.MapScale); //FActiveNet.MapScale := PCad.MapScale; if Assigned(ActiveNet) and Not ActiveNet.Deleted then ActiveNet.SetMapScale(PCad.MapScale); //ActiveNet.MapScale := PCad.MapScale; SetMapScaleToNets(Self); if not GProjectChanged then // Tolik 28/08/2019 -- SetProjectChanged(True); except on E: Exception do addExceptionToLogEx('TF_CAD.PCadMapScaleChanged', E.Message); end; end; procedure TF_CAD.sDivCanResize(Sender: TObject; var NewSize: Integer; var Accept: Boolean); begin try GCadForm.PCad.AutoRefresh := False; except on E: Exception do addExceptionToLogEx('TF_CAD.sDivCanResize', E.Message); end; end; procedure TF_CAD.FormCADPopupMenu(X, Y: Double; aAllowSelectInPM: Boolean); var i: Integer; Point: TPoint; Conn: TConnectorObject; Net: TNet; ArchObj: TSCSComponent; ArchSubObj: TSCSComponent; Path: TNetPath; TNetCount: Integer; // Tolik 15/09/2017 -- DoorPropMenuIndex: Integer; SelectedDoor, SelectedWindow: TNetDoor; FigCatalog: TSCSCatalog; FirstCompon: TSCSComponent; // procedure pmObjectsPrepare; var IsPolyline: Boolean; PolyLine: TPolyline; Seg: TPLSegment; PenPattern:TPattern; begin FSCS_Main.aObjProperties.Visible := True; FSCS_Main.pmiObjectSplit0.Visible := True; FSCS_Main.aFreeRotate.Visible := True; FSCS_Main.pmiObjectSplit1.Visible := True; FSCS_Main.aBackwards.Visible := True; FSCS_Main.aForward.Visible := True; FSCS_Main.aGrouping.Visible := True; FSCS_Main.aUngrouping.Visible := True; FSCS_Main.aLock.Visible := True; FSCS_Main.aUnlock.Visible := True; FSCS_Main.pmiObjectSplit2.Visible := True; FSCS_Main.aCreateBlockToFile.Visible := True; FSCS_Main.aCreateBlockToNB.Visible := True; FSCS_Main.pmiObjectSplit3.Visible := False; FSCS_Main.aDesignBoxCaptionHeight.Visible := False; FSCS_Main.aDesignBoxCaptionWidth.Visible := False; FSCS_Main.pmiObjectSplit4.Visible := False; FSCS_Main.aBlockParams.Visible := True; //16.05.2011 False; FSCS_Main.aCabinetFalseFloor.Visible := False; FSCS_Main.aConvertSegmentToArc.Visible := False; FSCS_Main.aInsertKnotForCabinet.Visible := False; FSCS_Main.aDeleteKnotForCabinet.Visible := False; FSCS_Main.aInvertArcSegment.Visible := False; FSCS_Main.aRotatePointObject90.Visible := True; FSCS_Main.aRotatePointObject270.Visible := True; FSCS_Main.aRotatePointObject180.Visible := True; FSCS_Main.aMirrorFigure.Visible := True; if Assigned(GPopupFigure) then begin FSCS_Main.aConvertToPolygon.Visible := GPopupFigure is TCircle; FSCS_Main.aLinesToTraces.Visible := (GPopupFigure is TLine) or (GPopupFigure is TPolyline) or (GPopupFigure is TFigureGrp); FSCS_Main.aTransparentFigure.Visible := GPopupFigure is TBMPObject; if FSCS_Main.aTransparentFigure.Visible then FSCS_Main.aTransparentFigure.Checked := TBMPObject(GPopupFigure).Transparent; end else begin FSCS_Main.aConvertToPolygon.Visible := false; FSCS_Main.aLinesToTraces.Visible := false; FSCS_Main.aTransparentFigure.Visible := False; end; // Для полилинии PolyLine := nil; Seg := nil; //PenPattern := nil; IsPolyline := (GPopupFigure <> nil) and (GPopupFigure is TPolyline); if IsPolyline then begin PolyLine := TPolyline(GPopupFigure); Seg := TPLSegment(PolyLine.Segments[PolyLine.SelectedPoint-1]); end; FSCS_Main.pmiObjectSplitPoly.Visible := IsPolyline; FSCS_Main.aSegCurveAll.Visible := IsPolyline; FSCS_Main.aSegLineAll.Visible := IsPolyline; FSCS_Main.aSegInsertKnot.Visible := IsPolyline; FSCS_Main.aSegDeleteKnot.Visible := IsPolyline; FSCS_Main.pmiObjSegment.Visible := IsPolyline; FSCS_Main.aSegDivTo3.Visible := IsPolyline; FSCS_Main.aSegRoundCornerByArc.Visible := IsPolyline; FSCS_Main.aSegDimLine.Visible := IsPolyline; FSCS_Main.pmiSegPenPattern.Visible := IsPolyline; if Assigned(PolyLine) then begin FSCS_Main.aSegClose.Visible := Not PolyLine.Closed; FSCS_Main.aSegOpen.Visible := PolyLine.Closed; if Assigned(Seg) then begin FSCS_Main.aSegLine.Checked := (Seg.SType = sLine); FSCS_Main.aSegCurve.Checked := (Seg.SType = sCurve); FSCS_Main.aSegArc.Checked := (Seg.SType = sArc); FSCS_Main.aSegDimLine.Checked := Seg.ShowDim; end else begin FSCS_Main.aSegLine.Checked := false; FSCS_Main.aSegCurve.Checked := false; FSCS_Main.aSegArc.Checked := false; FSCS_Main.aSegDimLine.Checked := Seg.ShowDim; end; FSCS_Main.aSegInverArc.Visible := FSCS_Main.aSegArc.Checked; FSCS_Main.aSegPenNone.Checked := Not Assigned(PolyLine.PenPattern); if Assigned(PolyLine.PenPattern) then begin FSCS_Main.aSegPenZigZag.Checked := (PolyLine.PenPattern.PatName = pnZigZag); FSCS_Main.aSegPenFlower.Checked := (PolyLine.PenPattern.PatName = pnFlower); FSCS_Main.aSegPenSinus.Checked := (PolyLine.PenPattern.PatName = pnSinus); FSCS_Main.aSegPenButtons.Checked := (PolyLine.PenPattern.PatName = pnButtons); FSCS_Main.aSegPenSquare.Checked := (PolyLine.PenPattern.PatName = pnSquare); FSCS_Main.aSegPenMiniSinus.Checked := (PolyLine.PenPattern.PatName = pnMiniSinus); end else begin FSCS_Main.aSegPenZigZag.Checked := false; FSCS_Main.aSegPenFlower.Checked := false; FSCS_Main.aSegPenSinus.Checked := false; FSCS_Main.aSegPenButtons.Checked := false; FSCS_Main.aSegPenSquare.Checked := false; FSCS_Main.aSegPenMiniSinus.Checked := false; end; end else begin FSCS_Main.aSegClose.Visible := false; FSCS_Main.aSegOpen.Visible := false; FSCS_Main.aSegInverArc.Visible := false; end; end; procedure pmObjectsForArchPrepare; begin //FSCS_Main.pmiArchTurn.Visible FSCS_Main.aObjProperties.Visible := False; //True; FSCS_Main.pmiObjectSplit0.Visible := False; //True; FSCS_Main.aFreeRotate.Visible := False; //True; FSCS_Main.pmiObjectSplit1.Visible := False; //True; FSCS_Main.aBackwards.Visible := False; //True; FSCS_Main.aForward.Visible := False; //True; FSCS_Main.aGrouping.Visible := True; FSCS_Main.aUngrouping.Visible := True; FSCS_Main.aLock.Visible := False; FSCS_Main.aUnlock.Visible := false; FSCS_Main.pmiObjectSplit2.Visible := False; //True; FSCS_Main.aCreateBlockToFile.Visible := False; //True; FSCS_Main.aCreateBlockToNB.Visible := False; //True; FSCS_Main.pmiObjectSplit3.Visible := False; FSCS_Main.aDesignBoxCaptionHeight.Visible := False; FSCS_Main.aDesignBoxCaptionWidth.Visible := False; FSCS_Main.pmiObjectSplit4.Visible := False; FSCS_Main.aBlockParams.Visible := True; FSCS_Main.aCabinetFalseFloor.Visible := False; FSCS_Main.aConvertSegmentToArc.Visible := False; FSCS_Main.aInsertKnotForCabinet.Visible := False; FSCS_Main.aDeleteKnotForCabinet.Visible := False; FSCS_Main.aInvertArcSegment.Visible := False; FSCS_Main.aRotatePointObject90.Visible := True; FSCS_Main.aRotatePointObject270.Visible := True; FSCS_Main.aRotatePointObject180.Visible := True; FSCS_Main.aMirrorFigure.Visible := True; //FSCS_Main.aConvertToPolygon.Visible := Assigned(GPopupFigure) and (GPopupFigure is TNet) and end; // Tolik 15/09/2017 -- Function GetMnuItemIndexByName(aName: String): Integer; var i: Integer; begin Result := -1; for i := 0 to FSCS_Main.pmArchDesign.Items.Count - 1 do begin if TMenuItem(FSCS_Main.pmArchDesign.Items[i]).Name = aName then begin Result := i; break; end; end; end; // // Tolik 05/09/2018 -- Function CheckDoorClick(aPath: TNetPath): Boolean; var i: Integer; currDoor: TNetDoor; begin Result := False; for i := 0 to aPath.Doors.Count - 1 do begin end; end; Function CheckWindowClick(aPath: TNetPath): Boolean; var i: Integer; begin Result := False; end; // Tolik 16/06/2021 -- procedure InsertActToPopupMenu(APopupMenu: TPopupMenu; AIndex: Integer; AAction: TAction); var pmnuItem: TMenuItem; begin if Not Assigned(APopupMenu) then Exit; ///// EXIT ///// pmnuItem := TMenuItem.Create(APopupMenu); pmnuItem.Action := AAction; if Not Assigned(AAction) then pmnuItem.Caption := '-'; APopupMenu.Items.Insert(AIndex, pmnuItem); if Assigned(AAction) then begin APopupMenu.Items[AIndex].Caption := AAction.Caption; APopupMenu.Items[AIndex].ImageIndex := AAction.ImageIndex; end; end; // begin //Tolik 16/06/2021 -- FSCS_Main.Pmi_CopyCurrList.Visible := False; FSCS_Main.Pmi_CopyCurrListWCompon.Visible := False; // GPopupFigure := nil; //16.05.2011 ArchObj := nil; ArchSubObj := nil; GetCursorPos(FPopupScrPoint); //04.05.2012 try GetCursorPos(Point); if PCad.CheckByPoint(PCad.ActiveLayer, X, Y) = nil then begin //21.05.2012 for i := 0 to 14 do //21.05.2012 FSCS_Main.pmList.Items[i].Visible := True; FSCS_Main.pmiListProperties.Visible := True; FSCS_Main.pmiListAllScreen.Visible := True; FSCS_Main.pmiList50.Visible := True; FSCS_Main.pmiList75.Visible := True; FSCS_Main.pmiList100.Visible := True; FSCS_Main.pmiList150.Visible := True; FSCS_Main.pmiList200.Visible := True; FSCS_Main.pmiList400.Visible := True; FSCS_Main.pmiListGridStep.Visible := True; FSCS_Main.pmiListInc.Visible := True; FSCS_Main.pmiListInc1pt.Visible := True; FSCS_Main.pmiListDec1pt.Visible := True; FSCS_Main.pmiListPageColor.Visible := True; FSCS_Main.pmiListBackgroundColor.Visible := True; FSCS_Main.pmiListClearGuides.Visible := True; if FListType = lt_DesignBox then begin //21.05.2012 FSCS_Main.pmList.Items[15].Visible := True; //21.05.2012 FSCS_Main.pmList.Items[16].Visible := True; FSCS_Main.pmiListDesignBoxParams.Visible := True; FSCS_Main.pmiListRefreshDesignList.Visible := True; end else begin //21.05.2012 FSCS_Main.pmList.Items[15].Visible := False; //21.05.2012 FSCS_Main.pmList.Items[16].Visible := False; FSCS_Main.pmiListDesignBoxParams.Visible := False; FSCS_Main.pmiListRefreshDesignList.Visible := False; end; //Tolik 16/06/2021 -- { if FSCS_Main.PmList.Items[1].Action <> F_ProjMan.Act_CopyCurrListWithoutCompons then begin InsertActToPopupMenu(FSCS_Main.PmList, 1, F_ProjMan.Act_CopyCurrList); InsertActToPopupMenu(FSCS_Main.PmList, 1, F_ProjMan.Act_CopyCurrListWithoutCompons); FSCS_Main.PmList.Items[1].ImageIndex := 209; FSCS_Main.PmList.Items[2].ImageIndex := 209; end; } // Tolik 16/06/2021 -- FSCS_Main.Pmi_CopyCurrList.Visible := True; FSCS_Main.Pmi_CopyCurrListWCompon.Visible := True; FSCS_Main.aAutoCreateTraces.Visible := True; // Tolik 08/02/2022 -- FSCS_Main.pmList.Popup(Point.X, Point.Y); // end else begin // для обьектов PowerCad if PCad.ActiveLayer = 1 then begin GPopupFigure := PCad.CheckByPoint(PCad.ActiveLayer, X, Y); if GPopupFigure = nil then Exit; if CheckFigureByClassName(GPopupFigure, cTCadNorms) then begin FSCS_Main.pmiCNNormsEdit.Visible := True; FSCS_Main.pmiCNNormsProp.Visible := True; FSCS_Main.pmCadNorms.Popup(Point.X, Point.Y); end else begin //16.05.2011 //FSCS_Main.pmObject.Items[0].Visible := True; //FSCS_Main.pmObject.Items[1].Visible := True; //FSCS_Main.pmObject.Items[2].Visible := True; //FSCS_Main.pmObject.Items[3].Visible := True; //FSCS_Main.pmObject.Items[4].Visible := True; //FSCS_Main.pmObject.Items[5].Visible := True; //FSCS_Main.pmObject.Items[6].Visible := True; //FSCS_Main.pmObject.Items[7].Visible := True; //FSCS_Main.pmObject.Items[8].Visible := True; //FSCS_Main.pmObject.Items[9].Visible := True; //FSCS_Main.pmObject.Items[10].Visible := True; //FSCS_Main.pmObject.Items[11].Visible := True; //FSCS_Main.pmObject.Items[12].Visible := True; //FSCS_Main.pmObject.Items[13].Visible := False; //FSCS_Main.pmObject.Items[14].Visible := False; //FSCS_Main.pmObject.Items[15].Visible := False; //FSCS_Main.pmObject.Items[16].Visible := False; //FSCS_Main.pmObject.Items[17].Visible := False; //FSCS_Main.pmObject.Items[18].Visible := False; //FSCS_Main.pmObject.Items[19].Visible := False; //FSCS_Main.pmObject.Items[20].Visible := False; //FSCS_Main.pmObject.Items[21].Visible := False; //FSCS_Main.pmObject.Items[22].Visible := False; pmObjectsPrepare; if GCadForm.FListType = lt_DesignBox then begin if PCad.SelectedCount > 0 then begin if CheckFigureByClassName(TFigure(PCad.Selection[0]), 'TText') then begin //16.05.2011 //FSCS_Main.pmObject.Items[13].Visible := False; //FSCS_Main.pmObject.Items[14].Visible := False; //FSCS_Main.pmObject.Items[15].Visible := False; FSCS_Main.pmiObjectSplit3.Visible := False; FSCS_Main.aDesignBoxCaptionHeight.Visible := False; FSCS_Main.aDesignBoxCaptionWidth.Visible := False; end; end; end; if CheckFigureByClassName(GPopupFigure, 'TBlock') or CheckFigureByClassName(GPopupFigure, 'TFigureGrp') or CheckFigureByClassName(GPopupFigure, 'TWMFObject') then begin //16.05.2011 //FSCS_Main.pmObject.Items[16].Visible := True; //FSCS_Main.pmObject.Items[17].Visible := True; FSCS_Main.pmiObjectSplit4.Visible := True; FSCS_Main.aBlockParams.Visible := True; end; FSCS_Main.pmObject.Popup(Point.X, Point.Y); end; end; // для кабинетов if PCad.ActiveLayer = 9 then begin GPopupFigure := PCad.CheckByPoint(PCad.ActiveLayer, X, Y); if GPopupFigure = nil then Exit; if CheckFigureByClassName(GPopupFigure, cTCabinet) then begin //16.05.2011 //for i := 0 to 17 do // FSCS_Main.pmObject.Items[i].Visible := False; //FSCS_Main.pmObject.Items[18].Visible := True; //FSCS_Main.pmObject.Items[19].Visible := False; //FSCS_Main.pmObject.Items[20].Visible := False; //FSCS_Main.pmObject.Items[21].Visible := False; //FSCS_Main.pmObject.Items[22].Visible := False; //FSCS_Main.pmObject.Popup(Point.X, Point.Y); ShowHideMenuItems(FSCS_Main.pmObject, false); FSCS_Main.aCabinetFalseFloor.Visible := True; FSCS_Main.pmObject.Popup(Point.X, Point.Y); end else if CheckFigureByClassName(GPopupFigure, cTCabinetExt) then begin //for i := 0 to 17 do // FSCS_Main.pmObject.Items[i].Visible := False; //FSCS_Main.pmObject.Items[18].Visible := True; //FSCS_Main.pmObject.Items[19].Visible := True; //FSCS_Main.pmObject.Items[20].Visible := True; //FSCS_Main.pmObject.Items[21].Visible := True; //FSCS_Main.pmObject.Items[22].Visible := True; //FSCS_Main.pmObject.Popup(Point.X, Point.Y); ShowHideMenuItems(FSCS_Main.pmObject, false); FSCS_Main.aCabinetFalseFloor.Visible := True; FSCS_Main.aConvertSegmentToArc.Visible := True; FSCS_Main.aInsertKnotForCabinet.Visible := True; FSCS_Main.aDeleteKnotForCabinet.Visible := True; FSCS_Main.aInvertArcSegment.Visible := True; FSCS_Main.pmObject.Popup(Point.X, Point.Y); end; end; // для архитектурного проектирования if PCad.ActiveLayer = lnArch then begin if PCad.SelectedCount = 1 then begin // TNET if CheckFigureByClassName(TFigure(PCad.Selection.Items[0]), 'TNet') then begin //07.06.2010 Переход на имена Экшнов //// Для сегмента // if TNet(PCad.Selection[0]).SelPath <> nil then // begin // FSCS_Main.pmArchDesign.Items[0].Visible := True; // FSCS_Main.pmArchDesign.Items[1].Visible := True; // FSCS_Main.pmArchDesign.Items[2].Visible := True; // FSCS_Main.pmArchDesign.Items[3].Visible := True; // FSCS_Main.pmArchDesign.Items[4].Visible := True; // FSCS_Main.pmArchDesign.Items[5].Visible := True; // FSCS_Main.pmArchDesign.Items[6].Visible := True; // FSCS_Main.pmArchDesign.Items[7].Visible := True; // FSCS_Main.pmArchDesign.Items[9].Visible := False; // FSCS_Main.pmArchDesign.Items[11].Visible := False; // FSCS_Main.pmArchDesign.Items[12].Visible := False; // FSCS_Main.pmArchDesign.Items[13].Visible := False; // FSCS_Main.pmArchDesign.Items[14].Visible := True; // FSCS_Main.pmArchDesign.Items[15].Visible := True; // FSCS_Main.pmArchDesign.Items[16].Visible := True; // FSCS_Main.pmArchDesign.Items[17].Visible := True; // // FSCS_Main.pmArchDesign.Items[18].Visible := True; // if TNet(PCad.Selection[0]).SelPath.ActiveDoor <> nil then // begin // FSCS_Main.pmArchDesign.Items[8].Visible := True; // FSCS_Main.pmArchDesign.Items[10].Visible := True; // end // else // begin // FSCS_Main.pmArchDesign.Items[8].Visible := False; // FSCS_Main.pmArchDesign.Items[10].Visible := False; // end; // if TNet(PCad.Selection[0]).SelPath.FShowLength then // begin // FSCS_Main.pmArchDesign.Items[18].Checked := True; // end // else // begin // FSCS_Main.pmArchDesign.Items[18].Checked := False; // end; // FSCS_Main.pmArchDesign.Popup(Point.X, Point.Y); // end; // // Для колонны // if TNet(PCad.Selection[0]).SelCol <> nil then // begin // FSCS_Main.pmArchDesign.Items[0].Visible := False; // FSCS_Main.pmArchDesign.Items[1].Visible := True; // FSCS_Main.pmArchDesign.Items[2].Visible := False; // FSCS_Main.pmArchDesign.Items[3].Visible := False; // FSCS_Main.pmArchDesign.Items[4].Visible := False; // FSCS_Main.pmArchDesign.Items[5].Visible := False; // FSCS_Main.pmArchDesign.Items[6].Visible := False; // FSCS_Main.pmArchDesign.Items[7].Visible := False; // FSCS_Main.pmArchDesign.Items[8].Visible := False; // FSCS_Main.pmArchDesign.Items[9].Visible := True; // FSCS_Main.pmArchDesign.Items[10].Visible := False; // FSCS_Main.pmArchDesign.Items[11].Visible := True; // FSCS_Main.pmArchDesign.Items[12].Visible := True; // FSCS_Main.pmArchDesign.Items[13].Visible := True; // FSCS_Main.pmArchDesign.Items[14].Visible := False; // FSCS_Main.pmArchDesign.Items[15].Visible := False; // FSCS_Main.pmArchDesign.Items[16].Visible := False; // FSCS_Main.pmArchDesign.Items[17].Visible := False; // FSCS_Main.pmArchDesign.Items[18].Visible := False; // FSCS_Main.pmArchDesign.Popup(Point.X, Point.Y); // end; FSCS_Main.aConvertToPolygon.Visible := false; FSCS_Main.aLinesToTraces.Visible := false; Net := TNet(PCad.Selection[0]); ArchObj := GetArchObjByCADObj(Net); Path := Net.SelPath; // Tolik 05/09/2018 -- SelectedDoor := Net.SelDoor; SelectedWindow := Net.SelWindow; // // Для сегмента if Path <> nil then begin //Tolik -- 15/09/2107 -- DoorPropMenuIndex := GetMnuItemIndexByName('SetNetDoorType'); if SelectedDoor <> nil then // Tolik 05/09/2018 -- чтобы только для двери ... begin if DoorPropMenuIndex <> -1 then begin if Path.DoorIndex = -1 then FSCS_Main.pmArchDesign.Items[DoorPropMenuIndex].Visible := False else begin FSCS_Main.pmArchDesign.Items[DoorPropMenuIndex].Visible := True; FSCS_Main.pmArchDesign.Items[DoorPropMenuIndex].Items[0].Checked := TNetDoor(Path.Doors[Path.DoorIndex]).Doubled; // Двойная FSCS_Main.pmArchDesign.Items[DoorPropMenuIndex].Items[1].Checked := TNetDoor(Path.Doors[Path.DoorIndex]).Mirrored; // в другую сторону (зеркально) FSCS_Main.pmArchDesign.Items[DoorPropMenuIndex].Items[2].Checked := TNetDoor(Path.Doors[Path.DoorIndex]).LeftRight; // Двустворчатая FSCS_Main.pmArchDesign.Items[DoorPropMenuIndex].Items[3].Checked := TNetDoor(Path.Doors[Path.DoorIndex]).Opened; // Открытая FSCS_Main.pmArchDesign.Items[DoorPropMenuIndex].Items[4].Checked := TNetDoor(Path.Doors[Path.DoorIndex]).HalfOpened; // Полуоткрытая end; end; end else FSCS_Main.pmArchDesign.Items[DoorPropMenuIndex].Visible := False; // ArchSubObj := GetArchObjByCADObj(Path); FSCS_Main.aDeleteWallPath.Visible := True; FSCS_Main.aDeleteWallRect.Visible := True; FSCS_Main.aDivSelPath.Visible := True; FSCS_Main.aSetWallPathWidth.Visible := True; FSCS_Main.aSetAllWallPathWidth.Visible := True; FSCS_Main.aAddWindow.Visible := True; FSCS_Main.aAddDoor.Visible := True; FSCS_Main.aAddColumn.Visible := (Net.SelPath.FComponID = 0); //FSCS_Main.aAddColumn.Visible := True; FSCS_Main.aDeleteColumn.Visible := False; FSCS_Main.aSetColumnAngle.Visible := False; FSCS_Main.aSetColumnHeight.Visible := False; FSCS_Main.aSetColumnWidth.Visible := False; FSCS_Main.aSetPathLineWidth.Visible := True; FSCS_Main.aSetPathLineStyle.Visible := True; FSCS_Main.aSetAllPathLineWidth.Visible := True; FSCS_Main.aSetAllPathLineStyle.Visible := True; FSCS_Main.aWallPathShowLength.Visible := True; FSCS_Main.aSetCornHeight.Visible := True; // Tolik 04/09/2018 -- высота угла стены для архитектуры FSCS_Main.aSetDoorWindowPllacementHeight.Visible := True; // задать высоту размещения окна/двери FSCS_Main.aSetDoorWndH.Visible := True; // задать высоту окна/двери // Перевернуть объекта FSCS_Main.pmiArchTurn.Visible := Path.ExistsPerpendPt; //(Path.epl1<>nil)or(Path.epl2<>nil)or(Path.epr1<>nil) or (Path.epr2<>nil); if Path.WStyle = wsLine then begin FSCS_Main.aSetAllPathLineWidth.Visible := False; FSCS_Main.aAddWindow.Visible := False; FSCS_Main.aAddDoor.Visible := False; FSCS_Main.aSetCornHeight.Visible := True; // Tolik 04/09/2018 -- высота угла стены для архитектуры FSCS_Main.aSetDoorWindowPllacementHeight.Visible := True; FSCS_Main.aSetDoorWndH.Visible := True; FSCS_Main.aAddColumn.Visible := False; FSCS_Main.aSetWallPathWidth.Visible := false; FSCS_Main.aSetAllWallPathWidth.Visible := false; end; if Net.SelPath.ActiveDoor <> nil then begin FSCS_Main.aDeleteWindowDoor.Visible := True; FSCS_Main.aSetSizeWindowDoor.Visible := True; if Net.SelPath.ActiveDoor.DoorObjType = dotNiche then FSCS_Main.pmiArchTurn.Visible := true; end else begin FSCS_Main.aDeleteWindowDoor.Visible := False; FSCS_Main.aSetSizeWindowDoor.Visible := False; end; if Net.SelPath.FShowLength then FSCS_Main.aWallPathShowLength.Checked := True else FSCS_Main.aWallPathShowLength.Checked := False; // сегмент в дугу FSCS_Main.aNetPathToArc.Visible := false; //if Not Path.isArc and // ((Path.FComponID = 0) or (TSCSComponent(GetArchObjByCADObj(Path)).IsLine = ctArhWall)) then if Not Path.isArc and ((Path.FComponID = 0) or Assigned(ArchSubObj)) then FSCS_Main.aNetPathToArc.Visible := true; // инвертировать дугу FSCS_Main.aInvertNetPathArc.Visible := false; if Path.isArc then begin FSCS_Main.aInvertNetPathArc.Visible := true; FSCS_Main.aConvertToPolygon.Visible := true; end; if Assigned(ArchObj) then begin if ArchObj.IsLine = ctArhRoofSeg then FSCS_Main.aNetProps.Visible := true else FSCS_Main.aNetProps.Visible := false; end else FSCS_Main.aNetProps.Visible := false; if Assigned(ArchSubObj) then begin if (ArchSubObj.IsLine = ctArhRoofHip) then begin FSCS_Main.DefinePMItemsRoofHipTypes; ShowHideMenuItemsList(FSCS_Main.FPMItemsRoofHipTypes, true); SetCheckToMenuItemList(FSCS_Main.FPMItemsRoofHipTypes, ArchSubObj.GetPropertyValueAsInteger(pnRoofHipType)); end else ShowHideMenuItemsList(FSCS_Main.FPMItemsRoofHipTypes, false); end else ShowHideMenuItemsList(FSCS_Main.FPMItemsRoofHipTypes, false); SelectComponInPM(FCADListID, Path.FComponID); //16.12.2011 FSCS_Main.pmArchDesign.Popup(Point.X, Point.Y); end else begin if ((ArchSubObj = nil) or (ArchSubObj.IsLine <> ctArhRoofHip)) and (FSCS_Main.FPMItemsRoofHipTypes <> nil) then ShowHideMenuItemsList(FSCS_Main.FPMItemsRoofHipTypes, false); end; // Для колонны if Net.SelCol <> nil then begin FSCS_Main.aDeleteWallPath.Visible := False; FSCS_Main.aDeleteWallRect.Visible := True; FSCS_Main.aDivSelPath.Visible := False; FSCS_Main.aSetWallPathWidth.Visible := False; FSCS_Main.aSetAllWallPathWidth.Visible := False; FSCS_Main.aAddWindow.Visible := False; FSCS_Main.aAddDoor.Visible := False; FSCS_Main.aSetCornHeight.Visible := True; // Tolik 04/09/2018 -- высота угла стены для архитектуры FSCS_Main.aSetDoorWindowPllacementHeight.Visible := False; FSCS_Main.aSetDoorWndH.Visible := False; FSCS_Main.aAddColumn.Visible := False; FSCS_Main.aDeleteWindowDoor.Visible := False; FSCS_Main.aDeleteColumn.Visible := True; FSCS_Main.aSetSizeWindowDoor.Visible := False; FSCS_Main.aSetColumnAngle.Visible := True; FSCS_Main.aSetColumnHeight.Visible := True; FSCS_Main.aSetColumnWidth.Visible := True; FSCS_Main.aSetPathLineWidth.Visible := False; FSCS_Main.aSetPathLineStyle.Visible := False; FSCS_Main.aSetAllPathLineWidth.Visible := False; FSCS_Main.aSetAllPathLineStyle.Visible := False; FSCS_Main.aWallPathShowLength.Visible := False; FSCS_Main.pmArchDesign.Popup(Point.X, Point.Y); end; end else begin GPopupFigure := PCad.CheckByPoint(PCad.ActiveLayer, X, Y); //pmObjectsForArchPrepare; //FSCS_Main.aFreeRotate.Visible := True; pmObjectsPrepare; FSCS_Main.pmObject.Popup(Point.X, Point.Y); end; end else begin TNetCount := 0; // Проверяем все ли объекты TNet for i := 0 to PCad.SelectedCount - 1 do if CheckFigureByClassName(TFigure(PCad.Selection.Items[i]), 'TNet') then TNetCount := TNetCount + 1; if TNetCount = PCad.SelectedCount then begin pmObjectsForArchPrepare; //FSCS_Main.aFreeRotate.Visible := True; FSCS_Main.pmObject.Popup(Point.X, Point.Y); end else begin pmObjectsPrepare; FSCS_Main.pmObject.Popup(Point.X, Point.Y); end; end; end; // для обьектов СКС if PCad.ActiveLayer = 2 then begin try if GCadForm.PCad.SelectedCount = 1 then GPopupFigure := TFigure(GCadForm.PCad.Selection[0]) else GPopupFigure := CheckBySCSObjects(X, Y); except GPopupFigure := nil; exit; end; if GPopupFigure <> nil then begin GPopupFigure.Select; if aAllowSelectInPM then ShowObjectInPM(GPopupFigure.ID, ''); RefreshCAD(PCad); end else exit; //Tolik 02/03/2021 -- схема однолинейная на щитке (для электрики) FSCS_Main.pmiOneLineCheme.Visible := False; if CheckFigureByClassName(GPopupFigure, cTConnectorObject) then if TConnectorObject(GPopupFigure).ConnectorType = ct_NB then begin FigCatalog := F_ProjMan.GSCSBase.CurrProject.CurrList.GetCatalogFromReferencesBySCSID(GPopupFigure.ID); if FigCatalog <> nil then begin FirstCompon := FigCatalog.GetFirstComponent; if FirstCompon <> nil then begin if FirstCompon.ComponentType.SysName = ctsnShield then if FirstCompon.IDNetType = 3 then FSCS_Main.pmiOneLineCheme.Visible := True; end; end; end; // if CheckFigureByClassName(GPopupFigure, cTOrthoLine) then begin SetMenuItemsForOrthoLine(TOrthoLine(GPopupFigure)); FSCS_Main.pmSCSObject.Popup(Point.X, Point.Y); FSCS_Main.pmSCSObject.HelpContext := 74001; end else if CheckFigureByClassName(GPopupFigure, cTConnectorObject) and (not TConnectorObject(GPopupFigure).FIsApproach) then begin FSCS_Main.pmiSCSObjDivTracesOnRoowWalls.Visible := false; //13.03.2013 FSCS_Main.aDivTracesOnRoowWalls.Visible := false; FSCS_Main.pmiSCSObjAutoCreateTraces.Visible := true; //13.03.2013 FSCS_Main.aAutoCreateTraces.Visible := true; if (TConnectorObject(GPopupFigure).ConnectorType = ct_Clear) then begin if (not TConnectorObject(GPopupFigure).FIsHouseJoined) then begin SetMenuItemsForConnector(TConnectorObject(GPopupFigure)); FSCS_Main.pmSCSObject.Popup(Point.X, Point.Y); end; end else begin SetMenuItemsForObject(TConnectorObject(GPopupFigure)); FSCS_Main.pmSCSObject.Popup(Point.X, Point.Y); end; FSCS_Main.pmSCSObject.HelpContext := 74004; end // THOUSE else if CheckFigureByClassName(GPopupFigure, cTHouse) then begin FSCS_Main.pmiHDInsertKnotForHouse.Visible := True; FSCS_Main.pmiHDDeleteKnotForHouse.Visible := True; FSCS_Main.pmiHDAddApproach.Visible := True; FSCS_Main.pmiHDEditApproach.Visible := False; FSCS_Main.pmiHDRotateApproach.Visible := False; FSCS_Main.pmiHDModApproach.Visible := False; FSCS_Main.pmiHDDeleteHouse.Visible := True; if THouse(GPopupFigure).AsEndPoint then begin FSCS_Main.pmiHDServerAsDefault.Visible := False; FSCS_Main.pmiHDNotAsServerDefault.Visible := True; end else begin FSCS_Main.pmiHDServerAsDefault.Visible := True; FSCS_Main.pmiHDNotAsServerDefault.Visible := False; end; FSCS_Main.pmHouseDesign.Popup(Point.X, Point.Y); end // TApproach else if CheckFigureByClassName(GPopupFigure, cTConnectorObject) and (TConnectorObject(GPopupFigure).FIsApproach) then begin FSCS_Main.pmiHDInsertKnotForHouse.Visible := False; FSCS_Main.pmiHDDeleteKnotForHouse.Visible := False; FSCS_Main.pmiHDAddApproach.Visible := False; FSCS_Main.pmiHDEditApproach.Visible := True; FSCS_Main.pmiHDRotateApproach.Visible := True; FSCS_Main.pmiHDModApproach.Visible := True; FSCS_Main.pmiHDDeleteHouse.Visible := False; if TConnectorObject(GPopupFigure).AsEndPoint then begin FSCS_Main.pmiHDServerAsDefault.Visible := False; FSCS_Main.pmiHDNotAsServerDefault.Visible := True; end else begin FSCS_Main.pmiHDServerAsDefault.Visible := True; FSCS_Main.pmiHDNotAsServerDefault.Visible := False; end; FSCS_Main.pmHouseDesign.Popup(Point.X, Point.Y); end else if CheckFigureByClassName(GPopupFigure, cTSCSFigureGrp) then begin //SetMenuItemsForConnector(TConnectorObject(GPopupFigure)); ShowHideMenuItems(FSCS_Main.pmSCSObject, false, false); FSCS_Main.pmiSCSObjFreeRotate.Visible := true; FSCS_Main.pmiSCSObjRotatePointObject90.Visible := true; FSCS_Main.pmiSCSObjRotatePointObject270.Visible := true; FSCS_Main.pmiSCSObjRotatePointObject180.Visible := true; FSCS_Main.pmiSCSObjProperties.Visible := true; FSCS_Main.pmSCSObject.Popup(Point.X, Point.Y); end; end; end; except on E: Exception do addExceptionToLogEx('TF_CAD.FormCADPopupMenu', E.Message); end; end; procedure TF_CAD.PCadSurfaceClick(Sender: TObject); var IDCompon: integer; isNormalMode: Boolean; ClickFigure: TFigure; //21.06.2013 FiguresList: TList; Item: TMenuItem; i: integer; FFigure: TFigure; Point: TPoint; FHeightStr: string; Button: TMouseButton; SelList: TList; FIsRaiseLineFigure: TFigure; Coord1, Coord2: Double; Net: TNet; // Tolik 24/04/2018 *-- MyMouse: TMouse; tt: TPoint; x,y,z: Double; // Tolik 24/03/2021 -- SCSCatalog: TSCSCatalog; SCSCompon: TSCSComponent; isElCompon: Boolean; CLickFigureSelected: Boolean; // // Compon: TSCSComponent; // Tolik 19/03/2021 -- // SCSCatalog: TSCSCatalog; // Tolik 19/03/2021 -- function CheckNormBaseELCableSelected: Boolean; begin Result := False; //if not TConnectorObject(ClickFigure).AsEndPoint then if F_NormBase.GSCSBase.SCSComponent <> nil then if F_NormBase.GSCSBase.SCSComponent.ID <> 0 then if isCableComponent(F_NormBase.GSCSBase.SCSComponent) then if F_NormBase.GSCSBase.SCSComponent.IDNetType = 3 then Result := True; end; procedure BuildpmELObjMenu; // Tolik 24/03/2021 -- var CableSelected, isShiled, isElComponent: Boolean; function CheckConnectByCableEnds: Boolean; var i, NbCount: integer; begin Result := True; if PCad.Selection.Count > 1 then begin NbCount := 0; for i := 0 to PCad.Selection.Count - 1 do begin if TFigure(PCad.Selection[i]) is TConnectorObject then if not TConnectorObject(PCad.Selection[i]).deleted then if TConnectorObject(PCad.Selection[i]).ConnectorType = ct_NB then inc(NbCount); end; Result := not (NbCount > 1); end; end; Procedure CheckElComponent; var SCSCatalog: TSCSCatalog; SCSComponent: TSCSComponent; function CheckNoRaspredBox(aFigure: Tfigure): boolean; var i, j: integer; RaiseLine, vLine1, vLine2: TOrthoLine; JoinedConn, NB_Conn, VLine1Conn, VLine2Conn: TConnectorObject; vLinesList, ConnList, PassedList: TList; function CheckNoRaspredBoxOnConn(aConn: TConnectorObject): Boolean; var SCSCatalog: TSCSCatalog; SCSCompon : TSCSComponent; i: integer; begin Result := True; SCSCatalog := F_ProjMan.GSCSBase.CurrProject.CurrList.GetCatalogFromReferencesBySCSID(aConn.ID); if SCSCatalog <> nil then begin for i := 0 to SCSCatalog.ComponentReferences.Count - 1 do begin if SCSCatalog.ComponentReferences[i].ComponentType.SysName = ctsnTerminalBox then begin Result := False; break; end; end; end; end; Procedure FillConnListByVLine(aPrevConn, aNextConn: TConnectorObject; aList: TList); var PrevConn, NextConn: TConnectorObject; begin //18/08/2022 end; begin Result := false; RaiseLine := nil; vLine1 := nil; vLine2 := nil; vLinesList := nil; ConnList := nil; VLine1Conn := nil; VLine2Conn := nil; if CheckFigureByClassName(aFigure, cTConnectorObject) then begin if TConnectorObject(aFigure).ConnectorType = ct_NB then begin Result := True; //seek Raise/vert Lines for i := 0 to TConnectorObject(aFigure).JoinedConnectorsList.Count - 1 do begin JoinedConn := TConnectorObject(aFigure).JoinedConnectorsList[i]; for j := 0 to JoinedConn.JoinedOrtholinesList.Count - 1 do begin if TOrthoLine(JoinedConn.JoinedOrtholinesList[j]).FIsRaiseUpDown then begin RaiseLine := TOrthoLine(JoinedConn.JoinedOrtholinesList[j]); break; end else begin if TOrthoLine(JoinedConn.JoinedOrtholinesList[j]).FIsVertical then begin if vLine1 = nil then begin vLine1 := TOrthoLine(JoinedConn.JoinedOrtholinesList[j]); VLine1Conn := JoinedConn; end else begin vLine2 := TOrthoLine(JoinedConn.JoinedOrtholinesList[j]); VLine2Conn := JoinedConn; break; end; end; end; end; if RaiseLine <> nil then break; if vLine2 <> nil then break; end; //check for RaspredBox if RaiseLine <> nil then // CheckOnRaise begin if RaiseLine.JoinConnector1.ID = JoinedConn.ID then JoinedConn := TConnectorObject(RaiseLine.JoinConnector2) else JoinedConn := TConnectorObject(RaiseLine.JoinConnector1); if JoinedConn.JoinedConnectorsList.Count > 0 then begin NB_Conn := TConnectorObject(JoinedConn.JoinedConnectorsList); if NB_Conn.ConnectorType = ct_NB then Result := CheckNoRaspredBoxOnConn(NB_Conn); end; end else begin // check on all Vertical Connections if vLine1 <> nil then begin vLinesList := TList.Create; ConnList := TList.Create; vLinesList.Add(VLine1); if vLine1.JoinConnector1.ID = VLine1Conn.Id then FillConnListByVLine(TConnectorObject(vLine1.JoinConnector1), TConnectorObject(vLine1.JoinConnector2), ConnList) else FillConnListByVLine(TConnectorObject(vLine1.JoinConnector2), TConnectorObject(vLine1.JoinConnector1), ConnList); end; if vLine2 <> nil then begin vLinesList.Add(VLine2); if vLine2.JoinConnector1.ID = VLine2Conn.Id then FillConnListByVLine(TConnectorObject(vLine2.JoinConnector1), TConnectorObject(vLine2.JoinConnector2), ConnList) else FillConnListByVLine(TConnectorObject(vLine2.JoinConnector2), TConnectorObject(vLine2.JoinConnector1), ConnList); end; if ConnList <> nil then begin for i := 0 to ConnList.Count - 1 do begin Result := CheckNoRaspredBoxOnConn(TConnectorObject(ConnList[i])); if not Result then break; end; end; end; end; end; end; begin //Result := False; SCSCatalog := F_ProjMan.GSCSBase.CurrProject.CurrList.GetCatalogFromReferencesBySCSID(ClickFigure.ID); if SCSCatalog <> nil then begin SCSComponent := SCSCatalog.GetFirstComponent; if SCSComponent <> nil then begin if SCSComponent.IDNetType = 3 then begin isElComponent := True; if SCSComponent.ComponentType.SysName = ctsnShield then isShiled := True; if SCSComponent.ComponentType.SysName = ctsnPlugSwitch then begin if CheckNoRaspredBox(ClickFigure) then begin GPlugSwitch := ClickFigure; //FSCS_Main.mnuInstRaspredBox.Visible := True; FSCS_Main.aInstRaspredBox.Visible := True; end else FSCS_Main.aInstRaspredBox.Visible := False; end else //FSCS_Main.mnuInstRaspredBox.Visible := False; FSCS_Main.aInstRaspredBox.Visible := False; end; end; end; end; begin //FSCS_Main.mnuInstRaspredBox.Visible := False; //Tolik 21/06/2022 -- FSCS_Main.aInstRaspredBox.Visible := False; //Tolik 21/06/2022 -- FSCS_Main.mnuSelTraceCable.Visible := False; FSCS_Main.mnuConnectByCable.Visible := False; FSCS_Main.mnuConnectByCableEnds.Visible := False; FSCS_Main.mnuAsServer.Visible := False; FSCS_Main.mnuAsNoServer.Visible := False; FSCS_Main.mnuInstRaspredBox.Visible := False; { FSCS_Main.mnuRot90.Visible := False; FSCS_Main.mnuRot180.Visible := False; FSCS_Main.mnuRot270.Visible := False; } FSCS_Main.mnuOnLineSC.Visible := False; FSCS_Main.mnuShieldAssemblySH.Visible := False; //Tolik 04/01/2023 FSCS_Main.mnuRotObj.Visible := False; CableSelected := CheckNormBaseELCableSelected; isShiled := False; isElComponent := False; if (ssShift in GGlobalShiftState) or (ssCtrl in GGlobalShiftState) then exit; if GCadForm.PCad.TraceFigure <> nil then exit; if assigned(F_SCSObjectsProp) then if F_SCSObjectsProp.Showing then exit; CheckElComponent; //Cable to trace if isElComponent then begin FSCS_Main.mnuRotObj.Visible := True; { FSCS_Main.mnuRot90.Visible := True; FSCS_Main.mnuRot180.Visible := True; FSCS_Main.mnuRot270.Visible := True; } if isShiled then begin FSCS_Main.mnuOnLineSC.Visible := True; FSCS_Main.mnuShieldAssemblySH.Visible := True; // Tolik 04/01/2023 -- end else begin FSCS_Main.mnuOnLineSC.Visible := False; // на всякий FSCS_Main.mnuShieldAssemblySH.Visible := False; //Tolik 04/01/2023 -- end; if TConnectorObject(ClickFigure).AsEndPoint then begin FSCS_Main.mnuAsServer.Visible := False; FSCS_Main.mnuAsNoServer.Visible := True; end else begin FSCS_Main.mnuAsServer.Visible := True; FSCS_Main.mnuAsNoServer.Visible := False; end; if CableSelected then begin FSCS_Main.mnuSelTraceCable.Visible := False; if isShiled then FSCS_Main.mnuConnectByCable.Visible := False else FSCS_Main.mnuConnectByCable.Visible := True; if CheckConnectByCableEnds then FSCS_Main.mnuConnectByCableEnds.Visible := True; end else begin FSCS_Main.mnuSelTraceCable.Visible := True; FSCS_Main.mnuConnectByCable.Visible := False; FSCS_Main.mnuConnectByCableEnds.Visible := False; end; end else begin FSCS_Main.mnuSelTraceCable.Visible := False; FSCS_Main.mnuConnectByCable.Visible := False; FSCS_Main.mnuConnectByCableEnds.Visible := False; end; end; begin try CheckCloseReportForm; // Tolik 30/04/2021 -- //Tolik if not GisMouseDown then GisMouseDown := True; // // // Tolik 24/04/2018 -- если не клик, а маусАП после драга, то нах отсюда (если маусклик от маусапа больше чем на 2 по любой координате) { tt.x := MyMouse.CursorPos.X; tt.y := MyMouse.CursorPos.Y; tt := PCad.Container.ScreenToClient(tt); x := tt.x; y := tt.y; z := 0; PCad.DeConvertXY(X, Y, Z); if ((CompareValue (ABS(X - PCad.RPushPoint.X), 2) = 1) or (CompareValue (ABS(Y - PCad.RPushPoint.Y), 2) = 1)) then exit; } // GCanRefreshProperties := True; if not PCad.Focused then if (PCad.ToolIdx = toSelect) {and (PCad.SelectedCount = 0)} then begin SelList := TList.Create; for i := 0 to PCad.SelectedCount - 1 do SelList.Add(TFigure(PCad.Selection[i])); if FSCS_Main.tbCADToolsExpert.Visible then begin if FSCS_Main.cbScaleExpert.Enabled then FSCS_Main.cbScaleExpert.SetFocus end else begin if FSCS_Main.cbScaleNoob.Enabled then FSCS_Main.cbScaleNoob.SetFocus; end; SendMessage(Self.Handle, WM_ACTIVATE, MakewParam(WA_ACTIVE, 0), 0); SendMessage(Self.Handle, WM_SETFOCUS, 0, 0); for i := 0 to SelList.Count - 1 do TFigure(SelList[i]).Select; RefreshCAD_T(PCad); FreeAndNil(SelList); end; if (GetKeyState(VK_LBUTTON) and 128) = 0 then //14.03.2011 Button := mbLeft; //14.03.2011 // нажата левая кнопка, для выделения с-п !!! if ((GetKeyState(VK_LBUTTON) and 128) = 0) and (PCad.ToolIdx = toSelect) and (not PCad.IsDragging) then begin try FIsRaiseLineFigure := CheckBySCSObjects(GCurrMousePos.x, GCurrMousePos.y); except FIsRaiseLineFigure := nil; end; if FIsRaiseLineFigure <> nil then begin if PCad.ActiveLayer = 2 then if CheckFigureByClassName(FIsRaiseLineFigure, cTOrthoLine) then if TOrthoLine(FIsRaiseLineFigure).FIsRaiseUpDown then begin FIsRaiseLineFigure.Select; RefreshCAD(PCad); end; end; end; // SELECT IN PM if FClickType = ct_Single then begin try ClickFigure := CheckBySCSObjects(GCurrMousePos.x, GCurrMousePos.y); except ClickFigure := nil; end; // поиск других объектов на данной высоте //21.06.2013 - поиск объектов в одной точке выполняется в TF_CAD.PCadGetFigureToSelect // if GFigureSnap = nil then // if (PCad.ToolIdx = toSelect) and (not GCadForm.FCreateObjectOnClick) then // if PCad.SelectedCount = 1 then // begin // FiguresList := GetFiguresByLevel(ClickFigure, GCurrMousePos.x, GCurrMousePos.y, False, true); // // формировать список объектов // if FiguresList.Count > 1 then // begin // GetCursorPos(Point); // //FSCS_Main.pmFiguresByLevel.Items.Clear; // // for i := 0 to FiguresList.Count - 1 do // // begin // // FFigure := TFigure(FiguresList[i]); // // Item := TMenuItem.Create(FSCS_Main.pmFiguresByLevel); // // FHeightStr := ''; // // if CheckFigureByClassName(FFigure, cTOrthoLine) then // // if TOrthoLine(FFigure).ActualZOrder[1] = TOrthoLine(FFigure).ActualZOrder[2] then // // FHeightStr := FormatFloat(ffMask, MetreToUOM(TOrthoLine(FFigure).ActualZOrder[1])) // // else // // FHeightStr := FormatFloat(ffMask, MetreToUOM(TOrthoLine(FFigure).ActualZOrder[1])) + '-' + // // FormatFloat(ffMask, MetreToUOM(TOrthoLine(FFigure).ActualZOrder[2])); // // if CheckFigureByClassName(FFigure, cTConnectorObject) then // // FHeightStr := FormatFloat(ffMask, MetreToUOM(TConnectorObject(FFigure).ActualZOrder[1])); // // Item.Caption := GetFullFigureName(FFigure) + ' (' + FHeightStr + GetUOMString(GCurrProjUnitOfMeasure) + ')' ; // // FSCS_Main.pmFiguresByLevel.Items.Add(Item); // // Item.Tag := FFigure.ID; // // Item.OnClick := SelectFigureEvent; // // end; // BuildPopupFiguresByLevel(FiguresList, SelectFigureEvent); // FSCS_Main.pmFiguresByLevel.Popup(Point.X, Point.Y); // end; // FreeAndNil(FiguresList); // end; /////////////////////////////////////// // Tolik 24/03/2021 -- вот тут переделано чуть совсем, чтобы пр клике на объекте электрики, можно было на нем вывести како-нибуддь меню.... { //21.06.2013 if ClickFigure <> nil then if FClickSCSFiguresList.Count > 1 then if FClickSCSFiguresList.IndexOf(ClickFigure) <> -1 then begin // Tolik 12/04/2018 -- for i := (FClickSCSFiguresList.Count - 1) downto 0 do begin if CheckFigureByClassName(TFigure(FClickSCSFiguresList[i]), cTOrthoLine) then if TOrthoLine(FClickSCSFiguresList[i]).FisVertical then FClickSCSFiguresList.delete(i); end; // BuildPopupFiguresByLevel(FClickSCSFiguresList, SelectFigureEvent); FClickSCSFiguresList.Clear; GetCursorPos(Point); FSCS_Main.pmFiguresByLevel.Popup(Point.X, Point.Y); end; } if ClickFigure <> nil then begin CLickFigureSelected := ClickFigure.Selected; if FClickSCSFiguresList.Count > 1 then begin if FClickSCSFiguresList.IndexOf(ClickFigure) <> -1 then begin // Tolik 12/04/2018 -- for i := (FClickSCSFiguresList.Count - 1) downto 0 do begin if CheckFigureByClassName(TFigure(FClickSCSFiguresList[i]), cTOrthoLine) then if TOrthoLine(FClickSCSFiguresList[i]).FisVertical then FClickSCSFiguresList.delete(i); end; // BuildPopupFiguresByLevel(FClickSCSFiguresList, SelectFigureEvent); FClickSCSFiguresList.Clear; GetCursorPos(Point); //Tolik 26/02/2022 -- //FSCS_Main.pmFiguresByLevel.Popup(Point.X, Point.Y); GpopupMenu := FSCS_Main.pmFiguresByLevel; gx := Point.X; gy := Point.Y; TimerShowPopup.Enabled := True; // end; end else begin // одна совсем... if (PCad.ActiveLayer = 2) and (PCad.ToolIdx = toSelect) then begin if CheckFigureByClassName(ClickFigure, cTConnectorObject) then begin isElCompon := False; SCSCatalog := F_ProjMan.GSCSBase.CurrProject.CurrList.GetCatalogFromReferencesBySCSID(ClickFigure.Id); if SCSCatalog <> nil then begin SCSCompon := SCSCatalog.GetFirstComponent; if SCSCompon <> nil then begin if SCSCompon.IDNetType = 3 then isElCompon := True; end; end; if isELCompon then begin FClickSCSFiguresList.Clear; GetCursorPos(GPopupPoint); //FSCS_Main.pmFiguresByLevel.Popup(Point.X, Point.Y); if GPCadPrevSelCount = 0 then // Tolik 24/07/2021 -- //if CLickFigureSelected then begin BuildpmELObjMenu; GPopupFigure := ClickFigure; //Tolik 26/02/2022 -- //FSCS_Main.pmELObjMenu.Popup(GPopupPoint.X, GPopupPoint.Y); FSCS_Main.pmELObjMenu.Popup(GPopupPoint.X, GPopupPoint.Y); {gx := GPopupPoint.X; gy := GPopupPoint.Y; GPopupMenu := FSCS_Main.pmELObjMenu; TimerShowPopup.Enabled := True; } // end; end //Tolik 16/08/2021 -- else // если комп шкаф begin if CheckSCSRack(ClickFigure) then begin //if CLickFigureSelected then if GPCadPrevSelCount = 0 then // Tolik 24/07/2021 -- begin GetCursorPos(GPopupPoint); GPopupFigure := ClickFigure; FSCS_Main.pmiAsDefaultServer.Visible := False; FSCS_Main.pmiSelectFiberCableToTrace.Visible := False; FSCS_Main.pmiConnectToAnotherRack.Visible := False; if not TConnectorObject(ClickFigure).AsEndPoint then begin FSCS_Main.pmiAsDefaultServer.Visible := True; FSCS_Main.pmiAsDefaultServer.Enabled := True; end; if CheckNormBaseSCSCableSelected then begin FSCS_Main.pmiConnectToAnotherRack.Visible := True; FSCS_Main.pmiConnectToAnotherRack.Enabled := True end else begin FSCS_Main.pmiSelectFiberCableToTrace.Visible := True; FSCS_Main.pmiSelectFiberCableToTrace.Enabled := True; end; //Tolik 26/02/2022 -- //FSCS_Main.pmSCSRack.Popup(GPopupPoint.X, GPopupPoint.Y); gx := GPopupPoint.X; gy := GPopupPoint.Y; GPopupMenu := FSCS_Main.pmSCSRack; TimerShowPopup.Enabled := True; // end; //FSCS_Main.pmSCSRack.Popup(Round(TConnectorObject(ClickFigure).Ap1.x), Round(TConnectorObject(ClickFigure).Ap1.y)); end; end; // end; end; end; end; ////////////////////////////////////////////// // просто компонента if ClickFigure <> nil then begin if PCad.ActiveLayer = 2 then if (F_ProjMan <> nil) and (F_NormBase <> nil) then if PCad.ToolIdx = toSelect then begin //Tolik 29/04/2021 -- if ClickFigure.Selected then begin // if CheckFigureByClassName(ClickFigure, cTConnectorObject) and (TConnectorObject(ClickFigure).FIsApproach) then SelectComponInPM(FCADListID, TConnectorObject(ClickFigure).FComponID) else ShowObjectInPM(ClickFigure.ID, ClickFigure.Name); end; end; end; // if PCad.ActiveLayer = lnArch then if (F_ProjMan <> nil) and (F_NormBase <> nil) then if PCad.ToolIdx = toSelect then begin ClickFigure := nil; //if (PCad.Selection.Count = 1) and (TObject(PCad.Selection[0]) is TNet) then //begin // Net := TNet(PCad.Selection[0]); // if (Net.SelPath <> nil) and (Net.SelPath.IsPointIn(GCurrMousePos.x, GCurrMousePos.y)) then // ClickFigure := Net; //end; if ClickFigure = nil then ClickFigure := PCad.CheckByPoint(8, GCurrMousePos.x, GCurrMousePos.y); if ClickFigure <> nil then begin SelectComponInPM(FCADListID, ClickFigure.ID); if ClickFigure is TNet then begin TNet(ClickFigure).DoClick(GCurrMousePos.x, GCurrMousePos.y); end; end; end; end; // commented by Tolik 12/03/2021 -- // Создавать объекты при клике isNormalMode := False; if PCad.ToolIdx = toSelect then if IsClickOnFigure then isNormalMode := True; // РЕЖИМ СОЗДАНИЯ ОБЪЕКТОВ ПРИ КЛИКЕ if FCreateObjectOnClick and isNormalMode then //if FCreateObjectOnClick then begin IDCompon := F_NormBase.GSCSBase.SCSComponent.ID; if IDCompon <> 0 then begin CheckFigure := CheckBySCSObjects(DownPoints.x,DownPoints.y); // положить комплектующую CreateOnClickMode(GFigureTraceTo, F_NormBase.GSCSBase.SCSComponent, GCurrMousePos.x, GCurrMousePos.y); // DrawGuidesOnDrop(DownPoints.x,DownPoints.y); ShowHintIFFigInsideCab(DownPoints.x,DownPoints.y); If CheckFigure <> nil then CheckFigure := nil; end else begin ShowMessage(cCad_Mes16); mProtocol.Lines.EndUpdate; end; end; // Tolik 19/03/2021 -- (* if Button = mbLeft then begin if GAutoAddCableAfterDragDrop then begin if (F_NormBase.GSCsBase.SCSComponent <> nil) and (F_NormBase.GSCsBase.SCSComponent.ID <> 0) and (isCableComponent(F_NormBase.GSCsBase.SCSComponent)) and (F_NormBase.GSCsBase.SCSComponent.IDNetType = 3) then begin if ClickFigure <> nil then begin if ClickFigure is TConnectorObject then begin SCSCatalog := F_ProjMan.GSCSBase.CurrProject.CurrList.GetCatalogFromReferencesBySCSID(ClickFigure.ID); if SCSCatalog <> nil then begin Compon := SCSCatalog.GetFirstComponent; if Compon <> nil then begin if Compon.ComponentType.SysName = ctsnShield then begin if Compon.IDNetType = 3 then begin if GSnapFiguresList.Count > 0 then begin //OnMouseUp(Self, Button, Shift, X, Y); //OnMouseUp(PCad, mbRight, GGlobalShiftState, Round(x), Round(y)); // OnMouseUp(PCad, mbRight, GGlobalShiftState, Round(ClickFigure.Ap1.x), Round(ClickFigure.AP1.y)); //OnMouseUp(PCad, mbRight, GGlobalShiftState, 0, 0); //SendMessage(Self.Handle, WM_LBUTTONDOWN, 0, 0); SendMessage(Self.Handle, WM_RBUTTONUP, 0, 0); { //GCadForm.OnMouseUp; if TFigure(GSnapFiguresList[GSnapFiguresList.Count - 1]) = nil then begin GSnapFiguresList.Add(ClickFigure); Inc(GClickIndex); end else begin if TFigure(GSnapFiguresList[GSnapFiguresList.Count - 1]).ID <> ClickFigure.Id then GSnapFiguresList.Add(ClickFigure); Inc(GClickIndex); end; ClickFigure.Select;} end; //PCad.EndTrace(GGlobalShiftState); end; end; end; end; end; end; end; end; end; *) if (PCad.ToolIdx = toSelect) and (Button = mbLeft) then begin RefreshCAD_T(PCad); end; // Tolik 11/06/2021 -- if Button = mbRight then begin if ClickFigure = nil then begin if PCad.ActiveLayer = lnSCSCommon then begin FCreateObjectOnClick := False; PCad.DeselectAll(2); PCad.SetTool(toSelect, 'TSelected'); PCad.Refresh; end; end; end; // except on E: Exception do addExceptionToLogEx('TF_CAD.PCadSurfaceClick', E.Message); end; //if GReadOnlyMode then //begin // for i := 0 to PCad.Figures.Count - 1 do // begin // TFigure(PCad.Figures[i]).LockModify := True; // TFigure(PCad.Figures[i]).LockMove := True; // TFigure(PCad.Figures[i]).LockSelect := True; // end; //end; { Вот это низзя ... - влупит еще один клик на КАД !!! if ClickFigure <> nil then begin if ((ClickFigure is TConnectorObject) or (ClickFigure is TOrthoLine)) then begin F_ProjMan.Tree_Catalog.Refresh; Application.ProcessMessages; end; end; } GPCadPrevSelCount := 0; end; procedure TF_CAD.SelectFigureEvent(Sender: TObject); var ID: Integer; FFigure: TFigure; begin try ID := TMenuItem(Sender).Tag; FFigure := GetFigureByID(GCadForm, ID); PCad.DeselectAll(2); FFigure.Select; PCad.RecordUndo := True; PCad.OrderSelection(osFront); PCad.RecordUndo := False; ShowObjectInPM(FFigure.ID, FFigure.Name); except on E: Exception do addExceptionToLogEx('TF_CAD.SelectFigureEvent', E.Message); end; end; procedure TF_CAD.DropFigureEvent(Sender: TObject); var ID: Integer; FFigure: TFigure; X, Y: Double; begin try ID := TMenuItem(Sender).Tag; FFigure := GetFigureByID(GCadForm, ID); GFigureSnap := FFigure; ShowObjectInPM(FFigure.ID, FFigure.Name); X := GCurrMousePos.x; Y := GCurrMousePos.y; DoDragDrop(X, Y); except on E: Exception do addExceptionToLogEx('TF_CAD.DropFigureEvent', E.Message); end; end; procedure TF_CAD.NewWndProc(var Message: TMessage); begin { if Message.msg = WM_SETCURSOR then beep;} end; procedure TF_CAD.DoDragDrop(X, Y: Double; aOnDropRoute: TFigure = nil; aTraceOnEntireRoute: boolean = False); var DropFigure: TFigure; StateType: TCompStateType; ComponID: integer; i, j, k, l: integer; isConnected: Boolean; GetRaiseLine: TOrthoLine; CurGCadForm: TF_CAD; IDLine: Integer; SaveSnapToGrid: Boolean; TracingCount: Integer; SelList: TList; NearTracedLine: TOrthoLine; TraceIDs: TIntList; //#From Oleg# ListOfLists: TIntList; vLists: TList; vList: TF_CAD; RaiseConn: TConnectorObject; EndPoint: TConnectorObject; Traces: TList; OldEndPoint: TFigure; IsCreateObjectOnClickTool: Boolean; SCSList: TSCSList; SCSCompon: TSCSComponent; InputMarkRes: Integer; PrevMark: string; SnapFigureConnected: boolean; resChoice: boolean; OldParam: boolean; Trace: TOrthoLine; isBetweenFloor: boolean; BreakCheck: boolean; AllConnectedTraces: TList; RackFound: boolean; SCSCatalog: TSCSCatalog; isObjectRack: boolean; FigureID: integer; NeedSelFigure: boolean; FOnDropFigure: TFigure; NeedExclTraces: boolean; jj: integer; //Tolik Old_proc : TWndMethod; CableIsMulti: Boolean; SavedGFigureSnap: TFigure; // -- чтобы записать на всякий GFigureSnap PCadNeedRefreshFlag: Boolean; // // Tolik 03/03/2021 -- GConn: TConnectorObject; SCSComponent: TSCScomponent; SCatalog : TSCSCatalog; FCallAutoTraceElectricMaster: Boolean; AllTrace: TList; itWasShift: Boolean; // Tolik 05/01/2022 WasEnbledAction: Boolean; // RefreshFlag: Boolean; // Tolik 11/11/2022 -- function CheckCanManualCableTrace: Boolean; var BetweenObjPath: TList; begin //Result := True; Result := True; if GEndPoint <> nil then begin if GFigureSnap <> nil then begin BetweenObjPath := GetAllTraceInCAD(GEndPoint, GFigureSnap); if BetweenObjPath <> nil then begin // тут, если есть путь до конечного объекта - ручную трассировку кабеля не включать, // чтобы сработало автоматическое подключение Result := False; BetweenObjPath.free; { Result := GCadForm.cbManualCableTracingMode.Down; BetweenObjPath.free; } end; end; end; end; function CheckCanTrace: Boolean; var SCSCatalog: TSCSCatalog; i: integer; begin Result := True; if ((PCad.Selection.Count = 0) and (GFigureSnap = nil)) then begin Result := False; exit; end; if GFigureSnap <> nil then begin if CheckFigureByClassName(GFigureSnap, cTConnectorObject) then begin if TConnectorObject(GFigureSnap).ConnectorType = ct_NB then begin Result := False; SCSCatalog := F_ProjMan.GSCSBase.CurrProject.CurrList.GetCatalogFromReferencesBySCSID(GFigureSnap.ID); if SCSCatalog <> nil then begin for i := 0 to SCSCatalog.ComponentReferences.Count - 1 do begin if SCSCatalog.ComponentReferences[i].IDNetType = GDropComponent.IDNetType then begin result := True; break; end; end; end; end; end; end; end; function SelectionResult(aList: TList): Integer; var i, j: integer; SCSCatalog: TSCSCatalog; begin Result := -1; if aList <> nil then begin Result := 2; for i := 0 to aList.Count - 1 do begin if Assigned(aList[i]) then begin if TFigure(aList[i]).Deleted = False then begin if checkFigureByClassName(TFigure(aList[i]), cTConnectorObject) then begin if TConnectorObject(aList[i]).ConnectorType = ct_Nb then begin SCSCatalog := F_ProjMan.GSCSBase.CurrProject.CurrList.GetCatalogFromReferencesBySCSID(TConnectorObject(aList[i]).ID); if SCSCatalog <> nil then begin for j := 0 to SCSCatalog.ComponentReferences.Count - 1 do begin if SCSCatalog.ComponentReferences[j].IDNetType = GDropComponent.IDNetType then begin Result := 1; break; end; end; end; end; end; end; end; end; end; end; Procedure ClearSelectionByDropComponType; var i, j: integer; SCSCatalog: TSCSCatalog; CanDel: Boolean; Figure: TFigure; begin if SelList <> nil then begin for i := SelList.Count - 1 downto 0 do begin CanDel := True; Figure := TFigure(SelList[i]); if not Figure.Deleted then begin if CheckFigureByClassName(Figure, cTConnectorObject) then begin if TConnectorObject(Figure).ConnectorType = ct_NB then begin SCSCatalog := F_ProjMan.GSCSBase.CurrProject.GetCatalogFromReferencesBySCSID(Figure.ID); if SCSCatalog <> nil then begin for j := 0 to SCSCatalog.ComponentReferences.Count - 1 do begin if SCSCatalog.ComponentReferences[j].IDNetType = GDropComponent.IDNetType then begin CanDel := False; break; end; end; end; end; end; end; if CanDel then begin PCad.Selection.Remove(Figure); Figure.Selected := False; selList.Delete(i); end; end; end; end; begin itWasShift := ssShift in GGlobalShiftState; // Tolik 05/01/2022 -- GisDrop := false; // Tolik 18/02/2022 -- на всякий... //GAutoAddCableAfterDragDrop := not cbManualCableTracingMode.Down; GAutoAddCableAfterDragDrop := cbManualCableTracingMode.Down; GCadForm.FisDragOver := False; // Tolik 29/03/2021 -- if F_NormBase.Tree_Catalog.Tag = 100 then begin Screen.Cursor := crDefault; exit; end; // Tolik -- 09/03/2017 -- vLists := nil; // try GisDrop := True; // Tolik 18/02/2022 -- ставим флаг, что идет дроп // Tolik 03/03/2021 -- трассировка кабелем для электрики //if GCallElectricAutoTraceMaster then //Tolik 09/02/2022 -- автоматически трассировать, если кинули на Кад виртуальный кабель (из виртуальных компонент) if (GDropComponent <> nil) and (isCableComponent(GDropComponent)) and (GDropComponent.IsTemplate = biTrue) then begin if GFigureSnap = nil then begin AutoCreateTracesMaster(nil); //29.06.2013 AutoCreateTraces; GisDrop := false; //Tolik 18/02/2022 -- GCadForm.PCad.Refresh; exit; end; end; // if GAutoAddCableAfterDragDrop then begin //GAutoAddCableAfterDragDrop := not cbManualCableTracingMode.Down; //if GAutoAddCableAfterDragDrop then begin if (GDropComponent <> nil) and (GFigureSnap <> nil) and (isCableComponent(GDropComponent)) and (GFigureSnap is TConnectorObject) then begin if GDropComponent.IDNetType = 3 then begin GConn := TConnectorObject(GFigureSnap); if GConn.ConnectorType = ct_Clear then if GConn.JoinedConnectorsList.Count > 0 then if TConnectorObject(GConn.JoinedConnectorsList[0]).ConnectorType = ct_NB then GConn := TConnectorObject(GConn.JoinedConnectorsList[0]); if GConn.ConnectorType = ct_NB then begin SCatalog := F_ProjMan.GSCSBase.CurrProject.CurrList.GetCatalogFromReferencesBySCSID(GConn.ID); if SCatalog <> nil then begin SCSComponent := SCatalog.GetFirstComponent; if SCSComponent <> nil then begin if SCSComponent.IDNetType = GDropComponent.IDNetType then begin if CheckCanManualCableTrace then begin GisDrop := false; FSCS_Main.aToolOrthoLine.Execute; //GAutoAddCableAfterDragDrop := True; //GSnapFiguresList.Add(GFigureSnap); PCad.SimulateDown(X,Y); PCad.SimulateUp(X, Y); GPrevFigureSnap := GFigureSnap; GFigureSnap := nil; GCadForm.FisDragOver := False; exit; end; end; end; end; end; end; end; end; end; // // дроп на Дизайн шкафа, добавить в шкаф GDragOnCAD := True; Traces := nil; OldEndPoint := nil; if FListType = lt_DesignBox then begin GisDrop := false; // Tolik 18/02/2022 -- DoFragDropDesigList; EndProgress; //Tolik Screen.Cursor := crDefault; exit; end; //Tolik Screen.Cursor := crHourGlass; F_NormBase.Tree_Catalog.Tag := 100; // Tolik Old_proc := F_NormBase.Tree_Catalog.WindowProc; F_NormBase.Tree_Catalog.WindowProc := NewWndProc; // RackFound := False; AllConnectedTraces := nil; isObjectRack := False; {IGOR} //D0000006296 if CheckFigureByClassName(GFigureSnap, cTOrthoLine) and (GDropComponent <> nil) and (GDropComponent.IsLine = 1) //and not CheckSysNameIsCableChannel(GDropComponent.ComponentType.SysName) then and CheckSysNameIsCable(GDropComponent.ComponentType.SysName) then begin if FNeedUpdateCheckedFigures then UpdateCheckedFigures; for i := 0 to FCheckedFigures.Count - 1 do begin if CheckFigureByClassName(FCheckedFigures[i], cTConnectorObject) then begin isObjectRack := False; SCSCatalog := F_ProjMan.GSCSBase.CurrProject.GetListBySCSID(TF_CAD(TConnectorObject(FCheckedFigures[i]).Owner.Owner).FCADListID).GetCatalogFromReferencesBySCSID(TConnectorObject(FCheckedFigures[i]).ID); if SCSCatalog <> nil then begin for k := 0 to SCSCatalog.SCSComponents.Count - 1 do begin if SCSCatalog.SCSComponents[k].ComponentType.SysName = ctsnCupboard then begin isObjectRack := true; break; end; if SCSCatalog.SCSComponents[k].ComponentType.SysName = ctsnBox then begin isObjectRack := true; break; end; end; end; if isObjectRack then begin AllConnectedTraces := GetAllTraceInCAD(TConnectorObject(FCheckedFigures[i]), TOrthoLine(GFigureSnap).JoinConnector1); if AllConnectedTraces <> nil then begin if AllConnectedTraces.Count > 0 then begin RackFound := True; break; end; freeandnil(AllConnectedTraces); end; end; end; end; if AllConnectedTraces <> nil then freeandnil(AllConnectedTraces); if RackFound then begin F_AutoTraceType.Panel1.Visible := True; F_AutoTraceType.RzGroupBox1.Visible := False; if F_AutoTraceType.ShowModal = mrCancel then begin F_AutoTraceType.Panel1.Visible := False; F_AutoTraceType.RzGroupBox1.Visible := True; //Tolik Screen.Cursor := crDefault; F_NormBase.Tree_Catalog.Tag := 0; F_NormBase.Tree_Catalog.WindowProc := Old_Proc; GisDrop := false; // Tolik 18/02/2022 -- exit; end; F_AutoTraceType.Panel1.Visible := False; F_AutoTraceType.RzGroupBox1.Visible := True; if F_AutoTraceType.cxRadioButton1.Checked then begin if (GEndPoint <> nil) then begin OldEndPoint := GEndPoint; TConnectorObject(GEndPoint).AsEndPoint := False; GEndPoint := nil; GListWithEndPoint := nil; end; FSCS_Main.SetFigureAsEndObject(GCadForm, TConnectorObject(FCheckedFigures[i])); FOnDropFigure := GFigureSnap; GFigureSnap := TConnectorObject(FCheckedFigures[i]); DoDragDrop(0, 0, FOnDropFigure, True); if OldEndPoint <> nil then begin if GEndPoint <> nil then TConnectorObject(GEndPoint).AsEndPoint := False; FSCS_Main.SetFigureAsEndObject(TF_CAD(OldEndPoint.Owner.Owner), TConnectorObject(OldEndPoint)); GListWithEndPoint := TF_CAD(OldEndPoint.Owner.Owner); end; //Tolik Screen.Cursor := crDefault; F_NormBase.Tree_Catalog.Tag := 0; F_NormBase.Tree_Catalog.WindowProc := Old_Proc; GisDrop := false; // Tolik 18/02/2022 -- exit; end; end; end; StateType := stProjectible; //#From Oleg# //14.09.2010 EndPoint := nil; //#From Oleg# //14.09.2010 SelList := TList.Create; for i := 0 to PCad.SelectedCount - 1 do SelList.Add(TFigure(PCad.Selection[i])); //26.01.2011 SaveSnapToGrid := PCad.SnapToGrids; //26.01.2011 if GFigureSnap = nil then //26.01.2011 PCad.SnapToGrids := True; //26.01.2011 CurrentLayer := 2; // убрать выделеные обьекты со слоя подложки PCad.DeselectAll(1); // при отпускании компоненты - воссоздать ее на CAD GListNode := Nil; if Not IsArchComponByIsLine(GDropComponent.IsLine) then begin SaveSnapToGrid := PCad.SnapToGrids; // Пока отключили автопривязку к сетке - так как после драг дропа - включается привязка к направляющим //if GFigureSnap = nil then // if not PCad.SnapToGuides then // PCad.SnapToGrids := True; if CurrentLayer <> 2 then // Tolik 20/09/2021 -- CurrentLayer := 2; BeginProgress; try // создать фигуру на CAD if GDropComponent.IsLine = 0 then begin // *UNDO* if FCanSaveForUndo then begin SaveForUndo(uat_None, True, False); FCanSaveForUndo := False; end; end; DropFigure := GetComponentFromNormBase(X, Y, GDropComponent, GFigureSnap, StateType); // скопирование компоненту NormBase -> ProjectManager if DropFigure <> nil then begin ComponID := CopyComponentToPrjManager(GListNode, DropFigure.ID, FCADListID, GDropComponent, False, True); // Дропнулся точечный обьект! if CheckFigureByClassName(DropFigure, cTConnectorObject) then begin SetConnNameInCaptionOnCAD(TConnectorObject(DropFigure)); // положить точечный объект на другой обьект //Tolik 21/06/2022 -- if GPlugSwitch <> nil then GFigureSnap := GPlugSwitch; if GFigureSnap <> Nil then begin // на ортолинию if CheckFigureByClassName(GFigureSnap, cTOrthoLine) then CheckingSnapPointObjectToOrthoLine(TConnectorObject(DropFigure), TOrthoLine(GFigureSnap)) // на пустой конектор else if CheckFigureByClassName(GFigureSnap, cTConnectorObject) then // Tolik 23/03/2018 -- //CheckingSnapPointObjectToConnector(TConnectorObject(DropFigure), TConnectorObject(GFigureSnap)); CheckingSnapPointObjectToConnector(TConnectorObject(DropFigure), TConnectorObject(GFigureSnap), True); // end; //Tolik 21/06/2022 -- if GPlugSwitch <> nil then TConnectorObject(DropFigure).FDrawFigureAngle := TConnectorObject(GPlugSwitch).FDrawFigureAngle; // SetConnObjectSelectHightPriority(TConnectorObject(DropFigure)); //#From Oleg# //29.09.2010 if GFigureSnap = Nil then //25.06.2013 begin if GDropObjByOneClick then // Tolik 01/08/2019 -- по просьбам клиентов begin //Tolik 06/01/2022 -- если магнит -- PCad.Refresh; if DropFigure <> nil then begin if DropFigure is TConnectorObject then begin if GFigureSnap = nil then begin SCatalog := F_ProjMan.GSCSBase.CurrProject.CurrList.GetCatalogFromReferencesBySCSID(DropFigure.ID); if SCatalog <> nil then begin if (GCadForm.cbMagnetToWalls.Down and (not itWasShift)) then //(not (ssShift in GGlobalShiftState))) then begin try RefreshFlag := GCanRefreshCad; GCanRefreshCad := false; TF_Main(F_ProjMan).F_ChoiceConnectSide.DefineObjectIcon(SCatalog); MagnetConnectorToNearestWall(TConnectorObject(DropFigure)); //SCatalog.ServToDefineParamsInCAD := True; finally GCanRefreshCad := RefreshFlag; end; end; end; end; end; end; // //25.06.2013 - если простой точ. объект, то спрашивать нужно ли такие устанавливать в 1 клик (режим "ложить без Drag&Drop") if (GDropComponent.ComponentType.SysName = ctsnWorkPlace) or (GCompTypeSysNameModules.IndexOf(GDropComponent.ComponentType.SysName) <> -1) then begin if GIsProgress then PauseProgress(true); try IsCreateObjectOnClickTool := MessageQuastYN(cMain_Mes140) = IDYES; //Tolik Screen.Cursor := crHourGlass; // SCSList := F_ProjMan.GSCSBase.CurrProject.GetListBySCSID(FCADListID); if SCSList <> nil then if SCSList.FNewComponNameMarkAsk then if GDropComponent.IsUserMark = biFalse then begin SCSCompon := F_ProjMan.GSCSBase.CurrProject.GetComponentFromReferences(ComponID); if SCSCompon <> nil then begin PrevMark := SCSCompon.NameMark; if SCSList.FNewComponNameMarkSaved = '' then SCSList.FNewComponNameMarkSaved := PrevMark; end; InputMarkRes := InputMark(ApplicationName, cMain_Mes141, SCSList.FNewComponNameMarkSaved); if InputMarkRes = mrOk then begin if trim(PrevMark) <> trim(SCSList.FNewComponNameMarkSaved) then begin SCSList.FNewComponNameMark := SCSList.FNewComponNameMarkSaved; //SCSCompon := F_ProjMan.GSCSBase.CurrProject.GetComponentFromReferences(ComponID); if SCSCompon <> nil then begin SCSCompon.IsUserMark := biTrue; SCSCompon.NameMark := SCSList.FNewComponNameMark; SCSCompon.ApplyChanges; end; end else begin SCSList.FNewComponNameMarkSaved := ''; end; end else begin SCSList.FNewComponNameMarkSaved := ''; if InputMarkRes = mrIgnore then begin SCSList.FNewComponNameMark := ''; SCSList.FNewComponNameMarkAsk := false; end; end; end; if IsCreateObjectOnClickTool then begin if Not GCadForm.FCreateObjectOnClick then begin FSCS_Main.aCreateObjectOnClickTool.Execute; if FSCS_Main.tbCADToolsExpert.Visible then FSCS_Main.tbCreateOnClickModeExpert.Down := true else FSCS_Main.tbCreateOnClickModeNoob.Down := true; end; end else begin if GCadForm.FCreateObjectOnClick then begin FSCS_Main.aCreateObjectOnClickTool.Execute; if FSCS_Main.tbCADToolsExpert.Visible then FSCS_Main.tbCreateOnClickModeExpert.Down := true else FSCS_Main.tbCreateOnClickModeNoob.Down := true; end; end; finally if GIsProgress then PauseProgress(false); end; end; end; end; end; end else // компонента(ы) (ортолиния!!!) вбрасываеться в трассу! if (GDropComponent <> nil) and (DropFigure = Nil) and (GFigureSnap <> nil) then begin if CheckFigureByClassName(GFigureSnap, cTConnectorObject) then begin if GCadForm.FCreateObjectOnClick or Self.FCreateObjectOnClick then begin GCadForm.FCreateObjectOnClick := False; RestoreCadGridStatus; // Tolik 04/03/2021 -- Self.FCreateObjectOnClick := False; PCad.SetTool(toSelect, 'TSelected'); FSCS_Main.tbCreateOnClickModeExpert.Down := False; FSCS_Main.tbCreateOnClickModeNoob.Down := False; FSCS_Main.tbSelectExpert.Down := True; FSCS_Main.tbSelectNoob.Down := True; end; // на РТ ComponID := CopyComponentToSCSObject(GFigureSnap.ID, GDropComponent.ID, True); if (GDropComponent.IsLine = 1) and (TConnectorObject(GFigureSnap).ConnectorType <> ct_Clear) then begin //29.06.2013 - Если нету трасс, то предлагаем создать автоматом Traces := GetAllConnectedTraces(TConnectorObject(GFigureSnap)); // 08.08.2013 Igor {TODO} // желательно доделать: исключать трассы ведущие к МЭ если есть другие не пустые ТО на листе кроме того на который дропнули // Исключим трассы подсоединенные к МЭ NeedExclTraces := False; if GCadForm.FNeedUpdateCheckedFigures then GCadForm.UpdateCheckedFigures(True); for jj := 0 to GCadForm.FCheckedFigures.Count - 1 do begin if CheckFigureByClassName(TFigure(GCadForm.FCheckedFigures[jj]), cTConnectorObject) then begin if TConnectorObject(GCadForm.FCheckedFigures[jj]) <> TConnectorObject(GFigureSnap) then if TConnectorObject(GCadForm.FCheckedFigures[jj]).ConnectorType <> ct_Clear then begin if (TConnectorObject(GCadForm.FCheckedFigures[jj]).JoinedConnectorsList.Count = 0) and (TConnectorObject(GCadForm.FCheckedFigures[jj]).JoinedFigures.Count = 0) and (TConnectorObject(GCadForm.FCheckedFigures[jj]).JoinedFigures.Count = 0) then begin NeedExclTraces := True; break; end; end; end; end; BreakCheck := False; if NeedExclTraces then begin for i := Traces.Count - 1 downto 0 do begin Trace := TOrthoLine(Traces[i]); isBetweenFloor := False; if Trace.FIsRaiseUpDown or Trace.FIsVertical then begin // проверим есть ли трассы подключенные к С/П но не ведущие к МЭ // проверим просто есть ли у одного из коннекторов больше чем 2 подключенных трассы if Trace.JoinConnector1 <> nil then begin if TConnectorObject(Trace.JoinConnector1).JoinedOrtholinesList.Count > 2 then BreakCheck := True; end; if Trace.JoinConnector2 <> nil then begin if TConnectorObject(Trace.JoinConnector2).JoinedOrtholinesList.Count > 2 then BreakCheck := True; end; if BreakCheck then break else begin isBetweenFloor := CheckOtherTraceBetwFloor(Trace, False, True); if isBetweenFloor then Traces.Delete(i) end; (* так пока хреново - проверку нужно переделывать что бы шла в одном направлении, а не по всем возможным. if Trace.JoinConnector1 <> nil then begin for j := 0 to TConnectorObject(Trace.JoinConnector1).JoinedOrtholinesList.Count - 1 do begin if TConnectorObject(Trace.JoinConnector1).JoinedOrtholinesList.Items[j] <> Trace then if Not CheckOtherTraceBetwFloor(TOrthoLine(TConnectorObject(Trace.JoinConnector1).JoinedOrtholinesList.Items[j]), False, False) then begin BreakCheck := True; break; end else begin isBetweenFloor := True; end; end; end; if (Trace.JoinConnector2 <> nil) and Not BreakCheck then begin for j := 0 to TConnectorObject(Trace.JoinConnector2).JoinedOrtholinesList.Count - 1 do begin if TConnectorObject(Trace.JoinConnector2).JoinedOrtholinesList.Items[j] <> Trace then if Not CheckOtherTraceBetwFloor(TOrthoLine(TConnectorObject(Trace.JoinConnector2).JoinedOrtholinesList.Items[j]), False, False) then begin BreakCheck := True; break; end else begin isBetweenFloor := True; end; end; end; if BreakCheck then break else if isBetweenFloor then Traces.Delete(i); *) end else if CheckConnJoinBetwFloor(TConnectorObject(Trace.JoinConnector1), False) or CheckConnJoinBetwFloor(TConnectorObject(Trace.JoinConnector2), False) then Traces.Delete(i) else begin isBetweenFloor := CheckOtherTraceBetwFloor(Trace, False, True); if isBetweenFloor then Traces.Delete(i) end; end; // 08.08.2013 END Igor end; //получим количество трасс - если нет подсоединенных - сбросим вркменно КО if (Traces.Count = 0) and (GEndPoint <> nil) then begin //if GEndPoint <> PCad then // в принципе может быть что и на том же каде КО сделал пользователь уже begin OldEndPoint := GEndPoint; TConnectorObject(GEndPoint).AsEndPoint := False; GEndPoint := nil; GListWithEndPoint := nil; end; end; end; // Прокладывать автоматически трассы и по новому алгоритму будет автотрассировка если не было КО // если трасс не было - КО на время сбрасывается. // если объект на который дропнули уже подключен - юзать старый алгоритм. SnapFigureConnected := False; if TConnectorObject(GFigureSnap).ConnectorType <> ct_Clear then begin if TConnectorObject(GFigureSnap).JoinedConnectorsList.Count > 0 then SnapFigureConnected := True; end else SnapFigureConnected := True; resChoice := False; //Tolik //вызываем мастер прокладки только для кабеля (а то ложемент - тоже линейный объект) //if (GDropComponent.IsLine = 1) and (Traces <> nil) and (Traces.Count <> 0) then if (GDropComponent.IsLine = 1) and (Traces <> nil) and (Traces.Count <> 0) and (IsCableComponent(GDropComponent)) then // здесь немножко сообщим, если кабель имеет множественные интерфейсы и дадим выбрать действие begin CableIsMulti := False; for l := 0 to GDropComponent.Interfaces.Count - 1 do begin if (TSCSInterface(GDropComponent.Interfaces[l]).TypeI = itFunctional) and (TSCSInterface(GDropComponent.Interfaces[l]).Multiple = biTrue) then begin CableIsMulti := True; Break; //// BREAK ////; end; end; if CableIsMulti then begin if GIsProgress then PauseProgress(true); if MessageModal(cAttentionCableMultiInterFace,'', mb_YesNo) = 6 then resChoice := ChoiceAutoTraceConnectOrder(nil, true, GDropComponent); if GIsProgress then PauseProgress(False); end else //Tolik 24/09/2021 -- //resChoice := ChoiceAutoTraceConnectOrder(nil, true, GDropComponent); begin resChoice := False; FCallAutoTraceElectricMaster := GCallAutoTraceElectricMaster; GCallAutoTraceElectricMaster := True; if GEndPoint <> nil then begin AllTrace := GetAllTraceInCAD(GEndPoint, GFigureSnap); if AllTrace <> nil then begin FreeAndNil(allTrace); resChoice := ChoiceAutoTraceConnectOrder(nil, true, GDropComponent); //Tolik 17/11/2021 -- if resChoice then AutoTraceCableFromNB(GDropComponent.ID, GDropComponent, true, false, FCanSaveForUndo, False, True); // end else begin EndPoint := TConnectorObject(GEndPoint); TConnectorObject(GendPoint).AsEndPoint := False; GEndPoint := nil; AutoTraceCableFromNB(GDropComponent.ID, GDropComponent, true, false, FCanSaveForUndo); if EndPoint <> nil then begin EndPoint.AsEndPoint := True; GEndPoint := EndPoint; end; end; end else begin AutoTraceCableFromNB(GDropComponent.ID, GDropComponent, true, false, FCanSaveForUndo); if GEndPoint <> nil then begin TConnectorObject(GEndPoint).AsEndPoint := False; GEndPoint := nil; end; end; GCallAutoTraceElectricMaster := FCallAutoTraceElectricMaster; end; // end; //if (GDropComponent.IsLine = 1) and (Traces <> nil) and (Traces.Count = 0) or resChoice then if (GDropComponent.IsLine = 1) and (Traces <> nil) and (Traces.Count = 0) and (IsCableComponent(GDropComponent)) or resChoice then begin //if ((GDropComponent.IsLine = 1) and (GEndPoint = Nil)) or ((GDropComponent.IsLine = 1) and (SnapFigureConnected)) then if ((GDropComponent.IsLine = 1) and (GEndPoint = Nil)) or ((GDropComponent.IsLine = 1) and resChoice and ((Not F_ProjMan.GSCSBase.CurrProject.Setting.TraceOnePortToOne) or (GEndPoint = GFigureSnap ))) or ((GDropComponent.IsLine = 1) and resChoice and ( F_AutoTraceConnectOrder.rbTraceManualCable.Checked )) then begin //24.06.2013 mProtocol.Lines.Add(cCad_Mes27) //24.06.2013 - устанавливаем обїект как конечный, и делаем с него авттрассировку if TConnectorObject(GFigureSnap).ConnectorType <> ct_Clear then begin //29.06.2013 - Если нету трасс, то предлагаем создать автоматом if Traces.Count = 0 then begin //Tolik 25/09/2021 -- тут вроде как и не нужно сбрасывать, если есть выбранные, а то // херится действие юзера типа по выбранным трассировать //PCad.DeselectAll(0); //PCad.SelectAll(lnSCSCommon); if ((PCad.Selection.Count = 0) and (GFigureSnap = nil)) then begin PCad.DeselectAll(0); PCad.SelectAll(lnSCSCommon); end; // //if PCad.Selection.Count > 1 then if CheckCanTrace then begin // Tolik -- 20/10/2016 -- SavedGFigureSnap := GFigureSnap; // //Tolik 27/09/2021 -- if GFigureSnap <> nil then begin GFigureSnap.Selected := True; if PCad.Selection.IndexOf(GFigureSnap) = -1 then PCad.Selection.Add(GFigureSnap); end; //AutoTraceCableFromNB(GDropComponent.ID, GDropComponent, true, false, FCanSaveForUndo); //AutoCreateTracesMaster(TConnectorObject(GFigureSnap)); F_NormBase.Act_AutoTraceCableExecute(nil); // // Tolik -- 20/10/2016 -- GFigureSnap := SavedGFigureSnap; // PCad.DeselectAll(0); RefreshCAD(PCad); FreeAndNil(Traces); Traces := GetAllConnectedTraces(TConnectorObject(GFigureSnap)); FCanSaveForUndo := false; end; end; // Если есть трассі от обїекта, то трассируем кабелем //Tolik 16/08/2021 -- //if Traces.Count > 0 then if ((Traces.Count > 0) and (not GAutoRouteCableAfterTraceCreation)) then // учесть настройку программы ("Автоматически прокладывать кабель после автосоздания трасс") // begin //if (GEndPoint = nil) or not SnapFigureConnected then // FSCS_Main.SetFigureAsEndObject(GCadForm, TConnectorObject(GFigureSnap)); if resChoice { SnapFigureConnected} then begin // если нет КО но дропнули на шкаф, бокс - установить его как КО isObjectRack := False; if (GEndPoint = nil) and (GFigureSnap <> nil) then begin FigureID := TConnectorObject(GFigureSnap).ID; SCSCatalog := F_ProjMan.GSCSBase.CurrProject.GetListBySCSID(TF_CAD(GFigureSnap.Owner.Owner).FCADListID).GetCatalogFromReferencesBySCSID(FigureID); if SCSCatalog <> nil then begin for k := 0 to SCSCatalog.SCSComponents.Count - 1 do begin if SCSCatalog.SCSComponents[k].ComponentType.SysName = ctsnCupboard then begin isObjectRack := true; break; end; if SCSCatalog.SCSComponents[k].ComponentType.SysName = ctsnBox then begin isObjectRack := true; break; end; end; end; end; // ЗДЕСЬ МЫ ТОЛЬКО если опция ОДИН порт и больше! // если GFigureSnap не шкаф/бокс а КО - шкаф/бокс выделим GFigureSnap // лучше так: если GFigureSnap не КО тогда выделим GFigureSnap и вызов трассировки от выделеного объекта к КО if GFigureSnap <> GEndPoint then begin if isObjectRack then FSCS_Main.SetFigureAsEndObject(GCadForm, GFigureSnap); GFigureSnap.Select; RefreshCAD(PCad); OldParam := F_ProjMan.GSCSBase.CurrProject.Setting.TraceNoAskParams; F_ProjMan.GSCSBase.CurrProject.Setting.TraceNoAskParams := True; try AutoTraceCableFromNB(GDropComponent.ID, GDropComponent, true, false, FCanSaveForUndo, False, True); except end; F_ProjMan.GSCSBase.CurrProject.Setting.TraceNoAskParams := OldParam; end else begin // если был дроп на трассу - GFigureSnap = GEndPoint if aTraceOnEntireRoute then begin if FNeedUpdateCheckedFigures then UpdateCheckedFigures; for i := 0 to FCheckedFigures.Count - 1 do begin if CheckFigureByClassName(FCheckedFigures[i], cTConnectorObject) and (TConnectorObject(FCheckedFigures[i]).ConnectorType <> ct_Clear)then begin if FCheckedFigures[i] <> GFigureSnap then begin NeedSelFigure := False; AllConnectedTraces := GetAllTraceInCAD(TConnectorObject(FCheckedFigures[i]), TConnectorObject(GFigureSnap)); if AllConnectedTraces <> nil then begin if AllConnectedTraces.Count > 0 then begin for k := 0 to AllConnectedTraces.Count - 1 do begin if AllConnectedTraces[k] = aOnDropRoute then begin NeedSelFigure := True; break; end; end; end; freeandnil(AllConnectedTraces); end; if NeedSelFigure then TConnectorObject(FCheckedFigures[i]).Select; end; end; end; if AllConnectedTraces <> nil then freeandnil(AllConnectedTraces); RefreshCAD(PCad); OldParam := F_ProjMan.GSCSBase.CurrProject.Setting.TraceNoAskParams; F_ProjMan.GSCSBase.CurrProject.Setting.TraceNoAskParams := True; try AutoTraceCableFromNB(GDropComponent.ID, GDropComponent, true, false, FCanSaveForUndo, False, True); except end; F_ProjMan.GSCSBase.CurrProject.Setting.TraceNoAskParams := OldParam; end else begin OldParam := F_ProjMan.GSCSBase.CurrProject.Setting.TraceNoAskParams; F_ProjMan.GSCSBase.CurrProject.Setting.TraceNoAskParams := True; try AutoTraceCableFromNB(GDropComponent.ID, GDropComponent, true, false, FCanSaveForUndo); except end; F_ProjMan.GSCSBase.CurrProject.Setting.TraceNoAskParams := OldParam; end; end; end else begin isObjectRack := False; if (GEndPoint = nil) and (GFigureSnap <> nil) then begin FigureID := TConnectorObject(GFigureSnap).ID; SCSCatalog := F_ProjMan.GSCSBase.CurrProject.GetListBySCSID(TF_CAD(GFigureSnap.Owner.Owner).FCADListID).GetCatalogFromReferencesBySCSID(FigureID); if SCSCatalog <> nil then begin for k := 0 to SCSCatalog.SCSComponents.Count - 1 do begin if SCSCatalog.SCSComponents[k].ComponentType.SysName = ctsnCupboard then begin isObjectRack := true; break; end; if SCSCatalog.SCSComponents[k].ComponentType.SysName = ctsnBox then begin isObjectRack := true; break; end; end; end; end; if isObjectRack then FSCS_Main.SetFigureAsEndObject(GCadForm, GFigureSnap); AutoTraceCableFromNB(GDropComponent.ID, GDropComponent, true, false, FCanSaveForUndo); end; end; FreeAndNil(Traces); // вернем назад КО if OldEndPoint <> nil then begin if GEndPoint <> nil then TConnectorObject(GEndPoint).AsEndPoint := False; //GEndPoint := OldEndPoint; //TConnectorObject(GEndPoint).AsEndPoint := True; //PCad.Refresh; FSCS_Main.SetFigureAsEndObject(TF_CAD(OldEndPoint.Owner.Owner), TConnectorObject(OldEndPoint)); GListWithEndPoint := TF_CAD(OldEndPoint.Owner.Owner); end; end; end // вброс в трассу по прежнему алгоритму - если был КО уже какой то и были уже ранее подключены трассы // к объекту на который дрег был. // {TODO} если были трассы но не было КО - сюда не попадаем - будет работать по флажку автотрассировка // возможно еще дополнительно проверять что-то (новый алгоритм (по флажку aFromDropConnObj) по идеи должен работать только при дреге на шкаф или бокс) else begin if (GDropComponent.IsLine = 1) and (GEndPoint <> nil) and {FROM IGOR ChoiceAutoTraceConnectOrder(nil, true, GDropComponent) and } //#FROM OLEG CheckCanJoinNBComponWithPointObjects(GDropComponent, //#FROM OLEG TConnectorObject(GEndPoint), //#FROM OLEG TConnectorObject(GFigureSnap)) then //#FROM OLEG begin if (TConnectorObject(GFigureSnap).ConnectorType = ct_Clear) and (TConnectorObject(GFigureSnap).JoinedOrtholinesList.Count > 1) then begin NearTracedLine := nil; for i := 0 to TConnectorObject(GFigureSnap).JoinedOrtholinesList.Count - 1 do if not CheckNoFigureInList(TOrthoLine(TConnectorObject(GFigureSnap).JoinedOrtholinesList[i]), SelList) then NearTracedLine := TOrthoLine(TConnectorObject(GFigureSnap).JoinedOrtholinesList[i]); EndProgress; TracingCount := MirrorCables(TConnectorObject(GFigureSnap), NearTracedLine); BeginProgress; if TracingCount > 0 then begin // получить список листов через которые будет проведена автотрассировка //ListOfLists := TIntList.create; //-- Tolik 09/03/2017 -- if GListWithEndPoint <> nil then begin ListOfLists := GetSortedListIDsByBounds(GListWithEndPoint.FCADListID, FCADListID); end else //-- Tolik 09/03/2017 -- begin ListOfLists := TIntList.create; ListOfLists.Add(FCADListID); end; vLists := TList.Create; for i := 0 to ListOfLists.Count - 1 do begin vList := GetListByID(ListOfLists[i]); if vList <> nil then vLists.Add(vList); end; // Tolik -- 09/03/2017 *-* FreeAndNil(ListOfLists); // SaveForProjectUndo(vLists, True, False); // Tolik -- 09/03/2017 -- FreeAndNil(vLists); // // *** if CheckFigureByClassName(GEndPoint, cTConnectorObject) then EndPoint := TConnectorObject(GEndPoint) else if CheckFigureByClassName(GEndPoint, cTHouse) then EndPoint := GetEndPointByHouse(THouse(GEndPoint), TConnectorObject(GFigureSnap)); // *** for i := 0 to TracingCount - 1 do TracingToEndPoint(TConnectorObject(GFigureSnap), EndPoint, GDropComponent.ID); end; end else begin // получить список листов через которые будет проведена автотрассировка // ListOfLists := TIntList.create; // -- Tolik 09/03/2017 -*- if GListWithEndPoint <> nil then begin ListOfLists := GetSortedListIDsByBounds(GListWithEndPoint.FCADListID, FCADListID); end else // -- Tolik 09/03/2017 -*- begin ListOfLists := TIntList.create; ListOfLists.Add(FCADListID); end; vLists := TList.Create; for i := 0 to ListOfLists.Count - 1 do begin vList := GetListByID(ListOfLists[i]); if vList <> nil then vLists.Add(vList); end; // Tolik 09/03/2017 -- FreeAndNil(ListOfLists); // SaveForProjectUndo(vLists, True, False); // Tolik -- 09/03/2017 -- FreeAndNil(vLists); // // *** if CheckFigureByClassName(GEndPoint, cTConnectorObject) then EndPoint := TConnectorObject(GEndPoint) else if CheckFigureByClassName(GEndPoint, cTHouse) then EndPoint := GetEndPointByHouse(THouse(GEndPoint), TConnectorObject(GFigureSnap)); // *** TracingToEndPoint(TConnectorObject(GFigureSnap), EndPoint, GDropComponent.ID); end; end; end; end; end else if CheckFigureByClassName(GFigureSnap, cTOrthoLine) then begin if not TOrthoLine(GFigureSnap).FIsRaiseUpDown then begin // *UNDO* if FCanSaveForUndo then begin SaveForUndo(uat_None, True, False); FCanSaveForUndo := False; end; end else // на с-п ложится begin RaiseConn := GetRaiseByRaiseLine(TOrthoLine(GFigureSnap)); if RaiseConn <> nil then begin // м-э if (RaiseConn.FConnRaiseType = crt_BetweenFloorUp) or (RaiseConn.FConnRaiseType = crt_BetweenFloorDown) or (RaiseConn.FConnRaiseType = crt_TrunkUp) or (RaiseConn.FConnRaiseType = crt_TrunkDown)then begin vLists := TList.Create; vLists.Add(GCadForm); vList := GetListByID(RaiseConn.FID_ListToPassage); if vList <> nil then vLists.Add(vList); SaveForProjectUndo(vLists, True, False); // Tolik -- 09/03/2017 -- FreeAndNil(vLists); // end else // обычный begin // *UNDO* if FCanSaveForUndo then begin SaveForUndo(uat_None, True, False); FCanSaveForUndo := False; end; end; end; end; end; // Tolik 04/10/2021 - - чтобы кабель упал и на выбранную трассу //if (GFigureSnap <> nil) and (not GFigureSnap.Selected) then if (GFigureSnap <> nil) then // if CheckFigureByClassName(GFigureSnap, cTOrthoLine) then begin GetRaiseLine := GetBetweenFloorRaiseLine(TOrthoLine(GFigureSnap)); DisableMarking; //15.01.2011 - Отключаем генерацию маркировки для кабеля try if GetRaiseLine <> nil then begin ComponID := CopyComponentToSCSObject(GetRaiseLine.ID, GDropComponent.ID, True); AutoConnectOnAppendCable(FCADListID, GetRaiseLine.ID); //#From Oleg# end; ComponID := CopyComponentToSCSObject(GFigureSnap.ID, GDropComponent.ID, True); AutoConnectOnAppendCable(FCADListID, TOrthoLine(GFigureSnap).ID); //#From Oleg# if GetRaiseLine <> nil then begin TraceIDs := TIntList.Create; TraceIDs.Add(TOrthoLine(GFigureSnap).ID); TraceIDs.Add(GetRaiseLine.ID); EnableMarking; //15.01.2011 ConnectObjectsInPMByWay(TraceIDs, nil, nil, nil); FreeAndNil(TraceIDs); end else begin EnableMarking; //15.01.2011 F_ProjMan.GSCSBase.CurrProject.FinishMarkingCompons; end; finally EnableMarking; //15.01.2011 end; //#From Oleg# end; // if FSCSType = st_Internal then // if GDropComponent.IsLine <> 0 then // if FAllowKindDelivery then // AutoDivideTraceOnAppendCable(TOrthoLine(GFigureSnap), 2); end; // убрать выделение всех выделенных фигур! if GPrevFigureSnap <> nil then begin TConnectorObject(DropFigure).DrawSnapFigures(GPrevFigureSnap, False); for i := 0 to PCad.SelectedCount - 1 do begin if CheckFigureByClassName(TFigure(PCad.Selection[i]), cTOrthoLine) and (TFigure(PCad.Selection[i]).Selected) then TConnectorObject(DropFigure).DrawSnapFigures(TFigure(PCad.Selection[i]), False); end; end; GListNode := Nil; GDraggedFigureZOrder := -1; PCad.SnapToGrids := SaveSnapToGrid; if SelList <> nil then FreeAndNil(SelList); // *UNDO* FCanSaveForUndo := True; // компонента(ы) кабель/КК вбрасываеться на пустое место if (GDropComponent <> nil) and (DropFigure = Nil) and (GFigureSnap = nil) then begin EndProgress; //24.06.2013 - Если Дроп Каб.канала, то віделяем все для дальнейшей прокладки //Tolik 22/11/2021 - - //if CheckSysNameIsCableChannel(GDropComponent.ComponentType.SysName) then if (CheckSysNameIsCableChannel(GDropComponent.ComponentType.SysName) or (GDropComponent.ComponentType.SysName = ctsnTube)) then // begin PCad.DeselectAll(0); PCad.SelectAll(lnSCSCommon); PCad.Refresh; Application.ProcessMessages; WasEnbledAction := F_NormBase.Act_TraceLineComponlBySelectedLines.Enabled; // Tolik 14/02/2022 -- F_NormBase.Act_TraceLineComponlBySelectedLines.Enabled := True; // Tolik 14/02/2022 -- F_NormBase.Act_TraceLineComponlBySelectedLines.Execute; F_NormBase.Act_TraceLineComponlBySelectedLines.Enabled := WasEnbledAction ; // Tolik 14/02/2022 -- //Tolik Screen.Cursor := crDefault; end else begin //if ((not GAutoAddCableAfterDragDrop) or (GAutoAddCableAfterDragDrop and (GCadForm.Pcad.Selection.Count < 2))) then // Tolik 20/09/2021 -- if ((not GAutoAddCableAfterDragDrop) or (GAutoAddCableAfterDragDrop and (GCadForm.Pcad.Selection.Count = 0))) then // Tolik 20/09/2021 -- begin if isCableComponent(GDropComponent) then FSCS_Main.aToolOrthoLine.Execute; end; //GAutoAddCableAfterDragDrop := True; end; //if ((not GAutoAddCableAfterDragDrop) or (GAutoAddCableAfterDragDrop and (GCadForm.Pcad.Selection.Count < 2))) then // Tolik 20/09/2021 -- //if (GCadForm.Pcad.Selection.Count < 2) then // Tolik 20/09/2021 -- if (GCadForm.PCad.Selection.Count = 0) or ((GCadForm.PCad.Selection.Count = 1) and (TFigure(GCadForm.Pcad.Selection[0]).ClassName <> 'TOrthoLine')) then // Tolik 04/10/2021 -- PCad.SimulateUp(X, Y) else begin if isCableComponent(GDropComponent) then try PCad.SetTool(ToSelect, 'TSelected'); EndPoint := nil; if SelList <> nil then SelList.Clear else SelList := TList.Create; SelList.Assign(PCad.Selection, laCopy); FCallAutoTraceElectricMaster := GCallAutoTraceElectricMaster; if SelectionResult(SelList) = 1 then begin if isCableComponent(GDropComponent) then ClearSelectionByDropComponType; if GEndPoint <> nil then begin EndPoint := TConnectorObject(GEndPoint); TConnectorObject(GendPoint).AsEndPoint := False; GEndPoint := nil; end; GCallAutoTraceElectricMaster := True; F_NormBase.Act_AutoTraceCableExecute(nil); if GEndPoint <> nil then begin TConnectorObject(GEndPoint).AsEndPoint := False; GEndPoint := nil; end; if EndPoint <> nil then begin EndPoint.AsEndPoint := True; GEndPoint := EndPoint; end; end else // тут, если выбраны только трассы на каде begin IF FCANSAVEFORUNDO THEN // Undo BEGIN SAVEFORUNDO(UAT_NONE, TRUE, FALSE); FCANSAVEFORUNDO := FALSE; END; try for i := 0 to SelList.Count - 1 do begin if CheckFigureByClassName(TFigure(SelList[i]), cTOrthoLine) then begin DisableMarking; //15.01.2011 - Отключаем генерацию маркировки для кабеля GetRaiseLine := GetBetweenFloorRaiseLine(TOrthoLine(SelList[i])); if GetRaiseLine <> nil then begin ComponID := CopyComponentToSCSObject(GetRaiseLine.ID, GDropComponent.ID, True); AutoConnectOnAppendCable(FCADListID, GetRaiseLine.ID); //#From Oleg# end; ComponID := CopyComponentToSCSObject(TOrthoLine(SelList[i]).ID, GDropComponent.ID, True); AutoConnectOnAppendCable(FCADListID, TOrthoLine(SelList[i]).ID); //#From Oleg# if GetRaiseLine <> nil then begin TraceIDs := TIntList.Create; TraceIDs.Add(TOrthoLine(SelList[i]).ID); TraceIDs.Add(GetRaiseLine.ID); EnableMarking; //15.01.2011 ConnectObjectsInPMByWay(TraceIDs, nil, nil, nil); FreeAndNil(TraceIDs); end else begin EnableMarking; //15.01.2011 end; end; end; finally EnableMarking; //15.01.2011 F_ProjMan.GSCSBase.CurrProject.FinishMarkingCompons; end; end; Finally GCallAutoTraceElectricMaster := FCallAutoTraceElectricMaster; end; end; GCadForm.PCad.Refresh; //Tolik if F_NormBase.Tree_Catalog.Tag = 100 then begin F_NormBase.Tree_Catalog.Tag := 0; F_NormBase.Tree_Catalog.WindowProc := Old_proc; end; Screen.Cursor := crDefault; // F_NormBase.Tree_Catalog.Tag := 0; F_NormBase.Tree_Catalog.WindowProc := Old_Proc; // Tolik -- 29/09/2017 -- пересчитать пересечения трасс (если нужно), чтобы корректно отрисовались фигуры отрисовки на пересечениях if GCadForm.FListSettings.ShowTracesCrossPoints > 0 then begin if GDropComponent.ComponentType.SysName = ctsnCableChannel then begin if GFigureSnap <> nil then begin if CheckFigureByClassName(GFigureSnap, cTOrthoLine) then DropCalcCrosses(TOrthoLine(GFigureSnap), False); end else begin ShowTracesIntersections(2, GCadForm.FListSettings.ShowTracesCrossPoints); // пересчитать пересечения end; end; end; // // exit; end; if DropFigure <> nil then begin DropFigure.Select; if CheckFigureByClassName(DropFigure, cTConnectorObject) then DropFigure.Radius := 0; end else if GFigureSnap <> nil then GFigureSnap.Select; GFigureSnap := Nil; GPrevFigureSnap := Nil; // Tolik 20/04/2017 -- PCadNeedRefreshFlag := TPowerCad(PCad).NeedRefresh; TPowerCad(PCad).NeedRefresh := True; // //Tolik -- 29/10/2016-- RefreshCAD(PCad); // TPowerCad(PCad).NeedRefresh := PCadNeedRefreshFlag; finally //Tolik if F_NormBase.Tree_Catalog.Tag = 100 then begin F_NormBase.Tree_Catalog.Tag := 0; F_NormBase.Tree_Catalog.WindowProc := Old_proc; end; Screen.Cursor := crDefault; EndProgress; end; end else begin //FSCS_Main.aToolWallRect.Execute; CreateArchObjWizard(FCADListID, GDropComponent, Self, nil); end; //Tolik if F_NormBase.Tree_Catalog.Tag = 100 then begin F_NormBase.Tree_Catalog.Tag := 0; F_NormBase.Tree_Catalog.WindowProc := Old_proc; end; // except on E: Exception do begin addExceptionToLogEx('TF_CAD.DoDragDrop', E.Message); //Toilk if F_NormBase.Tree_Catalog.Tag = 100 then begin F_NormBase.Tree_Catalog.Tag := 0; F_NormBase.Tree_Catalog.WindowProc := Old_proc; end; Screen.Cursor := crDefault; GisDrop := false; // Tolik 18/02/2022 -- // end; end; GisDrop := false; // Tolik 18/02/2022 -- GDragOnCAD := False; if F_NormBase.Tree_Catalog.Tag = 100 then begin F_NormBase.Tree_Catalog.Tag := 0; F_NormBase.Tree_Catalog.WindowProc := Old_proc; end; // Tolik -- //F_NormBase.Width := F_NormBase.Width + 1; //F_NormBase.Width := F_NormBase.Width - 1; F_NormBase.Tree_Catalog.Width := F_NormBase.Tree_Catalog.Width + 1; F_NormBase.Tree_Catalog.Width := F_NormBase.Tree_Catalog.Width - 1; // if Traces <> nil then FreeAndNil(Traces); // Tolik -- 09/03/2017 -- if vLists <> nil then FreeAndNil(vLists); //Tolik Screen.Cursor := crDefault; if GCadForm.FListSettings.ShowTracesCrossPoints > 0 then begin if GDropComponent <> nil then if GDropComponent.ComponentType.SysName = ctsnCableChannel then begin if GFigureSnap <> nil then begin if CheckFigureByClassName(GFigureSnap, cTOrthoLine) then DropCalcCrosses(TOrthoLine(GFigureSnap), False); end else ShowTracesIntersections(2, GCadForm.FListSettings.ShowTracesCrossPoints); end; end; //Tolik 24/12/2021 - - { if DropFigure <> nil then begin if DropFigure is TConnectorObject then begin if GFigureSnap = nil then begin if (GCadForm.cbMagnetToWalls.Down and (not itWasShift)) then //(not (ssShift in GGlobalShiftState))) then MagnetConnectorToNearestWall(TConnectorObject(DropFigure)); end; end; end; } // end; procedure TF_CAD.DoFragDropDesigList; var ComponID: integer; i, j: integer; isConnected: Boolean; vList: TF_CAD; vBox: TConnectorObject; vLists: TLIst; begin try vList := GetListByID(FJoinedListIDForDesignList); if vList <> nil then begin vBox := TConnectorObject(GetFigureByID(vList, FJoinedBoxIDForDesignList)); if vBox <> nil then begin vLists := TList.Create; vLists.Add(GCadForm); vLists.Add(vList); SaveForProjectUndo(vLists, True, False); ComplectNBComponToProjObj(vBox.ID, GDropComponent, False); UpdateDesignList(Self, vBox); // Tolik -- 09/03/2017 -- vLists.Free; // end; end; except on E: Exception do addExceptionToLogEx('TF_CAD.DoFragDropDesigList', E.Message); end; end; procedure TF_CAD.AutoDivideTraceOnAppendCable(aTrace: TOrthoLine; aLength: Double); var i, j: Integer; x1, x2, y1, y2, z1, z2: double; ang: double; nextx, nexty: double; Conn: TConnectorObject; Realdelta: double; Length_X, Length_Y, Length_Z, TraceLength: Double; CurTrace: TOrthoLine; DivCount: integer; GetPointObject: TConnectorObject; //Tolik isUserLength: Boolean; LastLineLen: Double; SnapToGridaValue, SnapToGuidesValue: Boolean; RaiseTypeName: string; // Tolik 22/11/2021 - - begin try // Tolik -- 14/03/2016 -- сбрасываем привязки, чтобы не поплыли размеры отрезков при разделении трассы SnapToGridaValue := PCad.SnapToGrids; SnapToGuidesValue := PCad.SnapToGuides; PCad.SnapToGrids := False; PCad.SnapToGuides := False; // LastLineLen := 0; // если установлена длина трассы для расчетов, нужно сразу высчитать длину // последнего куска, если будет разделение if aTrace.UserLength <> -1 then begin isUserLength := True; LastLineLen := aTrace.UserLength; while LastLineLen > aLength do LastLineLen := LastLineLen - aLength; // ОСТАТОК end else isUserLength := False; // aLength := 2; // Realdelta := aLength * 1000 / PCad.MapScale; // Tolik -- 12/11/2015 -- учесть установку длины трассы для расчетов if isUserLength then begin // TraceLength := aTrace.LineLength * 1000 / PCad.MapScale; // длину берем из расчетной RealDelta := ((aLength*aTrace.CalculLength)/aTrace.userLength) * 1000 / PCad.MapScale; // длину блока масштабируем end; // if TConnectorObject(aTrace.JoinConnector1).JoinedConnectorsList.Count = 0 then begin x1 := aTrace.ActualPoints[1].x; y1 := aTrace.ActualPoints[1].y; end else begin GetPointObject := TConnectorObject(aTrace.JoinConnector1).JoinedConnectorsList[0]; begin X1 := GetPointObject.ActualPoints[1].x; Y1 := GetPointObject.ActualPoints[1].y; end; end; Z1 := aTrace.ActualZOrder[1]; if TConnectorObject(aTrace.JoinConnector2).JoinedConnectorsList.Count = 0 then begin x2 := aTrace.ActualPoints[2].x; y2 := aTrace.ActualPoints[2].y; end else begin GetPointObject := TConnectorObject(aTrace.JoinConnector2).JoinedConnectorsList[0]; begin X2 := GetPointObject.ActualPoints[2].x; Y2 := GetPointObject.ActualPoints[2].y; end; end; //Tolik 22/11/2021 -- тут нужно считать длину трассы независимо от плоскости (могут быть разные высоты концов, // а то для наклонных, например, трасс неверно посчитается длина нужных отрезков, т.е. будет // определенный остаток, + не учтены вертикали и райзы... нужно допилить.) //Z2 := aTrace.ActualZOrder[1]; Z2 := aTrace.ActualZOrder[2]; // Length_X := abs(X1 - X2); Length_Y := abs(Y1 - Y2); Length_Z := abs(Z1 - Z2); TraceLength := SQRT(SQR(Length_X) + SQR(Length_Y) + SQR(Length_Z)); if CompareValue(TraceLength, aLength, 0.05) = 1 then // Tolik 22/11/2021 -- если трасса короче отрезка, //на которые нужно ее поделить, то дальше делать нечего, //поэтому тут - проверочку begin ang := aTrace.GetAngleInRad(x1, y1, x2, y2); DivCount := Trunc(TraceLength / Realdelta); if Frac(TraceLength / Realdelta) <= 0.01 then DivCount := DivCount - 1; CurTrace := aTrace; FAllowSuppliesKind := False; if compareValue(aTrace.ActualZOrder[1], aTrace.ActualZOrder[2], 0.05) = 0 then begin for i := 1 to DivCount do begin nextx := x1 + i * Realdelta * Cos(ang); nexty := y1 + i * Realdelta * Sin(ang); Conn := TConnectorObject.Create(nextx, nexty, CurTrace.ActualZOrder[1], CurTrace.LayerHandle, PCTypesUtils.mydsNormal, PCad); Conn.ConnectorType := ct_Clear; Conn.Name := cCadClasses_Mes12; // Tolik 06/11/2018 -- PCad.AddCustomFigure (GLN(aTrace.LayerHandle), Conn, false); SnapConnectorToOrtholine(Conn, CurTrace); // Tolik if isUserLength then CurTrace.UserLength := ALength; // CurTrace.ReCreateCaptionsGroup(True, True); CurTrace.ReCreateNotesGroup(True); TOrthoLine(CurTrace).Move(0.01, 0.01); TOrthoLine(CurTrace).Move(-0.01, -0.01); // for j := 0 to Conn.JoinedOrtholinesList.Count - 1 do if TOrthoLine(Conn.JoinedOrtholinesList[j]) <> CurTrace then CurTrace := TOrthoLine(Conn.JoinedOrtholinesList[j]); end; // Tolik // последний кусок трассы (выставить длину, что останется) if isUserLength and (DivCount > 0) then begin for j := 0 to Conn.JoinedOrtholinesList.Count - 1 do if TOrthoLine(Conn.JoinedOrtholinesList[j]) <> CurTrace then CurTrace := TOrthoLine(Conn.JoinedOrtholinesList[j]); if LastLineLen <> 0 then CurTrace.UserLength := LastLineLen else CurTrace.UserLength := ALength; CurTrace.ReCreateCaptionsGroup(True, True); CurTrace.ReCreateNotesGroup(True); // выровнять подписи для трассы TOrthoLine(CurTrace).Move(0.01, 0.01); TOrthoLine(CurTrace).Move(-0.01, -0.01); end; end // Tolik 22/11/2021 -- else begin if aTrace.FisRaiseUpDown then // если попадем на райз - попвтаться преобразовать райз в вертикаль, // если только это не магистраль или не межэтажка (как с ними быть - пока // что непонятно...) begin if CheckRaiseIsNotBetweenFloorOrMagistral(aTrace, RaiseTypeName) then begin ConvertRaiseToVertical(aTrace); // end; end; if aTrace.FIsVertical then // если вертикаль begin end else begin // если просто наклонная трасса if aTrace.FisRaiseUpDown then exit; // здесь выходим, если райз, но не преобразовался в вертикаль, потому что это магистраль или межэтажка end; end; end; // // Tolik -- 14/03/2016 -- возвращаем настройки привязок Када обратно PCad.SnapToGrids := SnapToGridaValue; PCad.SnapToGuides := SnapToGuidesValue; // FAllowSuppliesKind := True; RefreshCAD(PCad); except on E: Exception do addExceptionToLogEx('TF_CAD.AutoDivideTraceOnAppendCable', E.Message); end; end; procedure TF_CAD.SnapFigureEvent(Sender: TObject); var ID: Integer; FFigure: TFigure; aSelf: TConnectorObject; begin try ID := TMenuItem(Sender).Tag; FFigure := GetFigureByID(GCadForm, ID); GFigureSnap := FFigure; if GLastConnector <> nil then aSelf := GLastConnector else exit; // Tolik 19/04/2018 -- if GFigureSnap = nil then Exit; //if (GetRaiseConn(aSelf) = nil) then //begin if not CheckTrunkObject(aSelf) then begin if not aSelf.FIsApproach then begin //// To Connector ////////////////////////// if CheckFigureByClassName(GFigureSnap, cTConnectorObject) then begin if (aSelf.ConnectorType = ct_Clear) and (TConnectorObject(GFigureSnap).ConnectorType = ct_Clear) then // Tolik 29/03/2018 -*- //aSelf := SnapConnectorToConnector(aSelf, TConnectorObject(GFigureSnap)) CheckingSnapConnectorToConnector(aSelf, TConnectorObject(GFigureSnap)) // else if (aSelf.ConnectorType = ct_Clear) and (TConnectorObject(GFigureSnap).ConnectorType <> ct_Clear) then // Tolik 03/04/2018 -- // SnapConnectorToPointObject(aSelf, TConnectorObject(GFigureSnap), True) CheckingSnapPointObjectToConnector(TConnectorObject(GFigureSnap), aSelf, False, True) // else if (aSelf.ConnectorType <> ct_Clear) and (TConnectorObject(GFigureSnap).ConnectorType = ct_Clear) then // Tolik -- 20/03/2018 -- //SnapPointObjectToConnector(aSelf, TConnectorObject(GFigureSnap)); CheckingSnapPointObjectToConnector(TConnectorObject(aSelf), TConnectorObject(GFigureSnap)); // end else //// To Ortholine ////////////////////////// if CheckFigureByClassName(GFigureSnap, cTOrthoLine) then begin if aSelf.ConnectorType = ct_Clear then begin if TOrthoLine(GFigureSnap).FIsVertical then SnapConnectorToVertical(aSelf, TOrthoLine(GFigureSnap)) else SnapConnectorToOrtholine(aSelf, TOrthoLine(GFigureSnap)); end else begin if TOrthoLine(GFigureSnap).FIsVertical then SnapPointObjectToVertical(aSelf, TOrthoLine(GFigureSnap)) else SnapPointObjectToOrthoLine(aSelf, TOrthoLine(GFigureSnap)); end; end else //// To Ortholine ////////////////////////// if CheckFigureByClassName(GFigureSnap, cTHouse) then begin if aSelf.ConnectorType = ct_Clear then SnapConnectorToHouse(aSelf, THouse(GFigureSnap)); end; end; end; //end {else if GetRaiseConn(aSelf) <> nil then GCadForm.mProtocol.Lines.Add(cCadClasses_Mes11); } if GPrevFigureSnap <> nil then aSelf.DrawSnapFigures(GPrevFigureSnap, False); // Tolik --18/04/2018 -- if GPrevFigureSnap <> nil then begin if CheckFigureByClassName(GPrevFigureSnap, cTConnectorObject) then begin TConnectorObject(GPrevFigureSnap).Draw(PCad.DEngine, False); //PCad.Refresh; end; end; // if GFigureSnap <> nil then begin if CheckFigureByClassName(GFigureSnap, cTConnectorObject) then TConnectorObject(GFigureSnap).isSnap := False else if CheckFigureByClassName(GFigureSnap, cTOrthoLine) then TOrthoLine(GFigureSnap).isSnap := False else THouse(GFigureSnap).isSnap := False; GFigureSnap := nil; end; if GPrevFigureSnap <> nil then begin if CheckFigureByClassName(GPrevFigureSnap, cTConnectorObject) then TConnectorObject(GPrevFigureSnap).isSnap := False else if CheckFigureByClassName(GPrevFigureSnap, cTOrthoLine) then TOrthoLine(GPrevFigureSnap).isSnap := False else THouse(GPrevFigureSnap).isSnap := False; end; GPrevFigureSnap := nil; GFigureSnap := Nil; GPrevFigureSnap := Nil; RefreshCAD(PCad); except on E: Exception do addExceptionToLogEx('TF_CAD.SnapFigureEvent', E.Message); end; end; procedure TF_CAD.SetMenuItemsForConnector(aConn: TConnectorObject); var i: integer; Conn: TConnectorObject; PObject: TConnectorObject; begin try if GCadForm.FShowLineCaptionsType = skExternalSCS then begin FSCS_Main.pmiSCSObjProperties.Visible := True; FSCS_Main.pmiSCSObjComponProperties.Visible := True; FSCS_Main.pmiSCSObjRealignLine.Visible := False; FSCS_Main.pmiSCSObjDivideLine.Visible := False; FSCS_Main.pmiSCSObjAutoDivideLine.Visible := False; //22.08.2012 FSCS_Main.pmiSCSObjServerAsDefault.Visible := True; //22.08.2012 FSCS_Main.pmiSCSObjNotAsServerDefault.Visible := True; FSCS_Main.pmiSCSObjDisconnect.Visible := True; for i := 0 to aConn.JoinedOrtholinesList.Count - 1 do if TOrthoLine(aConn.JoinedOrtholinesList[i]).FConnectingLine then begin FSCS_Main.pmiSCSObjDisconnect.Visible := False; break; end; FSCS_Main.pmiSCSObjSelectTracetoServer.Visible := True; FSCS_Main.pmiSCSObjMakeCabling.Visible := False; //22.08.2012 FSCS_Main.pmiSCSObjCreateRaise.Visible := False; //22.08.2012 FSCS_Main.pmiSCSObjDestroyRaise.Visible := False; FSCS_Main.pmiSCSObjRaiseLine.Visible := False; FSCS_Main.pmiSCSObjDeleteSCSObject.Visible := True; FSCS_Main.pmiSCSObjCreateFloorRaiseUp.Visible := False; FSCS_Main.pmiSCSObjCreateFloorRaiseDown.Visible := False; FSCS_Main.pmiSCSObjRotatePointObject90.Visible := False; FSCS_Main.pmiSCSObjRotatePointObject270.Visible := False; FSCS_Main.pmiSCSObjRotatePointObject180.Visible := False; FSCS_Main.pmiSCSObjDisconnectPointObject.Visible := False; FSCS_Main.pmiSCSObjDesignBox.Visible := False; FSCS_Main.pmiSCSObjRealignLine2.Visible := False; FSCS_Main.pmiSCSObjRealignObject.Visible := True; FSCS_Main.pmiSCSObjChangeRaiseHeight.Visible := False; FSCS_Main.pmiSCSObjDisconnectAllConnectors.Visible := False; FSCS_Main.pmiSCSObjDisconnectFromRM.Visible := False; //22.08.2012 FSCS_Main.pmiSCSObjRemoveObjectOnHeight.Visible := False; FSCS_Main.pmiSCSObjShowConfigurator.Visible := True; FSCS_Main.pmiSCSObjMirrorView.Visible := False; FSCS_Main.pmiSCSObjCreateDuplicates.Visible := False; // !!! if (aConn.FConnRaiseType = crt_None) and (GetRaiseConn(aConn) = nil) then begin if aConn.JoinedOrtholinesList.Count > 1 then FSCS_Main.pmiSCSObjDisconnectTraces.Visible := True else FSCS_Main.pmiSCSObjDisconnectTraces.Visible := False; end else FSCS_Main.pmiSCSObjDisconnectTraces.Visible := False; FSCS_Main.pmiSCSObjRotateTraceDrawFigure180.Visible := False; FSCS_Main.pmiSCSObjMirrorBlock.Visible := False; FSCS_Main.pmiSCSObjMarkForTracing.Visible := False; FSCS_Main.pmiSCSObjMarkForDisableTracing.Visible := False; FSCS_Main.pmiSCSObjCreateTrunk.Visible := False; FSCS_Main.pmiSCSObjCreateVertical.Visible := False; end else begin if aConn.JoinedConnectorsList.Count = 0 then begin FSCS_Main.pmiSCSObjProperties.Visible := True; FSCS_Main.pmiSCSObjComponProperties.Visible := True; FSCS_Main.pmiSCSObjRealignLine.Visible := False; FSCS_Main.pmiSCSObjDivideLine.Visible := False; FSCS_Main.pmiSCSObjAutoDivideLine.Visible := False; {//22.08.2012 if aConn.AsEndPoint then begin FSCS_Main.pmiSCSObjServerAsDefault.Visible := False; FSCS_Main.pmiSCSObjNotAsServerDefault.Visible := True; end else begin FSCS_Main.pmiSCSObjServerAsDefault.Visible := True; FSCS_Main.pmiSCSObjNotAsServerDefault.Visible := False; end; } FSCS_Main.pmiSCSObjDisconnect.Visible := True; FSCS_Main.pmiSCSObjSelectTracetoServer.Visible := true; //08.08.2012 False; FSCS_Main.pmiSCSObjMakeCabling.Visible := True; FSCS_Main.pmiSCSObjRaiseLine.Visible := False; FSCS_Main.pmiSCSObjDeleteSCSObject.Visible := True; {//22.08.2012 if aConn.FConnRaiseType <> crt_None then begin FSCS_Main.pmiSCSObjCreateRaise.Visible := False; FSCS_Main.pmiSCSObjDestroyRaise.Visible := False; end else begin if CheckRaise(aConn) then begin FSCS_Main.pmiSCSObjCreateRaise.Visible := False; FSCS_Main.pmiSCSObjDestroyRaise.Visible := True; end else begin FSCS_Main.pmiSCSObjCreateRaise.Visible := True; FSCS_Main.pmiSCSObjDestroyRaise.Visible := False; end; end;} if (aConn.FConnRaiseType = crt_None) and (GetRaiseConn(aConn) = nil) then begin FSCS_Main.pmiSCSObjCreateFloorRaiseUp.Visible := True; FSCS_Main.pmiSCSObjCreateFloorRaiseDown.Visible := True; end else begin FSCS_Main.pmiSCSObjCreateFloorRaiseUp.Visible := False; FSCS_Main.pmiSCSObjCreateFloorRaiseDown.Visible := False; end; FSCS_Main.pmiSCSObjRotatePointObject90.Visible := False; FSCS_Main.pmiSCSObjRotatePointObject270.Visible := False; FSCS_Main.pmiSCSObjRotatePointObject180.Visible := False; FSCS_Main.pmiSCSObjDisconnectPointObject.Visible := False; FSCS_Main.pmiSCSObjDesignBox.Visible := False; FSCS_Main.pmiSCSObjRealignLine2.Visible := False; if (aConn.FConnRaiseType = crt_None) then FSCS_Main.pmiSCSObjRealignObject.Visible := True else FSCS_Main.pmiSCSObjRealignObject.Visible := False; FSCS_Main.pmiSCSObjChangeRaiseHeight.Visible := False; FSCS_Main.pmiSCSObjDisconnectAllConnectors.Visible := False; FSCS_Main.pmiSCSObjDisconnectFromRM.Visible := False; // *** {//22.08.2012 if (aConn.FConnRaiseType <> crt_None) then begin Conn := aConn.FObjectFromRaise; FSCS_Main.aRemoveObjectOnHeight.Caption := cCad_Mes28 +' '+ FormatFloat(ffMask, MetreToUOM(Conn.ActualZOrder[1])) + GetUOMString(GCurrProjUnitOfMeasure); FSCS_Main.pmiSCSObjRemoveObjectOnHeight.Visible := True; end else if (GetRaiseConn(aConn) <> nil) then begin Conn := GetRaiseConn(TConnectorObject(GPopupFigure)); FSCS_Main.aRemoveObjectOnHeight.Caption := cCad_Mes28 +' '+ FormatFloat(ffMask, MetreToUOM(Conn.ActualZOrder[1])) + GetUOMString(GCurrProjUnitOfMeasure); FSCS_Main.pmiSCSObjRemoveObjectOnHeight.Visible := True; end else FSCS_Main.pmiSCSObjRemoveObjectOnHeight.Visible := False;} if aConn.JoinedOrtholinesList.Count > 0 then FSCS_Main.pmiSCSObjShowConfigurator.Visible := True else FSCS_Main.pmiSCSObjShowConfigurator.Visible := False; FSCS_Main.pmiSCSObjMirrorView.Visible := False; FSCS_Main.pmiSCSObjCreateDuplicates.Visible := True; // !!! if (aConn.FConnRaiseType = crt_None) and (GetRaiseConn(aConn) = nil) then begin if aConn.JoinedOrtholinesList.Count > 1 then FSCS_Main.pmiSCSObjDisconnectTraces.Visible := True else FSCS_Main.pmiSCSObjDisconnectTraces.Visible := False; end else FSCS_Main.pmiSCSObjDisconnectTraces.Visible := False; FSCS_Main.pmiSCSObjRotateTraceDrawFigure180.Visible := False; FSCS_Main.pmiSCSObjMirrorBlock.Visible := False; FSCS_Main.pmiSCSObjMarkForTracing.Visible := False; FSCS_Main.pmiSCSObjMarkForDisableTracing.Visible := False; if (aConn.FConnRaiseType = crt_None) and (GetRaiseConn(aConn) = nil) then begin FSCS_Main.pmiSCSObjCreateTrunk.Visible := True; end else begin FSCS_Main.pmiSCSObjCreateTrunk.Visible := False; end; if GUseVerticalTraces then begin if (aConn.FConnRaiseType = crt_None) and (GetRaiseConn(aConn) = nil) then FSCS_Main.pmiSCSObjCreateVertical.Visible := True else FSCS_Main.pmiSCSObjCreateVertical.Visible := False; end else begin FSCS_Main.pmiSCSObjCreateVertical.Visible := False; end; end else begin FSCS_Main.pmiSCSObjProperties.Visible := False; FSCS_Main.pmiSCSObjComponProperties.Visible := False; FSCS_Main.pmiSCSObjRealignLine.Visible := False; FSCS_Main.pmiSCSObjDivideLine.Visible := False; FSCS_Main.pmiSCSObjAutoDivideLine.Visible := False; //22.08.2012 FSCS_Main.pmiSCSObjServerAsDefault.Visible := False; //22.08.2012 FSCS_Main.pmiSCSObjNotAsServerDefault.Visible := False; FSCS_Main.pmiSCSObjDisconnect.Visible := False; FSCS_Main.pmiSCSObjSelectTracetoServer.Visible := False; FSCS_Main.pmiSCSObjMakeCabling.Visible := False; //22.08.2012 FSCS_Main.pmiSCSObjCreateRaise.Visible := False; //22.08.2012 FSCS_Main.pmiSCSObjDestroyRaise.Visible := False; FSCS_Main.pmiSCSObjRaiseLine.Visible := False; FSCS_Main.pmiSCSObjDeleteSCSObject.Visible := False; FSCS_Main.pmiSCSObjCreateFloorRaiseUp.Visible := False; FSCS_Main.pmiSCSObjCreateFloorRaiseDown.Visible := False; FSCS_Main.pmiSCSObjRotatePointObject90.Visible := False; FSCS_Main.pmiSCSObjRotatePointObject270.Visible := False; FSCS_Main.pmiSCSObjRotatePointObject180.Visible := False; FSCS_Main.pmiSCSObjDisconnectPointObject.Visible := False; FSCS_Main.pmiSCSObjDesignBox.Visible := False; FSCS_Main.pmiSCSObjRealignLine2.Visible := False; FSCS_Main.pmiSCSObjRealignObject.Visible := False; FSCS_Main.pmiSCSObjChangeRaiseHeight.Visible := False; FSCS_Main.pmiSCSObjDisconnectAllConnectors.Visible := False; if GetRaiseLine(aConn) = nil then FSCS_Main.pmiSCSObjDisconnectFromRM.Visible := True else FSCS_Main.pmiSCSObjDisconnectFromRM.Visible := False; //22.08.2012 FSCS_Main.pmiSCSObjRemoveObjectOnHeight.Visible := False; FSCS_Main.pmiSCSObjShowConfigurator.Visible := False; FSCS_Main.pmiSCSObjMirrorView.Visible := False; FSCS_Main.pmiSCSObjCreateDuplicates.Visible := False; FSCS_Main.pmiSCSObjDisconnectTraces.Visible := False; FSCS_Main.pmiSCSObjRotateTraceDrawFigure180.Visible := False; FSCS_Main.pmiSCSObjMirrorBlock.Visible := False; FSCS_Main.pmiSCSObjMarkForTracing.Visible := False; FSCS_Main.pmiSCSObjMarkForDisableTracing.Visible := False; FSCS_Main.pmiSCSObjCreateTrunk.Visible := False; FSCS_Main.pmiSCSObjCreateVertical.Visible := False; end; end; //------------------------------------------------------------------ if aConn.JoinedConnectorsList.Count = 0 then begin if aConn.AsEndPoint then begin FSCS_Main.pmiSCSObjServerAsDefault.Visible := False; FSCS_Main.pmiSCSObjNotAsServerDefault.Visible := True; end else begin FSCS_Main.pmiSCSObjServerAsDefault.Visible := True; FSCS_Main.pmiSCSObjNotAsServerDefault.Visible := False; end; end else begin FSCS_Main.pmiSCSObjServerAsDefault.Visible := False; FSCS_Main.pmiSCSObjNotAsServerDefault.Visible := False; end; //22.08.2012 Общие пункты для скс и распределительной сети if (GCadForm.FShowLineCaptionsType <> skExternalSCS) or GAllowExternalListCoordZ then begin if aConn.JoinedConnectorsList.Count = 0 then begin if aConn.FConnRaiseType <> crt_None then begin FSCS_Main.pmiSCSObjCreateRaise.Visible := False; FSCS_Main.pmiSCSObjDestroyRaise.Visible := False; end else begin if CheckRaise(aConn) then begin FSCS_Main.pmiSCSObjCreateRaise.Visible := False; FSCS_Main.pmiSCSObjDestroyRaise.Visible := True; end else begin FSCS_Main.pmiSCSObjCreateRaise.Visible := True; FSCS_Main.pmiSCSObjDestroyRaise.Visible := False; end; end; Conn := nil; if (aConn.FConnRaiseType <> crt_None) then Conn := aConn.FObjectFromRaise else if (GetRaiseConn(aConn) <> nil) then Conn := GetRaiseConn(TConnectorObject(GPopupFigure)) else FSCS_Main.pmiSCSObjRemoveObjectOnHeight.Visible := False; if Conn <> nil then begin FSCS_Main.aRemoveObjectOnHeight.Caption := cCad_Mes28 +' '+ FormatFloat(ffMask, MetreToUOM(Conn.ActualZOrder[1])) + GetUOMString(GCurrProjUnitOfMeasure); FSCS_Main.pmiSCSObjRemoveObjectOnHeight.Visible := True; end; end else begin FSCS_Main.pmiSCSObjCreateRaise.Visible := False; FSCS_Main.pmiSCSObjDestroyRaise.Visible := False; FSCS_Main.pmiSCSObjRemoveObjectOnHeight.Visible := False; end; end else begin FSCS_Main.pmiSCSObjCreateRaise.Visible := False; FSCS_Main.pmiSCSObjDestroyRaise.Visible := False; FSCS_Main.pmiSCSObjRemoveObjectOnHeight.Visible := False; end; except on E: Exception do addExceptionToLogEx('TF_CAD.SetMenuItemsForConnector', E.Message); end; end; procedure TF_CAD.SetMenuItemsForObject(aObject: TConnectorObject); var Conn: TConnectorObject; begin try if GCadForm.FShowLineCaptionsType = skExternalSCS then begin FSCS_Main.pmiSCSObjProperties.Visible := True; FSCS_Main.pmiSCSObjComponProperties.Visible := True; FSCS_Main.pmiSCSObjRealignLine.Visible := False; FSCS_Main.pmiSCSObjDivideLine.Visible := False; FSCS_Main.pmiSCSObjAutoDivideLine.Visible := False; //22.08.2012 FSCS_Main.pmiSCSObjServerAsDefault.Visible := True; //22.08.2012 FSCS_Main.pmiSCSObjNotAsServerDefault.Visible := True; FSCS_Main.pmiSCSObjDisconnect.Visible := False; FSCS_Main.pmiSCSObjSelectTracetoServer.Visible := True; FSCS_Main.pmiSCSObjMakeCabling.Visible := False; //22.08.2012 FSCS_Main.pmiSCSObjCreateRaise.Visible := False; //22.08.2012 FSCS_Main.pmiSCSObjDestroyRaise.Visible := False; FSCS_Main.pmiSCSObjRaiseLine.Visible := False; FSCS_Main.pmiSCSObjDeleteSCSObject.Visible := True; FSCS_Main.pmiSCSObjCreateFloorRaiseUp.Visible := False; FSCS_Main.pmiSCSObjCreateFloorRaiseDown.Visible := False; FSCS_Main.pmiSCSObjRotatePointObject90.Visible := True; FSCS_Main.pmiSCSObjRotatePointObject270.Visible := True; FSCS_Main.pmiSCSObjRotatePointObject180.Visible := True; if CheckTrunkObject(aObject) then FSCS_Main.pmiSCSObjDisconnectPointObject.Visible := False else FSCS_Main.pmiSCSObjDisconnectPointObject.Visible := True; if HaveObjectCupboardComponent(aObject.ID) then FSCS_Main.pmiSCSObjDesignBox.Visible := True else FSCS_Main.pmiSCSObjDesignBox.Visible := False; FSCS_Main.pmiSCSObjRealignLine2.Visible := False; FSCS_Main.pmiSCSObjRealignObject.Visible := True; FSCS_Main.pmiSCSObjChangeRaiseHeight.Visible := False; FSCS_Main.pmiSCSObjDisconnectAllConnectors.Visible := False; FSCS_Main.pmiSCSObjDisconnectFromRM.Visible := False; //22.08.2012 FSCS_Main.pmiSCSObjRemoveObjectOnHeight.Visible := False; FSCS_Main.pmiSCSObjShowConfigurator.Visible := True; if CheckTrunkObject(aObject) then FSCS_Main.pmiSCSObjMirrorView.Visible := True else FSCS_Main.pmiSCSObjMirrorView.Visible := False; FSCS_Main.pmiSCSObjCreateDuplicates.Visible := True; FSCS_Main.pmiSCSObjDisconnectTraces.Visible := False; FSCS_Main.pmiSCSObjRotateTraceDrawFigure180.Visible := False; if CheckTrunkObject(aObject) then FSCS_Main.pmiSCSObjMirrorBlock.Visible := False else FSCS_Main.pmiSCSObjMirrorBlock.Visible := True; FSCS_Main.pmiSCSObjMarkForTracing.Visible := False; FSCS_Main.pmiSCSObjMarkForDisableTracing.Visible := False; FSCS_Main.pmiSCSObjCreateTrunk.Visible := False; FSCS_Main.pmiSCSObjCreateVertical.Visible := False; end else begin FSCS_Main.pmiSCSObjProperties.Visible := True; FSCS_Main.pmiSCSObjComponProperties.Visible := True; FSCS_Main.pmiSCSObjRealignLine.Visible := False; FSCS_Main.pmiSCSObjDivideLine.Visible := False; FSCS_Main.pmiSCSObjAutoDivideLine.Visible := False; FSCS_Main.pmiSCSObjDisconnect.Visible := False; FSCS_Main.pmiSCSObjSelectTracetoServer.Visible := True; FSCS_Main.pmiSCSObjMakeCabling.Visible := False; FSCS_Main.pmiSCSObjRaiseLine.Visible := False; FSCS_Main.pmiSCSObjDeleteSCSObject.Visible := True; {//22.08.2012 if TConnectorObject(aObject).AsEndPoint then begin FSCS_Main.pmiSCSObjServerAsDefault.Visible := False; FSCS_Main.pmiSCSObjNotAsServerDefault.Visible := True; end else begin FSCS_Main.pmiSCSObjServerAsDefault.Visible := True; FSCS_Main.pmiSCSObjNotAsServerDefault.Visible := False; end;} {//22.08.2012 if aObject.FConnRaiseType <> crt_None then begin FSCS_Main.pmiSCSObjCreateRaise.Visible := False; FSCS_Main.pmiSCSObjDestroyRaise.Visible := False; end else if CheckRaise(aObject) then begin FSCS_Main.pmiSCSObjCreateRaise.Visible := False; FSCS_Main.pmiSCSObjDestroyRaise.Visible := True; end else begin FSCS_Main.pmiSCSObjCreateRaise.Visible := True; FSCS_Main.pmiSCSObjDestroyRaise.Visible := False; end;} if (aObject.FConnRaiseType = crt_None) and (GetRaiseConn(aObject) = nil) then begin FSCS_Main.pmiSCSObjCreateFloorRaiseUp.Visible := True; FSCS_Main.pmiSCSObjCreateFloorRaiseDown.Visible := True; end else begin FSCS_Main.pmiSCSObjCreateFloorRaiseUp.Visible := False; FSCS_Main.pmiSCSObjCreateFloorRaiseDown.Visible := False; end; FSCS_Main.pmiSCSObjRotatePointObject90.Visible := True; //FSCS_Main.pmiSCSObjRotatePointObject180.Visible := True; FSCS_Main.pmiSCSObjRotatePointObject270.Visible := True; FSCS_Main.pmiSCSObjRotatePointObject180.Visible := True; if aObject.FConnRaiseType = crt_None then FSCS_Main.pmiSCSObjDisconnectPointObject.Visible := True else FSCS_Main.pmiSCSObjDisconnectPointObject.Visible := False; if HaveObjectCupboardComponent(aObject.ID) then FSCS_Main.pmiSCSObjDesignBox.Visible := True else FSCS_Main.pmiSCSObjDesignBox.Visible := False; FSCS_Main.pmiSCSObjRealignLine2.Visible := False; if (aObject.FConnRaiseType = crt_None) then FSCS_Main.pmiSCSObjRealignObject.Visible := True else FSCS_Main.pmiSCSObjRealignObject.Visible := False; FSCS_Main.pmiSCSObjChangeRaiseHeight.Visible := False; if aObject.JoinedConnectorsList.Count = 0 then FSCS_Main.pmiSCSObjDisconnectAllConnectors.Visible := False else FSCS_Main.pmiSCSObjDisconnectAllConnectors.Visible := True; FSCS_Main.pmiSCSObjDisconnectFromRM.Visible := False; {//22.08.2012 if (aObject.FConnRaiseType <> crt_None) then begin Conn := aObject.FObjectFromRaise; FSCS_Main.aRemoveObjectOnHeight.Caption := cCad_Mes28 +' '+ FormatFloat(ffMask, MetreToUOM(Conn.ActualZOrder[1])) + GetUOMString(GCurrProjUnitOfMeasure); FSCS_Main.pmiSCSObjRemoveObjectOnHeight.Visible := True; end else if (GetRaiseConn(aObject) <> nil) then begin Conn := GetRaiseConn(aObject); FSCS_Main.aRemoveObjectOnHeight.Caption := cCad_Mes28 +' '+ FormatFloat(ffMask, MetreToUOM(Conn.ActualZOrder[1])) + GetUOMString(GCurrProjUnitOfMeasure); FSCS_Main.pmiSCSObjRemoveObjectOnHeight.Visible := True; end else FSCS_Main.pmiSCSObjRemoveObjectOnHeight.Visible := False;} if aObject.JoinedConnectorsList.Count > 0 then FSCS_Main.pmiSCSObjShowConfigurator.Visible := True else FSCS_Main.pmiSCSObjShowConfigurator.Visible := False; if CheckTrunkObject(aObject) then FSCS_Main.pmiSCSObjMirrorView.Visible := True else FSCS_Main.pmiSCSObjMirrorView.Visible := False; FSCS_Main.pmiSCSObjCreateDuplicates.Visible := True; FSCS_Main.pmiSCSObjDisconnectTraces.Visible := False; FSCS_Main.pmiSCSObjRotateTraceDrawFigure180.Visible := False; if CheckTrunkObject(aObject) then begin FSCS_Main.pmiSCSObjMirrorBlock.Visible := False; end else begin if aObject.DrawFigure.InFigures.Count > 0 then FSCS_Main.pmiSCSObjMirrorBlock.Visible := True else FSCS_Main.pmiSCSObjMirrorBlock.Visible := False; end; FSCS_Main.pmiSCSObjMarkForTracing.Visible := False; FSCS_Main.pmiSCSObjMarkForDisableTracing.Visible := False; if (aObject.FConnRaiseType = crt_None) and (GetRaiseConn(aObject) = nil) then begin FSCS_Main.pmiSCSObjCreateTrunk.Visible := True; end else begin FSCS_Main.pmiSCSObjCreateTrunk.Visible := False; end; if GUseVerticalTraces then begin if (aObject.FConnRaiseType = crt_None) and (GetRaiseConn(aObject) = nil) then FSCS_Main.pmiSCSObjCreateVertical.Visible := True else FSCS_Main.pmiSCSObjCreateVertical.Visible := False; end else begin FSCS_Main.pmiSCSObjCreateVertical.Visible := False; end; end; //------------------------------------------------------------ //Tolik 30/08/2021-- FSCS_Main.pmi_SelectFiberCableToTrace.Visible := False; FSCS_Main.pmi_ConnectToAnotherRack.Visible := False; if GPopupFigure <> nil then begin if Not GPopupFigure.Deleted then begin if GCadForm.FListType = lt_Normal then begin if CheckSCSRack(GPopupFigure) then begin if CheckNormBaseSCSCableSelected then FSCS_Main.pmi_ConnectToAnotherRack.Visible := true else FSCS_Main.pmi_SelectFiberCableToTrace.Visible := true; end; end; end; end; // if TConnectorObject(aObject).AsEndPoint then begin FSCS_Main.pmiSCSObjServerAsDefault.Visible := False; FSCS_Main.pmiSCSObjNotAsServerDefault.Visible := True; end else begin FSCS_Main.pmiSCSObjServerAsDefault.Visible := True; FSCS_Main.pmiSCSObjNotAsServerDefault.Visible := False; end; //22.08.2012 Общие пункты для скс и распределительной сети if (GCadForm.FShowLineCaptionsType <> skExternalSCS) or GAllowExternalListCoordZ then begin if aObject.FConnRaiseType <> crt_None then begin FSCS_Main.pmiSCSObjCreateRaise.Visible := False; FSCS_Main.pmiSCSObjDestroyRaise.Visible := False; end else if CheckRaise(aObject) then begin FSCS_Main.pmiSCSObjCreateRaise.Visible := False; FSCS_Main.pmiSCSObjDestroyRaise.Visible := True; end else begin FSCS_Main.pmiSCSObjCreateRaise.Visible := True; FSCS_Main.pmiSCSObjDestroyRaise.Visible := False; end; if (aObject.FConnRaiseType <> crt_None) then begin Conn := aObject.FObjectFromRaise; FSCS_Main.aRemoveObjectOnHeight.Caption := cCad_Mes28 +' '+ FormatFloat(ffMask, MetreToUOM(Conn.ActualZOrder[1])) + GetUOMString(GCurrProjUnitOfMeasure); FSCS_Main.pmiSCSObjRemoveObjectOnHeight.Visible := True; end else if (GetRaiseConn(aObject) <> nil) then begin Conn := GetRaiseConn(aObject); FSCS_Main.aRemoveObjectOnHeight.Caption := cCad_Mes28 +' '+ FormatFloat(ffMask, MetreToUOM(Conn.ActualZOrder[1])) + GetUOMString(GCurrProjUnitOfMeasure); FSCS_Main.pmiSCSObjRemoveObjectOnHeight.Visible := True; end else FSCS_Main.pmiSCSObjRemoveObjectOnHeight.Visible := False; end else begin FSCS_Main.pmiSCSObjCreateRaise.Visible := False; FSCS_Main.pmiSCSObjDestroyRaise.Visible := False; end; except on E: Exception do addExceptionToLogEx('TF_CAD.SetMenuItemsForObject', E.Message); end; end; procedure TF_CAD.SetMenuItemsForOrthoLine(aLine: TOrthoLine); begin try if GCadForm.FShowLineCaptionsType = skExternalSCS then begin FSCS_Main.pmiSCSObjProperties.Visible := True; FSCS_Main.pmiSCSObjComponProperties.Visible := True; FSCS_Main.pmiSCSObjRealignLine.Visible := False; if aLine.FConnectingLine then begin FSCS_Main.pmiSCSObjDivideLine.Visible := False; FSCS_Main.pmiSCSObjAutoDivideLine.Visible := False; end else begin FSCS_Main.pmiSCSObjDivideLine.Visible := True; FSCS_Main.pmiSCSObjAutoDivideLine.Visible := True; end; FSCS_Main.pmiSCSObjServerAsDefault.Visible := False; FSCS_Main.pmiSCSObjNotAsServerDefault.Visible := False; FSCS_Main.pmiSCSObjDisconnect.Visible := False; FSCS_Main.pmiSCSObjSelectTracetoServer.Visible := False; FSCS_Main.pmiSCSObjMakeCabling.Visible := False; FSCS_Main.pmiSCSObjCreateRaise.Visible := False; FSCS_Main.pmiSCSObjDestroyRaise.Visible := False; FSCS_Main.pmiSCSObjRaiseLine.Visible := GAllowExternalListCoordZ and not aLine.FIsRaiseUpDown and not aLine.FIsVertical; //22.08.2012 False; FSCS_Main.pmiSCSObjDeleteSCSObject.Visible := True; FSCS_Main.pmiSCSObjCreateFloorRaiseUp.Visible := False; FSCS_Main.pmiSCSObjCreateFloorRaiseDown.Visible := False; FSCS_Main.pmiSCSObjRotatePointObject90.Visible := False; FSCS_Main.pmiSCSObjRotatePointObject270.Visible := False; FSCS_Main.pmiSCSObjRotatePointObject180.Visible := False; FSCS_Main.pmiSCSObjDisconnectPointObject.Visible := False; FSCS_Main.pmiSCSObjDesignBox.Visible := False; FSCS_Main.pmiSCSObjRealignLine2.Visible := True; FSCS_Main.pmiSCSObjRealignObject.Visible := False; FSCS_Main.pmiSCSObjChangeRaiseHeight.Visible := False; FSCS_Main.pmiSCSObjDisconnectAllConnectors.Visible := False; FSCS_Main.pmiSCSObjDisconnectFromRM.Visible := False; FSCS_Main.pmiSCSObjRemoveObjectOnHeight.Visible := False; FSCS_Main.pmiSCSObjShowConfigurator.Visible := False; FSCS_Main.pmiSCSObjMirrorView.Visible := False; FSCS_Main.pmiSCSObjCreateDuplicates.Visible := False; FSCS_Main.pmiSCSObjDisconnectTraces.Visible := False; FSCS_Main.pmiSCSObjRotateTraceDrawFigure180.Visible := True; FSCS_Main.pmiSCSObjMirrorBlock.Visible := False; if not aLine.FIsRaiseUpDown then begin if aLine.FMarkTracing then FSCS_Main.pmiSCSObjMarkForTracing.Caption := cMain_Mes100 else FSCS_Main.pmiSCSObjMarkForTracing.Caption := cMain_Mes99; FSCS_Main.pmiSCSObjMarkForTracing.Visible := True; if aLine.FDisableTracing then FSCS_Main.pmiSCSObjMarkForDisableTracing.Caption := cMain_Mes113 else FSCS_Main.pmiSCSObjMarkForDisableTracing.Caption := cMain_Mes112; FSCS_Main.pmiSCSObjMarkForDisableTracing.Visible := True; end else begin FSCS_Main.pmiSCSObjMarkForTracing.Visible := False; FSCS_Main.pmiSCSObjMarkForDisableTracing.Visible := False; end; FSCS_Main.pmiSCSObjCreateTrunk.Visible := False; FSCS_Main.pmiSCSObjCreateVertical.Visible := False; FSCS_Main.pmiSCSObjDivTracesOnRoowWalls.Visible := false; //13.03.2013 FSCS_Main.aDivTracesOnRoowWalls.Visible := false; end else begin FSCS_Main.pmiSCSObjProperties.Visible := True; FSCS_Main.pmiSCSObjComponProperties.Visible := True; FSCS_Main.pmiSCSObjRealignLine.Visible := False; if not aLine.FIsRaiseUpDown then begin FSCS_Main.pmiSCSObjDivideLine.Visible := True; FSCS_Main.pmiSCSObjAutoDivideLine.Visible := True; end else begin FSCS_Main.pmiSCSObjDivideLine.Visible := False; FSCS_Main.pmiSCSObjAutoDivideLine.Visible := False; end; FSCS_Main.pmiSCSObjServerAsDefault.Visible := False; FSCS_Main.pmiSCSObjNotAsServerDefault.Visible := False; FSCS_Main.pmiSCSObjDisconnect.Visible := False; FSCS_Main.pmiSCSObjSelectTracetoServer.Visible := False; FSCS_Main.pmiSCSObjMakeCabling.Visible := False; FSCS_Main.pmiSCSObjCreateRaise.Visible := False; FSCS_Main.pmiSCSObjDestroyRaise.Visible := False; if (not aLine.FIsRaiseUpDown) and (not aLine.FIsVertical) then begin FSCS_Main.pmiSCSObjRaiseLine.Visible := True end else begin FSCS_Main.pmiSCSObjRaiseLine.Visible := False; end; FSCS_Main.pmiSCSObjDeleteSCSObject.Visible := True; // создание мэ перехода if not aLine.FIsRaiseUpDown then begin FSCS_Main.pmiSCSObjCreateFloorRaiseUp.Visible := True; FSCS_Main.pmiSCSObjCreateFloorRaiseDown.Visible := True; end else begin FSCS_Main.pmiSCSObjCreateFloorRaiseUp.Visible := False; FSCS_Main.pmiSCSObjCreateFloorRaiseDown.Visible := False; end; FSCS_Main.pmiSCSObjRotatePointObject90.Visible := False; FSCS_Main.pmiSCSObjRotatePointObject270.Visible := False; FSCS_Main.pmiSCSObjRotatePointObject180.Visible := False; FSCS_Main.pmiSCSObjDisconnectPointObject.Visible := False; FSCS_Main.pmiSCSObjDesignBox.Visible := False; if not aLine.FIsRaiseUpDown then FSCS_Main.pmiSCSObjRealignLine2.Visible := True else FSCS_Main.pmiSCSObjRealignLine2.Visible := False; FSCS_Main.pmiSCSObjRealignObject.Visible := False; if aLine.FIsRaiseUpDown then FSCS_Main.pmiSCSObjChangeRaiseHeight.Visible := True else FSCS_Main.pmiSCSObjChangeRaiseHeight.Visible := False; FSCS_Main.pmiSCSObjDisconnectAllConnectors.Visible := False; FSCS_Main.pmiSCSObjDisconnectFromRM.Visible := False; FSCS_Main.pmiSCSObjRemoveObjectOnHeight.Visible := False; FSCS_Main.pmiSCSObjShowConfigurator.Visible := False; FSCS_Main.pmiSCSObjMirrorView.Visible := False; FSCS_Main.pmiSCSObjCreateDuplicates.Visible := True; FSCS_Main.pmiSCSObjDisconnectTraces.Visible := False; FSCS_Main.pmiSCSObjRotateTraceDrawFigure180.Visible := True; FSCS_Main.pmiSCSObjMirrorBlock.Visible := False; if not aLine.FIsRaiseUpDown then begin if aLine.FMarkTracing then FSCS_Main.pmiSCSObjMarkForTracing.Caption := cMain_Mes100 else FSCS_Main.pmiSCSObjMarkForTracing.Caption := cMain_Mes99; FSCS_Main.pmiSCSObjMarkForTracing.Visible := True; if aLine.FDisableTracing then FSCS_Main.pmiSCSObjMarkForDisableTracing.Caption := cMain_Mes113 else FSCS_Main.pmiSCSObjMarkForDisableTracing.Caption := cMain_Mes112; FSCS_Main.pmiSCSObjMarkForDisableTracing.Visible := True; end else begin FSCS_Main.pmiSCSObjMarkForTracing.Visible := False; FSCS_Main.pmiSCSObjMarkForDisableTracing.Visible := False; end; // создание магистрали if not aLine.FIsRaiseUpDown then begin FSCS_Main.pmiSCSObjCreateTrunk.Visible := True; end else begin FSCS_Main.pmiSCSObjCreateTrunk.Visible := False; end; FSCS_Main.pmiSCSObjCreateVertical.Visible := False; FSCS_Main.pmiSCSObjDivTracesOnRoowWalls.Visible := true; //13.03.2013 FSCS_Main.aDivTracesOnRoowWalls.Visible := true; end; //Tolik 08/02/2022 -- //FSCS_Main.aAutoCreateTraces.Visible := false; except on E: Exception do addExceptionToLogEx('TF_CAD.SetMenuItemsForOrthoLine', E.Message); end; end; function TF_CAD.GetLastSelectedSCSObject: TFigure; var FFigure: TFigure; i, SelCount: integer; begin Result := nil; try SelCount := PCad.SelectedCount - 1; Result := TFigure(PCad.Selection[SelCount]); if CheckFigureByClassName(Result, cTConnectorObject) or CheckFigureByClassName(Result, cTOrthoLine) then Exit; for i := SelCount downto 0 do begin FFigure := TFigure(PCad.Selection[i]); if CheckFigureByClassName(FFigure, cTConnectorObject) or CheckFigureByClassName(FFigure, cTOrthoLine) then begin Result := FFigure; exit; end; end; except on E: Exception do addExceptionToLogEx('TF_CAD.GetLastSelectedSCSObject', E.Message); end; end; function TF_CAD.GetScaleKoefs: TDoublePoint; var pt: TPoint; VisRect: TDoubleRect; Rect: TRect; MPos: TDoublePoint; koefposx, koefposy: double; x1, x2, y1, y2: double; begin try Result.x := 0; Result.y := 0; Rect := PCad.ClientRect; x1 := Rect.Left; x2 := Rect.Right; y1 := Rect.Top; y2 := Rect.Bottom; if FScaleByCursor then begin GetCursorPos(pt); pt := Self.ScreenToClient(pt); // pt.x := pt.x - 35 - 27; // pt.y := pt.y - 35; // koefposx := (pt.x - x1) / (x2 - x1); // koefposy := (pt.y - y1) / (y2 - y1); // Result.x := (x2 - x1) * koefposx; // Result.y := (y2 - y1) * koefposy; Result.x := pt.x; Result.y := pt.y; end else begin Result.x := (x2 - x1) / 2; Result.y := (y2 - y1 - 10) / 2; end; except on E: Exception do addExceptionToLogEx('TF_CAD.GetScaleKoefs', E.Message); end; end; procedure TF_CAD.RotateObjectsByKeyboard(aObjects: TList; aAngle: Double); var i: integer; PointObject: TConnectorObject; AngleRad: Double; AngleDeg: Double; Bnd: TDoubleRect; NewAngleDegree: Double; // Tolik --03/10/2016 -- SavedUndoFlag: Boolean; // begin SavedUndoFlag := SavedUndoFlag; try if aObjects.Count > 0 then begin // *UNDO* if GCadForm.FCanSaveForUndo then begin GCadForm.SaveForUndo(uat_None, False, False); GCadForm.FCanSaveForUndo := False; end; for i := 0 to aObjects.Count - 1 do begin PointObject := TConnectorObject(aObjects[i]); if CheckTrunkObject(PointObject) then begin RotateTrunkObject(PointObject, aAngle); Exit; end; AngleRad := aAngle / 180 * pi; PointObject.Rotate(AngleRad, PointObject.ActualPoints[1]); PointObject.DrawFigure.Rotate(AngleRad, PointObject.CenterPoint); PointObject.FDrawFigureAngle := PointObject.FDrawFigureAngle + AngleRad; if PointObject.FDrawFigureAngle >= 2 * pi then PointObject.FDrawFigureAngle := PointObject.FDrawFigureAngle - 2 * pi; Bnd := PointObject.DrawFigure.GetBoundRect; PointObject.GrpSizeX := Bnd.Right - Bnd.Left; PointObject.GrpSizeY := Bnd.Bottom - Bnd.Top; // NewAngleDegree := PointObject.FDrawFigureAngle * 180 / pi; if (NewAngleDegree >= 0) and (NewAngleDegree <= 45) then PointObject.FCaptionsViewType := cv_Right else if (NewAngleDegree > 45) and (NewAngleDegree < 135) then PointObject.FCaptionsViewType := cv_Down else if (NewAngleDegree >= 135) and (NewAngleDegree <= 225) then PointObject.FCaptionsViewType := cv_Left else if (NewAngleDegree > 225) and (NewAngleDegree < 315) then PointObject.FCaptionsViewType := cv_Up else if (NewAngleDegree >= 315) and (NewAngleDegree <= 360) then PointObject.FCaptionsViewType := cv_Right; PointObject.DefRaizeDrawFigurePos; // RefreshCAD(GCadForm.PCad); PointObject.ReCreateCaptionsGroup(false, false); end; if not GProjectChanged then // Tolik 28/08/2019 -- SetProjectChanged(True); // *UNDO* GCadForm.FCanSaveForUndo := True; end; except on E: Exception do addExceptionToLogEx('TF_CAD.RotateObjectsByKeyboard', E.Message); end; //GCadForm.FCanSaveForUndo := SavedUndoFlag; end; //Tolik 03/06/2021 -- //function TF_CAD.SaveForUndo(aType: TListUndoActionType; aSavePM: Boolean; aIsProject: Boolean; aProjectIndex: Integer = 0): TListUndoAction; function TF_CAD.SaveForUndo(aType: TListUndoActionType; aSavePM: Boolean; aIsProject: Boolean; aProjectIndex: Integer = 0; aFromMasterNewList: Boolean = false): TListUndoAction; // var SavedGCadForm: TF_CAD; begin if GisAutoRotingCable then // Tolik 30/05/2022 -- exit; Result := nil; //Tolik 16/08/2021 -- GetPathToSCSCADDir; GetPathToSCSUndoDir; GetPathToUndoDir; // try // Tolik 04/10/2016-- if GlobalDisableSaveForUndo then exit; // SavedGCadForm := GCadForm; GCadForm := Self; // очистить REDO Лист if FSCSRedoList <> nil then ClearRedoList; // Tolik 03/06/2021 -- if aFromMasterNewList then begin Result := SaveForUndoNormalList(aType, aSavePM, aIsProject, aProjectIndex); GCadForm := SavedGCadForm; exit; end; if FListType = lt_Normal then Result := SaveForUndoNormalList(aType, aSavePM, aIsProject, aProjectIndex) else if FListType = lt_ProjectPlan then Result := SaveForUndoProjectPlan(aType, aSavePM, aIsProject, aProjectIndex) else if FListType = lt_DesignBox then Result := SaveForUndoDesignList(aType, aSavePM, aIsProject, aProjectIndex) // Tolik 12/02/2021 -- если тип листа -- электрическая схема однолинейная else if FListType = lt_ElScheme then //SaveListToUndoStack(GCadForm.FCADListID); Result := SaveForUndoELScheme(aType, aSavePM, aIsProject, aProjectIndex) else if FListType = lt_AScheme then //SaveListToUndoStack(GCadForm.FCADListID); Result := SaveForUndoELScheme(aType, aSavePM, aIsProject, aProjectIndex); // GCadForm := SavedGCadForm; except on E: Exception do addExceptionToLogEx('TF_CAD.SaveForUndo', E.Message); end; end; function TF_CAD.SaveForUndoNormalList(aType: TListUndoActionType; aSavePM: Boolean; aIsProject: Boolean; aProjectIndex: Integer = 0): TListUndoAction; var i, j: integer; Count: Integer; OldFName, FName: string; SetUndoName: string; ListUndoAction: TListUndoAction; tmpCad: TPowerCad; Stream: TMemoryStream; size: integer; CanProcess: Boolean; BasePath: string; aNeedEnd: boolean; SaveGCadRefreshFlag: boolean; begin Result := nil; //Tolik 16/08/2021 -- GetPathToSCSCADDir; GetPathToSCSUndoDir; GetPathToUndoDir; // try SaveGCadRefreshFlag := GCanRefreshCad; GCanRefreshCad := false; CanProcess := true; // *UNDO ProjectManager* BasePath := ''; if (aSavePM) and ((not aIsProject) or (aProjectIndex = 0)) then begin BasePath := SavePMForUndo(FCADListID, aIsProject); CanProcess := BasePath <> ''; end; if CanProcess then begin // проверить нужно ли сейчас делать слепок if not CheckMakeSaveForUndo then begin // Прибавить активное действие FActiveActions := FActiveActions + 1; // выйти GCanRefreshCad := SaveGCadRefreshFlag; exit; end; // Прибавить активное действие FActiveActions := FActiveActions + 1; // кол-во откатов переполнено, сместить. if FSCSUndoList.Count = 10 then begin // удалить первый файл в списке ListUndoAction := TListUndoAction(FSCSUndoList[0]); FName := ListUndoAction.FCadFileName; // удалить файл if FileExists(FName) then DeleteFile(FName); // удалить элемент из списка файлов FSCSUndoList.Delete(0); // *UNDO ProjectManager* DeleteUndoFromPM(FCADListID, ListUndoAction.FBasePath, ListUndoAction.FIsProject); // удалить объект UndoAction if ListUndoAction.ActionType = uat_Floor then begin // завязки на другие этажи - удалить всю цепочку DeleteProjectUndoActions(Self, ListUndoAction); end; FreeAndNil(ListUndoAction); // переприсвоить имена файлов с учетом смещения for i := 0 to FSCSUndoList.Count - 1 do begin ListUndoAction := TListUndoAction(FSCSUndoList[i]); // FName := FUndoDir + FCADListName + IntTostr(FCADListIndex) + '_' + IntToStr(i); FName := FUndoDir + FCADListFileName + '_' + IntToStr(i); OldFName := ListUndoAction.FCadFileName; RenameFile(OldFName, FName); ListUndoAction.FCadFileName := FName; end; end; ListUndoAction := TListUndoAction.Create(aType, aSavePM); // записать последнее изменение в файл, название в FUndoList Count := FSCSUndoList.Count; // SetUndoName := FUndoDir + FCADListName + IntTostr(FCADListIndex) + '_' + IntToStr(Count); SetUndoName := FUndoDir + FCADListFileName + '_' + IntToStr(Count); // сохранить в список файлов ListUndoAction.FCadFileName := SetUndoName; ListUndoAction.FIndex := Count; ListUndoAction.FIsProject := aIsProject; FSCSUndoList.Add(ListUndoAction); // сохранить в темповый файл FUndoFiguresList.Clear; aNeedEnd := False; /////if PCad.Figures.Count > 2000 then ///////BeginProgress('',0);// ждем окончания создания слепка 08.11.2013 самыков //IGOR Нужно делать только с проверкой!!! if FCheckedFigures.Count > 2000 then begin if (GIsProgressCount = 0) and (not F_Progress.Visible) and (Not GIsProgress) and (FFiguresDelManual.Count = 0) and (FRemFigures.Count = 0) then begin BeginProgress('',0); aNeedEnd := True; end; end; PCad.SaveSCSFiguresToFile(SetUndoName); /////if PCad.Figures.Count > 2000 then ///// EndProgress; //08.11.2013 самыков if aNeedEnd then EndProgress; // *UNDO ProjectManager* //16.08.2011 if (aSavePM) and ((not aIsProject) or (aProjectIndex = 0)) then //16.08.2011 BasePath := SavePMForUndo(FCADListID, ListUndoAction.FIsProject) //16.08.2011 else //16.08.2011 BasePath := ''; ListUndoAction.FBasePath := BasePath; Result := ListUndoAction; end; except on E: Exception do addExceptionToLogEx('TF_CAD.SaveForUndoNormalList', E.Message); end; GCanRefreshCad := SaveGCadRefreshFlag; end; function TF_CAD.SaveForUndoProjectPlan(aType: TListUndoActionType; aSavePM: Boolean; aIsProject: Boolean; aProjectIndex: Integer = 0): TListUndoAction; var i, j: integer; Count: Integer; OldFName, FName: string; SetUndoName: string; ListUndoAction: TListUndoAction; tmpCad: TPowerCad; Stream: TMemoryStream; size: integer; BasePath: string; begin Result := nil; //Tolik 16/08/2021 -- GetPathToSCSCADDir; GetPathToSCSUndoDir; GetPathToUndoDir; // try // проверить нужно ли сейчас делать слепок if not CheckMakeSaveForUndo then begin // Прибавить активное действие FActiveActions := FActiveActions + 1; exit; end; // Прибавить активное действие FActiveActions := FActiveActions + 1; // кол-во откатов переполнено, сместить. if FSCSUndoList.Count = 10 then begin // удалить первый файл в списке ListUndoAction := TListUndoAction(FSCSUndoList[0]); FName := ListUndoAction.FCadFileName; // удалить файл if FileExists(FName) then DeleteFile(FName); // удалить элемент из списка файлов FSCSUndoList.Delete(0); // удалить объект UndoAction FreeAndNil(ListUndoAction); // переприсвоить имена файлов с учетом смещения for i := 0 to FSCSUndoList.Count - 1 do begin ListUndoAction := TListUndoAction(FSCSUndoList[i]); // FName := FUndoDir + FCADListName + IntTostr(FCADListIndex) + '_' + IntToStr(i); FName := FUndoDir + FCADListFileName + '_' + IntToStr(i); OldFName := ListUndoAction.FCadFileName; RenameFile(OldFName, FName); ListUndoAction.FCadFileName := FName; end; end; ListUndoAction := TListUndoAction.Create(aType, aSavePM); // записать последнее изменение в файл, название в FUndoList Count := FSCSUndoList.Count; // SetUndoName := FUndoDir + FCADListName + IntTostr(FCADListIndex) + '_' + IntToStr(Count); SetUndoName := FUndoDir + FCADListFileName + '_' + IntToStr(Count); // сохранить в список файлов ListUndoAction.FCadFileName := SetUndoName; ListUndoAction.FIndex := Count; ListUndoAction.FIsProject := aIsProject; FSCSUndoList.Add(ListUndoAction); // сохранить в темповый файл FUndoFiguresList.Clear; PCad.SavePlanFiguresToFile(SetUndoName); ListUndoAction.FBasePath := ''; Result := ListUndoAction; except on E: Exception do addExceptionToLogEx('TF_CAD.SaveForUndoProjectPlan', E.Message); end; end; // Tolik 12/02/2021 -- function TF_CAD.SaveForUndoELScheme(aType: TListUndoActionType; aSavePM: Boolean; aIsProject: Boolean; aProjectIndex: Integer = 0): TListUndoAction; var i, j: integer; Count: Integer; OldFName, FName: string; SetUndoName: string; ListUndoAction: TListUndoAction; tmpCad: TPowerCad; Stream: TMemoryStream; size: integer; BasePath: string; begin Result := nil; //Tolik 16/08/2021 -- GetPathToSCSCADDir; GetPathToSCSUndoDir; GetPathToUndoDir; // try // проверить нужно ли сейчас делать слепок if not CheckMakeSaveForUndo then begin // Прибавить активное действие FActiveActions := FActiveActions + 1; exit; end; // Прибавить активное действие FActiveActions := FActiveActions + 1; // кол-во откатов переполнено, сместить. if FSCSUndoList.Count = 10 then begin // удалить первый файл в списке ListUndoAction := TListUndoAction(FSCSUndoList[0]); FName := ListUndoAction.FCadFileName; // удалить файл if FileExists(FName) then DeleteFile(FName); // удалить элемент из списка файлов FSCSUndoList.Delete(0); // удалить объект UndoAction FreeAndNil(ListUndoAction); // переприсвоить имена файлов с учетом смещения for i := 0 to FSCSUndoList.Count - 1 do begin ListUndoAction := TListUndoAction(FSCSUndoList[i]); // FName := FUndoDir + FCADListName + IntTostr(FCADListIndex) + '_' + IntToStr(i); FName := FUndoDir + FCADListFileName + '_' + IntToStr(i); OldFName := ListUndoAction.FCadFileName; RenameFile(OldFName, FName); ListUndoAction.FCadFileName := FName; end; end; ListUndoAction := TListUndoAction.Create(aType, aSavePM); // записать последнее изменение в файл, название в FUndoList Count := FSCSUndoList.Count; // SetUndoName := FUndoDir + FCADListName + IntTostr(FCADListIndex) + '_' + IntToStr(Count); SetUndoName := FUndoDir + FCADListFileName + '_' + IntToStr(Count); // сохранить в список файлов ListUndoAction.FCadFileName := SetUndoName; ListUndoAction.FIndex := Count; ListUndoAction.FIsProject := aIsProject; FSCSUndoList.Add(ListUndoAction); // сохранить в темповый файл FUndoFiguresList.Clear; PCad.SaveElSchemeFiguresToFile(SetUndoName); ListUndoAction.FBasePath := ''; Result := ListUndoAction; except on E: Exception do addExceptionToLogEx('TF_CAD.SaveForUndoELScheme', E.Message); end; end; // function TF_CAD.SaveForUndoDesignList(aType: TListUndoActionType; aSavePM: Boolean; aIsProject: Boolean; aProjectIndex: Integer = 0): TListUndoAction; var i, j: integer; Count: Integer; OldFName, FName: string; SetUndoName: string; ListUndoAction: TListUndoAction; tmpCad: TPowerCad; Stream: TMemoryStream; size: integer; BasePath: string; begin Result := nil; //Tolik 16/08/2021 -- GetPathToSCSCADDir; GetPathToSCSUndoDir; GetPathToUndoDir; // try // проверить нужно ли сейчас делать слепок if not CheckMakeSaveForUndo then begin // Прибавить активное действие FActiveActions := FActiveActions + 1; // выйти exit; end; // Прибавить активное действие FActiveActions := FActiveActions + 1; // кол-во откатов переполнено, сместить. if FSCSUndoList.Count = 10 then begin // удалить первый файл в списке ListUndoAction := TListUndoAction(FSCSUndoList[0]); FName := ListUndoAction.FCadFileName; // удалить файл if FileExists(FName) then DeleteFile(FName); // удалить элемент из списка файлов FSCSUndoList.Delete(0); // *UNDO ProjectManager* DeleteUndoFromPM(FCADListID, ListUndoAction.FBasePath, ListUndoAction.FIsProject); // удалить объект UndoAction if ListUndoAction.ActionType = uat_Floor then begin // завязки на другие этажи - удалить всю цепочку DeleteProjectUndoActions(Self, ListUndoAction); end; FreeAndNil(ListUndoAction); // переприсвоить имена файлов с учетом смещения for i := 0 to FSCSUndoList.Count - 1 do begin ListUndoAction := TListUndoAction(FSCSUndoList[i]); // FName := FUndoDir + FCADListName + IntTostr(FCADListIndex) + '_' + IntToStr(i); FName := FUndoDir + FCADListFileName + '_' + IntToStr(i); OldFName := ListUndoAction.FCadFileName; RenameFile(OldFName, FName); ListUndoAction.FCadFileName := FName; end; end; ListUndoAction := TListUndoAction.Create(aType, aSavePM); // записать последнее изменение в файл, название в FUndoList Count := FSCSUndoList.Count; // SetUndoName := FUndoDir + FCADListName + IntTostr(FCADListIndex) + '_' + IntToStr(Count); SetUndoName := FUndoDir + FCADListFileName + '_' + IntToStr(Count); // сохранить в список файлов ListUndoAction.FCadFileName := SetUndoName; ListUndoAction.FIndex := Count; ListUndoAction.FIsProject := aIsProject; FSCSUndoList.Add(ListUndoAction); // сохранить в темповый файл FUndoFiguresList.Clear; PCad.SavePlanFiguresToFile(SetUndoName); ListUndoAction.FBasePath := ''; Result := ListUndoAction; except on E: Exception do addExceptionToLogEx('', E.Message); end; end; procedure TF_CAD.SCSUndoNormalList; var FName: string; Figure: TFigure; i, j: integer; ListUndoAction: TListUndoAction; LinkUndoObject: TLinkUndoObject; Stream: TMemoryStream; size: integer; CountInPrj: Integer; OldTick1, OldTick2, OldTick3, CurTick1, CurTick2, CurTick3: Cardinal; CurListParams: TListParams; ListOfLists: TList; SavedGCadForm, CurrCad: TF_CAD; NetObj: TNet; //Tolik CadFigList: TList; SaveGCadRefreshFlag: boolean; //f: TextFile; begin try { AssignFile(f, 'c:\UndoFig.txt'); rewrite(f); Writeln(f, 'BEGIN'); CloseFile(f);} SaveGCadRefreshFlag := GCanRefreshCad; GCanRefreshCad := false; SavedGCadForm := GCadForm; ListOfLists := nil; // Tolik 11/12/2020 -- // IGOR 2017-04-25 если это не сделать, дебагить после анду/реду потом нереально при включенном стоп-он АВ self.UnSnapFigure; GPrevFigureTraceTo := nil; GPrevFigureSnap := nil; GFigureSnap := nil; FullEndUpdateCad(true); // Tolik 24/03/2021 -- BeginProgress; if FSCSUndoList.Count > 0 then begin ListUndoAction := TListUndoAction(FSCSUndoList[FSCSUndoList.Count - 1]); FName := ListUndoAction.FCadFileName; // есть файл if FileExists(FName) then begin // Перед UNDO, создается слепок текущего состояния для REDO if ListUndoAction.ActionType = uat_Floor then begin CountInPrj := 0; ListOfLists := TList.Create; for i := 0 to ListUndoAction.FProjectUndoAction.FLinkUndoObject.Count - 1 do begin LinkUndoObject := TLinkUndoObject(ListUndoAction.FProjectUndoAction.FLinkUndoObject[i]); if LinkUndoObject.FCad.FListType = lt_Normal then begin CountInPrj := CountInPrj + 1; ListOfLists.Add(LinkUndoObject.FCad); end; end; SaveForProjectRedo(ListOfLists, ListUndoAction.FSavePM, ListUndoAction.FIsProject); //FreeAndNil(ListOfLists); end else begin CountInPrj := 1; SaveForRedo(ListUndoAction.ActionType, ListUndoAction.FSavePM, ListUndoAction.FIsProject, CountInPrj); end; // if FListType <> lt_Normal then PCad.RecordUndo := False; // перед очисткой сбросим чтобы сработала проверка в TConnectorObject.Destroy; PCad.OnObjectInserted := nil; //ClearSCSFigures; Try F_ProjMan.Tree_Catalog.Items.BeginUpdate; //ClearFiguresOnListUndoRedo; GProjectClose := True; GClearFigures := True; GCadForm.FCadClose := True; GProjectClose := True; //ClearFiguresOnListDelete(GCadForm); ClearSCSFigures; Finally F_ProjMan.Tree_Catalog.Items.EndUpdate; GProjectClose := false; GClearFigures := false; GCadForm.FCadClose := false; GProjectClose := false; End; //PCad.OnObjectInserted := nil; FUndoFiguresList.Clear; PCad.LoadSCSFiguresFromFile(FName); PCad.OnObjectInserted := PCadObjectInserted; FUndoStatus := True; try if GListWithEndPoint = Self then begin GEndPoint := nil; GListWithEndPoint := nil; end; GNeedReRaiseProperties := False; //Tolik CadFigList := TList.Create; for i := 0 to PCad.FigureCount - 1 do CadFigList.Add(TFigure(PCad.Figures.Items[i])); for i := 0 to CadFigList.Count - 1 do begin Figure := TFigure(CadFigList[i]); if CheckFigureByClassName(Figure, 'TNet') then begin NetObj := TNet(PCad.Figures.Items[i]); if NetObj.FComponID = 0 then begin FActiveNet := NetObj; ActiveNet := FActiveNet; end; end else if CheckFigureByClassName(Figure, cTConnectorObject) then begin TConnectorObject(Figure).RaiseProperties(CadFigList); TConnectorObject(Figure).FJoinedListIDForBox := -1; end else if CheckFigureByClassName(Figure, cTOrthoLine) then TOrthoLine(Figure).RaiseProperties(CadFigList) else if CheckFigureByClassName(Figure, cTSCSFigureGrp) then TSCSFigureGrp(Figure).RaiseProperties(CadFigList) else if CheckFigureByClassName(Figure, cTCabinet) then TCabinet(Figure).RaiseProperties(CadFigList) else if CheckFigureByClassName(Figure, cTCabinetExt) then TCabinetExt(Figure).RaiseProperties(CadFigList) else if CheckFigureByClassName(Figure, cTHouse) then THouse(Figure).RaiseProperties(CadFigList); end; FreeAndNil(CadFigList); { for i := 0 to PCad.FigureCount - 1 do begin Figure := TFigure(PCad.Figures.Items[i]); if CheckFigureByClassName(Figure, 'TNet') then begin NetObj := TNet(PCad.Figures.Items[i]); if NetObj.FComponID = 0 then begin FActiveNet := NetObj; ActiveNet := FActiveNet; end; end else if CheckFigureByClassName(Figure, cTConnectorObject) then begin TConnectorObject(Figure).RaiseProperties; TConnectorObject(Figure).FJoinedListIDForBox := -1; end else if CheckFigureByClassName(Figure, cTOrthoLine) then TOrthoLine(Figure).RaiseProperties else if CheckFigureByClassName(Figure, cTSCSFigureGrp) then TSCSFigureGrp(Figure).RaiseProperties else if CheckFigureByClassName(Figure, cTCabinet) then TCabinet(Figure).RaiseProperties else if CheckFigureByClassName(Figure, cTCabinetExt) then TCabinetExt(Figure).RaiseProperties else if CheckFigureByClassName(Figure, cTHouse) then THouse(Figure).RaiseProperties; end; if GNeedReRaiseProperties then begin i := 0; while i < PCad.FigureCount do begin Figure := TFigure(PCad.Figures.Items[i]); if CheckFigureByClassName(Figure, cTConnectorObject) then begin TConnectorObject(Figure).ReRaiseProperties; end; if CheckFigureByClassName(Figure, cTOrthoLine) then begin TOrthoLine(Figure).ReRaiseProperties; end; i := i + 1; end; end; } finally FUndoStatus := False; end; FindObjectsForConvertClasses; PCad.DrawFigures(True); // удалить файл if FileExists(FName) then DeleteFile(FName); // удалить последний который поднимается из спика FSCSUndoList.Delete(FSCSUndoList.Count - 1); // *UNDO ProjectManager* UndoListInPM(FCADListID, ListUndoAction.FBasePath, ListUndoAction.FIsProject, 0, CountInPrj); // есть связи с другими этажами - поднять со всех связанных листов if ListUndoAction.ActionType = uat_Floor then begin LoadProjectUndoActions(Self, ListUndoAction); end; // Tolik 11/12/2020 -- Здесь правильно, только если будет один лист, иначе перепутаютя настройки Када // берет, например настройки листа № 3 и применяет к кабинетам листа № 1...получается херня. // List Params {CurListParams := GetListParams(FCADListID); FCanSaveForUndo := False; LoadSettingsForListByParams(CurListParams, True); SetVisibleCabinetsNumbers(FShowCabinetsNumbers); SetVisibleCabinetsBounds(FShowCabinetsBounds); FCanSaveForUndo := True;} if CountInPrj = 1 then begin // List Params CurListParams := GetListParams(FCADListID); FCanSaveForUndo := False; LoadSettingsForListByParams(CurListParams, True); SetVisibleCabinetsNumbers(FShowCabinetsNumbers); SetVisibleCabinetsBounds(FShowCabinetsBounds); FCanSaveForUndo := True; OnAfterUndo; end else if CountInPrj > 1 then begin if ListOfLists <> nil then begin for i := 0 to ListOfLists.Count - 1 do begin GCadForm := TF_CAD(ListOfLists[i]); CurListParams := GetListParams(GCadForm.FCADListID); GCadForm.FCanSaveForUndo := False; LoadSettingsForListByParams(CurListParams, True); SetVisibleCabinetsNumbers(GCadForm.FShowCabinetsNumbers); SetVisibleCabinetsBounds(GCadForm.FShowCabinetsBounds); GCadForm.FCanSaveForUndo := True; GCadForm.OnAfterUndo; end; FreeAndNil(ListOfLists); end; end; // end else FSCSUndoList.Remove(ListUndoAction); // удалить объект UndoAction FreeAndNil(ListUndoAction); // Tolik --28/06/2016 -- if Assigned(F_SCSObjectsProp) then if F_SCSObjectsProp.Showing then F_SCSObjectsProp.ClearAllProperties; // end; except on E: Exception do addExceptionToLogEx('TF_CAD.SCSUndoNormalList', E.Message); end; //Tolik 04/06/2021 -- if FListType <> lt_Normal then PCad.RecordUndo := True; // // Tolik 26/09/2017 -- if FListSettings.ShowTracesCrossPoints > 0 then ShowTracesIntersections(2, FListSettings.ShowTracesCrossPoints); // GCadForm := SavedGCadForm; GCanRefreshCad := SaveGCadRefreshFlag; EndProgress; {append(f); writeln(f, 'END'); writeln(f, '---------------------------------------------------------------------------'); CloseFile(f);} PCad.refresh; end; procedure TF_CAD.SCSUndoProjectPlan; var FName: string; i, j: integer; ListUndoAction: TListUndoAction; Stream: TMemoryStream; size: integer; CountInPrj: Integer; CurListParams: TListParams; SavedGCadForm: TF_CAD; Figure: TFigure; begin try //Tolik 25/06/2021 -- SCSUndoNormalList; PCad.RecordUndo := True; //PCad.UndoCount := 0; exit; // // IGOR 2017-04-25 если это не сделать, дебагить после анду/реду потом нереально при включенном стоп-он АВ self.UnSnapFigure; GPrevFigureTraceTo := nil; GPrevFigureSnap := nil; GFigureSnap := nil; BeginProgress; if FSCSUndoList.Count > 0 then begin ListUndoAction := TListUndoAction(FSCSUndoList[FSCSUndoList.Count - 1]); FName := ListUndoAction.FCadFileName; // есть файл if FileExists(FName) then begin // Перед UNDO, создается слепок текущего состояния для REDO SaveForRedo(ListUndoAction.ActionType, ListUndoAction.FSavePM, ListUndoAction.FIsProject, 1); ClearPlanFigures; PCad.OnObjectInserted := nil; FUndoFiguresList.Clear; PCad.LoadSCSFiguresFromFile(FName); PCad.OnObjectInserted := PCadObjectInserted; FUndoStatus := True; try for i := 0 to PCad.FigureCount - 1 do begin Figure := TFigure(PCad.Figures.Items[i]); if CheckFigureByClassName(Figure, cTPlanObject) then TPlanObject(Figure).RaiseProperties(PCad.Figures) else if CheckFigureByClassName(Figure, cTPlanConnector) then TPlanConnector(Figure).RaiseProperties(PCad.Figures) else if CheckFigureByClassName(Figure, cTPlanTrace) then TPlanTrace(Figure).RaiseProperties(PCad.Figures); end; finally FUndoStatus := False; end; // удалить файл if FileExists(FName) then DeleteFile(FName); // удалить последний который поднимается из спика FSCSUndoList.Delete(FSCSUndoList.Count - 1); CurListParams := GetListParams(FCADListID); FCanSaveForUndo := False; LoadSettingsForListByParams(CurListParams, True); FCanSaveForUndo := True; end else FSCSUndoList.Remove(ListUndoAction); // удалить объект UndoAction FreeAndNil(ListUndoAction); end; except on E: Exception do addExceptionToLogEx('TF_CAD.SCSUndoProjectPlan', E.Message); end; EndProgress; end; procedure TF_CAD.SCSUndoDesignList; var FName: string; i, j: integer; ListUndoAction: TListUndoAction; LinkUndoObject: TLinkUndoObject; Stream: TMemoryStream; size: integer; CountInPrj: Integer; OldTick1, OldTick2, OldTick3, CurTick1, CurTick2, CurTick3: Cardinal; CurListParams: TListParams; ListOfLists: TList; SavedGCadForm: TF_CAD; begin try //Tolik 23/06/2021 -- SCSUndoNormalList; PCad.RecordUndo := True; //PCad.UndoCount := 0; exit; // // IGOR 2017-04-25 если это не сделать, дебагить после анду/реду потом нереально при включенном стоп-он АВ self.UnSnapFigure; GPrevFigureTraceTo := nil; GPrevFigureSnap := nil; GFigureSnap := nil; BeginProgress; if FSCSUndoList.Count > 0 then begin ListUndoAction := TListUndoAction(FSCSUndoList[FSCSUndoList.Count - 1]); FName := ListUndoAction.FCadFileName; // есть файл if FileExists(FName) then begin // Перед UNDO, создается слепок текущего состояния для REDO if ListUndoAction.ActionType = uat_Floor then begin ListOfLists := TList.Create; CountInPrj := ListUndoAction.FProjectUndoAction.FLinkUndoObject.Count; for i := 0 to ListUndoAction.FProjectUndoAction.FLinkUndoObject.Count - 1 do begin LinkUndoObject := TLinkUndoObject(ListUndoAction.FProjectUndoAction.FLinkUndoObject[i]); ListOfLists.Add(LinkUndoObject.FCad); end; SaveForProjectRedo(ListOfLists, ListUndoAction.FSavePM, ListUndoAction.FIsProject); FreeAndNil(ListOfLists); end else begin CountInPrj := 1; SaveForRedo(ListUndoAction.ActionType, ListUndoAction.FSavePM, ListUndoAction.FIsProject, CountInPrj); end; // ClearPlanFigures; PCad.OnObjectInserted := nil; FUndoFiguresList.Clear; PCad.LoadSCSFiguresFromFile(FName); PCad.OnObjectInserted := PCadObjectInserted; FUndoStatus := True; if GListWithEndPoint = Self then begin GEndPoint := nil; GListWithEndPoint := nil; end; FUndoStatus := False; // удалить файл if FileExists(FName) then DeleteFile(FName); // удалить последний который поднимается из спика FSCSUndoList.Delete(FSCSUndoList.Count - 1); // есть связи с другими этажами - поднять со всех связанных листов if ListUndoAction.ActionType = uat_Floor then begin LoadProjectUndoActions(Self, ListUndoAction); end; // List Params CurListParams := GetListParams(FCADListID); FCanSaveForUndo := False; LoadSettingsForListByParams(CurListParams, True); FCanSaveForUndo := True; end else FSCSUndoList.Remove(ListUndoAction); // удалить объект UndoAction FreeAndNil(ListUndoAction); end; except on E: Exception do addExceptionToLogEx('TF_CAD.SCSUndoDesignList', E.Message); end; EndProgress; end; // Tolik 12/02/2021 -- procedure TF_CAD.SCSUndoElScheme; var FName: string; i, j: integer; ListUndoAction: TListUndoAction; LinkUndoObject: TLinkUndoObject; Stream: TMemoryStream; size: integer; CountInPrj: Integer; OldTick1, OldTick2, OldTick3, CurTick1, CurTick2, CurTick3: Cardinal; CurListParams: TListParams; ListOfLists: TList; SavedGCadForm: TF_CAD; begin try SCSUndoNormalList; PCad.RecordUndo := True; PCad.UndoCount := 0; exit; // IGOR 2017-04-25 если это не сделать, дебагить после анду/реду потом нереально при включенном стоп-он АВ self.UnSnapFigure; GPrevFigureTraceTo := nil; GPrevFigureSnap := nil; GFigureSnap := nil; BeginProgress; if FSCSUndoList.Count > 0 then begin ListUndoAction := TListUndoAction(FSCSUndoList[FSCSUndoList.Count - 1]); FName := ListUndoAction.FCadFileName; // есть файл if FileExists(FName) then begin // Перед UNDO, создается слепок текущего состояния для REDO if ListUndoAction.ActionType = uat_Floor then begin ListOfLists := TList.Create; CountInPrj := ListUndoAction.FProjectUndoAction.FLinkUndoObject.Count; for i := 0 to ListUndoAction.FProjectUndoAction.FLinkUndoObject.Count - 1 do begin LinkUndoObject := TLinkUndoObject(ListUndoAction.FProjectUndoAction.FLinkUndoObject[i]); ListOfLists.Add(LinkUndoObject.FCad); end; SaveForProjectRedo(ListOfLists, ListUndoAction.FSavePM, ListUndoAction.FIsProject); FreeAndNil(ListOfLists); end else begin CountInPrj := 1; SaveForRedo(ListUndoAction.ActionType, ListUndoAction.FSavePM, ListUndoAction.FIsProject, CountInPrj); end; // ClearPlanFigures; PCad.OnObjectInserted := nil; FUndoFiguresList.Clear; PCad.LoadSCSFiguresFromFile(FName); PCad.OnObjectInserted := PCadObjectInserted; FUndoStatus := True; if GListWithEndPoint = Self then begin GEndPoint := nil; GListWithEndPoint := nil; end; FUndoStatus := False; // удалить файл if FileExists(FName) then DeleteFile(FName); // удалить последний который поднимается из спика FSCSUndoList.Delete(FSCSUndoList.Count - 1); // есть связи с другими этажами - поднять со всех связанных листов if ListUndoAction.ActionType = uat_Floor then begin LoadProjectUndoActions(Self, ListUndoAction); end; // List Params CurListParams := GetListParams(FCADListID); FCanSaveForUndo := False; LoadSettingsForListByParams(CurListParams, True); FCanSaveForUndo := True; end else FSCSUndoList.Remove(ListUndoAction); // удалить объект UndoAction FreeAndNil(ListUndoAction); end; except on E: Exception do addExceptionToLogEx('TF_CAD.SCSUndoElScheme', E.Message); end; EndProgress; end; // procedure TF_CAD.OnAfterUndo; var i, j: integer; Figure, InFigure: TFigure; begin // IGOR 2017-04-25 если это не сделать, дебагить после анду/реду потом нереально при включенном стоп-он АВ self.UnSnapFigure; GPrevFigureTraceTo := nil; GPrevFigureSnap := nil; GFigureSnap := nil; for i := 0 to PCad.FigureCount - 1 do begin Figure := TFigure(PCad.Figures.Items[i]); if Assigned(Figure.FAfterUndo) then Figure.FAfterUndo(Figure); if Figure is TFigureGrp then for j := 0 to TFigureGrp(Figure).InFigures.Count - 1 do begin InFigure := TFigure(TFigureGrp(Figure).InFigures[j]); if Assigned(InFigure.FAfterUndo) then InFigure.FAfterUndo(InFigure); end; end; end; //Tolik 07/096/2022 -- procedure TF_CAD.ClearSCSFigures; var i: integer; FigureCount: Integer; FFigure: TFigure; // Tolik LHandle2: Integer; LHandle3: Integer; LHandle4: Integer; LHandle5: Integer; LHandle6: Integer; LHandle8: Integer; LHandle9: Integer; LayersList: TIntList; // FigList: TList; Count: Integer; procedure ClearFigures(aFigList: TList); var i, j: integer; FFigure: TFigure; FigList, GrpFigList: TList; OldTick, CurrTick: Cardinal; FigureString: String; FigPos: Integer; AddrList: THashedStringListMy; DelFigList: TStringList; res: PPHashItem; // Tolik 07/12/2016-- NotSCSDelFigList: TList; //f : TextFile; figuresTodelList: TList; s: string; CadRefreshFlag: Boolean; procedure DeleteGRPFigures(aFigureGrp: TFigureGrp); var i: integer; InFigure: TFigureGrp; FFigure: TFigure; begin try if Assigned(aFigureGrp) then begin if Assigned(aFigureGrp.inFigures) then begin i := 0; for i := 0 to aFigureGrp.inFigures.Count - 1 do begin FFigure := TFigure(aFigureGrp.inFigures[i]); FigureString := IntToStr(Integer(Pointer(FFigure))); AddrList.Add(FigureString); try if FFigure is TFigureGrp then DeleteGrpFigures(TFigureGrp(FFigure)) else if CheckFigureByClassName(FFigure, 'TBlock') then DeleteGrpFigures(TBlock(FFigure)); except on E: Exception do addExceptionToLogEx('U_Cad.RemoveInFigureGrp', E.Message); end; end; aFigureGrp.InFigures.Clear; end; end; except on E: Exception do addExceptionToLogEx('U_Cad.RemoveInFigureGrp', E.Message); end; end; begin // Tolik 17/05/2021 -- если пользователь удалил лист в процессе расстановки компонент, во избежание АВ сбросить шадоу объект CadRefreshFlag := GCanRefreshCad; GCanRefreshCad := False; //figuresTodelList := Nil; //figuresTodelList := TList.Create; AddrList := THashedStringListMy.Create; AddrList.CaseSensitive := True; //FigList := TList.Create; try GClearFigures := True; // чтобы было видно, что можно удалить коннектор из ПМ на дестрое! BeginProgress; //aCAD.PCad.OnGUIEvent := Nil; // //OldTick := GetTickCount; //aCAD.PCad.DisableAlign; //aCAD.PCad.BeginMultiDeselect; //02.04.2012 //aCad.PCad.Locked := true; try // Tolik 02/12/2016 -- готовим на удаление и памяти тех фигур, которые не СКС и были удалены пользователем // и пока еще сидят в памяти (шлепаем их здесь) for i := 0 to aFigList.Count - 1 do begin FFigure := TFigure(aFigList[i]); if FFigure <> nil then begin try FigureString := IntToStr(Integer(Pointer(FFigure))); AddrList.Add(FigureString); if FFigure is TFigureGrp then begin DeleteGRPFigures(TFigureGrp(FFigure)) end else if CheckFigureByClassName(FFigure, 'TBlock') then DeleteGrpFigures(TBlock(FFigure)); except end; end; end; // -- с оптимизированным списком -- проба for i := 0 to AddrList.Count - 1 do begin if AddrList[i] <> '' then begin FigureString := AddrList[i]; FFigure := TFigure( Ptr(strtoint(FigureString))); FigPos := AddrList.IndexOF(FigureString); while FigPos <> -1 do begin AddrList.FValueHash.Remove(FigureString); AddrList[FigPos] := ''; AddrList.FValueHashValid := True; AddrList.FNameHashValid := True; FigPos := AddrList.IndexOF(FigureString); end; try if fFigure <> nil then begin if CheckFigurebyClassName(FFigure, cTOrthoLine) then begin TOrthoLine(FFigure).JoinedFigures.Clear; end else if CheckFigurebyClassName(FFigure, cTConnectorObject) then begin TConnectorObject(FFigure).JoinedOrtholinesList.Clear; TConnectorObject(FFigure).JoinedConnectorsList.Clear; TConnectorObject(FFigure).RemJoined.Clear; TConnectorObject(FFigure).JoinedFigures.Clear; end; FreeAndNil(FFigure); end; except on E: Exception do begin addExceptionToLogEx('U_Common.ClearFiguresonListDelete', E.Message); end; end; end; end; // это чтобы не попытался перерисовать то, чего нет (вдруг при закрытии листа куча компонент выбрана) GCadForm.PCad.Selection.Clear; // finally //aCAD.PCad.EndMultiDeselect; //aCAD.PCad.EnableAlign; end; GClearFigures := False; except on E: Exception do begin GClearFigures := False; // на всякий addExceptionToLogEx('U_Common.ClearFiguresonListDelete', E.Message); EndProgress; //Exit; end; end; //if figuresTodelList <> nil then //figuresTodelList.free; AddrList.Clear; FreeAndNil(AddrList); //FigList.Clear; //FreeAndNil(FigList); EndProgress; GClearFigures := False; GCanRefreshCad := CadRefreshFlag; end; begin try //Tolik 01/09/2022 -- PCad.SetTool(toSelect, ''); // // //Tolik LHandle2 := PCad.GetLayerHandle(2); LHandle3 := PCad.GetLayerHandle(3); LHandle4 := PCad.GetLayerHandle(4); LHandle5 := PCad.GetLayerHandle(5); LHandle6 := PCad.GetLayerHandle(6); LHandle8 := PCad.GetLayerHandle(8); LHandle9 := PCad.GetLayerHandle(9); FigList := TList.Create; //Tolik 01/09/2022 -- { for i := 0 to PCad.FigureCount - 1 do begin FFigure := TFigure(PCad.Figures[i]); if (FFigure.LayerHandle = LHandle2) or (FFigure.LayerHandle = LHandle3) or (FFigure.LayerHandle = LHandle4) or (FFigure.LayerHandle = LHandle5) or (FFigure.LayerHandle = LHandle6) or (FFigure.LayerHandle = LHandle8) or (FFigure.LayerHandle = LHandle9) then FigList.Add(FFigure); end; } for i := PCad.FigureCount - 1 downto 0 do begin FFigure := TFigure(PCad.Figures[i]); if (FFigure.LayerHandle = LHandle2) or (FFigure.LayerHandle = LHandle3) or (FFigure.LayerHandle = LHandle4) or (FFigure.LayerHandle = LHandle5) or (FFigure.LayerHandle = LHandle6) or (FFigure.LayerHandle = LHandle8) or (FFigure.LayerHandle = LHandle9) then begin PCad.Figures.Delete(i); FigList.Add(FFigure); //FFigure.Free; end; end; ClearFigures(FigList); // // а вот здесь вопрос...что делать с потеряшками? { for i := 0 to PCad.FigureCount - 1 do begin FFigure := TFigure(PCad.Figures[i]); if LayersList.OndexOf(FFigure.LayerHandle)) <> -1 then FigList.Add(FFigure); end;} //Tolik 01/09/2022 -- (* for i := 0 to FigList.Count - 1 do begin FFigure := TFigure(FigList[i]); if FFigure is TFigureGrp then RemoveInFigureGrp(TFigureGrp(FFigure)); PCad.Figures.Remove(FFigure); try //Tolik 26/10/2015 можно смело удалять, даже если групповая фигура ... раньше ее удаление могло привести к АВ, так как // FSingleBlock для ортолинии "сидел" как на КАДе, так и в DrawFiruge. Из-за дубляжа возникала ошибка, т.к. получалось // двойное удаление, но так, как было совсем не годится -- потенциальная утечка памяти вследсвие НЕ УДАЛЕНИЯ ГРУППОВЫХ ФИГУР // if not(FFigure is TFigureGrp) then //10/12/2016 -- убивать, только если это -- НЕ ФИГУРА ОТРИСОВКИ (иначе ебнется перерисовка Када) if not Assigned(GShadowObject) then FreeAndNil(FFigure) else if FFigure.ID <> GShadowObject.ID then FreeAndNil(FFigure); except end; end; *) //Tolik -- 28/12/2016 -- {if Assigned(GShadowObject) then PCad.Figures.Add(GShadowObject);} // //FreeAndNil(FigList); //Tolik // 31/10/2015 чтобы после Undo/Redo не возникло спонтанного непонятного удаления фигур, // списки удаляемых фигур до Undo/Redo тоже нужно почистить, иначе по ним отработает PCad.GuiEvent FRemFigures.Clear; FFiguresDelManual.Clear; // FSCSFigures.Clear; RefreshCAD(PCad); except // on E: Exception do addExceptionToLogEx('TF_CAD.ClearSCSFigures', E.Message); end; end; (* procedure TF_CAD.ClearSCSFigures; var i: integer; FigureCount: Integer; FFigure: TFigure; // Tolik LHandle2: Integer; LHandle3: Integer; LHandle4: Integer; LHandle5: Integer; LHandle6: Integer; LHandle8: Integer; LHandle9: Integer; LayersList: TIntList; // FigList: TList; Count: Integer; begin try //Tolik 01/09/2022 -- PCad.SetTool(toSelect, ''); // // //Tolik LHandle2 := PCad.GetLayerHandle(2); LHandle3 := PCad.GetLayerHandle(3); LHandle4 := PCad.GetLayerHandle(4); LHandle5 := PCad.GetLayerHandle(5); LHandle6 := PCad.GetLayerHandle(6); LHandle8 := PCad.GetLayerHandle(8); LHandle9 := PCad.GetLayerHandle(9); FigList := TList.Create; //Tolik 01/09/2022 -- { for i := 0 to PCad.FigureCount - 1 do begin FFigure := TFigure(PCad.Figures[i]); if (FFigure.LayerHandle = LHandle2) or (FFigure.LayerHandle = LHandle3) or (FFigure.LayerHandle = LHandle4) or (FFigure.LayerHandle = LHandle5) or (FFigure.LayerHandle = LHandle6) or (FFigure.LayerHandle = LHandle8) or (FFigure.LayerHandle = LHandle9) then FigList.Add(FFigure); end; } for i := PCad.FigureCount - 1 downto 0 do begin FFigure := TFigure(PCad.Figures[i]); if (FFigure.LayerHandle = LHandle2) or (FFigure.LayerHandle = LHandle3) or (FFigure.LayerHandle = LHandle4) or (FFigure.LayerHandle = LHandle5) or (FFigure.LayerHandle = LHandle6) or (FFigure.LayerHandle = LHandle8) or (FFigure.LayerHandle = LHandle9) then begin PCad.Figures.Delete(i); FFigure.Free; end; end; // // а вот здесь вопрос...что делать с потеряшками? { for i := 0 to PCad.FigureCount - 1 do begin FFigure := TFigure(PCad.Figures[i]); if LayersList.OndexOf(FFigure.LayerHandle)) <> -1 then FigList.Add(FFigure); end;} //Tolik 01/09/2022 -- (* for i := 0 to FigList.Count - 1 do begin FFigure := TFigure(FigList[i]); if FFigure is TFigureGrp then RemoveInFigureGrp(TFigureGrp(FFigure)); PCad.Figures.Remove(FFigure); try //Tolik 26/10/2015 можно смело удалять, даже если групповая фигура ... раньше ее удаление могло привести к АВ, так как // FSingleBlock для ортолинии "сидел" как на КАДе, так и в DrawFiruge. Из-за дубляжа возникала ошибка, т.к. получалось // двойное удаление, но так, как было совсем не годится -- потенциальная утечка памяти вследсвие НЕ УДАЛЕНИЯ ГРУППОВЫХ ФИГУР // if not(FFigure is TFigureGrp) then //10/12/2016 -- убивать, только если это -- НЕ ФИГУРА ОТРИСОВКИ (иначе ебнется перерисовка Када) if not Assigned(GShadowObject) then FreeAndNil(FFigure) else if FFigure.ID <> GShadowObject.ID then FreeAndNil(FFigure); except end; end; *) //Tolik -- 28/12/2016 -- {if Assigned(GShadowObject) then PCad.Figures.Add(GShadowObject);} // //FreeAndNil(FigList); //Tolik // 31/10/2015 чтобы после Undo/Redo не возникло спонтанного непонятного удаления фигур, // списки удаляемых фигур до Undo/Redo тоже нужно почистить, иначе по ним отработает PCad.GuiEvent (* FRemFigures.Clear; FFiguresDelManual.Clear; // FSCSFigures.Clear; RefreshCAD(PCad); except // on E: Exception do addExceptionToLogEx('TF_CAD.ClearSCSFigures', E.Message); end; end; *) ///////////////////////////////////////////////////////////////////////////////////////////////////// procedure TF_CAD.ClearPlanFigures; var i: integer; FigureCount: Integer; FFigure: TFigure; LHandle1: Integer; FigList: TList; Count: Integer; begin try LHandle1 := PCad.GetLayerHandle(1); FigList := TList.Create; for i := 0 to PCad.FigureCount - 1 do begin FFigure := TFigure(PCad.Figures[i]); if (FFigure.LayerHandle = LHandle1) then FigList.Add(FFigure); end; // Tolik // 31/10/2015 чтобы после Undo/Redo не возникло спонтанного непонятного удаления фигур, // списки удаляемых фигур до Undo/Redo тоже нужно почистить, иначе по ним отработает PCad.GuiEvent FRemFigures.Clear; FFiguresDelManual.Clear; // for i := 0 to FigList.Count - 1 do begin FFigure := TFigure(FigList[i]); if FFigure is TFigureGrp then RemoveInFigureGrp(TFigureGrp(FFigure)); PCad.Figures.Remove(FFigure); try // Tolik 26/10/2015 -- удалять нужно все // if not(FFigure is TFigureGrp) then // FreeAndNil(FFigure); except end; end; FreeAndNil(FigList); RefreshCAD(PCad); except // on E: Exception do addExceptionToLogEx('TF_CAD.ClearPlanFigures', E.Message); end; end; procedure TF_CAD.ClearUndoList(AFreeList: Boolean=true); var i: Integer; FileName: string; ListUndoAction: TListUndoAction; begin try if FSCSUndoList <> nil then begin for i := 0 to FSCSUndoList.Count - 1 do begin ListUndoAction := TListUndoAction(FSCSUndoList[i]); FileName := ListUndoAction.FCadFileName; if FileExists(FileName) then DeleteFile(FileName); // очистить ссылки на других этажах if ListUndoAction.ActionType = uat_Floor then begin // завязки на другие этажи - удалить всю цепочку DeleteProjectUndoActions(Self, ListUndoAction); end; // удалить объект UndoAction FreeAndNil(ListUndoAction); end; if AFreeList then //13.03.2012 FreeAndNil(FSCSUndoList) else FSCSUndoList.Clear; end; except on E: Exception do addExceptionToLogEx('TF_CAD.ClearUndoList', E.Message); end; end; function TF_CAD.BeginSaveForUndo(aType: TListUndoActionType; aSavePM: Boolean; aIsProject: Boolean; aProjectIndex: Integer = 0): TListUndoAction; begin Result := nil; if FUndoCount = 0 then begin FUndoCount := FUndoCount + 1; Result := SaveForUndo(aType, aSavePM, aIsProject, aProjectIndex); end; end; procedure TF_CAD.EndSaveForUndo; begin if FUndoCount > 0 then FUndoCount := FUndoCount - 1; end; procedure TF_CAD.FOnBeforeMove(Sender: TObject; Figure: TFigure; aDeltaX: double = -999999; aDeltaY: double = -999999); var i: Integer; vList: TList; vSavePM: Boolean; Conn, PointObject: TConnectorObject; BreakedPoints: TDoublePoint; vFigure: TFigure; oldx, oldy, newx, newy: double; //Tolik 15/11/2017 -- SelectedFigure: TFigure; // begin // Tolik -- 07/02/2017 -- vList := nil; // try if (PCad.ActiveLayer = lnArch) or CheckOneOfSCSlayers(PCad.ActiveLayer) then begin // *UNDO* if FCanSaveForUndo then begin vList := GetRelatedListsBySelected(PCad.Selection, cst_Move); if vList.Count = 1 then begin vSavePM := false; // будет привязка if GFigureSnap <> nil then vSavePM := True; // будет отвязка соединителя // Tolik 15/11/2017 -- if Pcad.SelectedCount > 0 then begin for i := 0 to PCad.Selection.Count - 1 do begin SelectedFigure := TFigure(PCad.Selection[i]); if CheckFigureByClassName(SelectedFigure, cTConnectorObject) then if TConnectorObject(SelectedFigure).ConnectorType = ct_Clear then if TConnectorObject(SelectedFigure).JoinedConnectorsList.Count >= 1 then begin PointObject := TConnectorObject(TConnectorObject(SelectedFigure).JoinedConnectorsList[0]); BreakedPoints.x := TConnectorObject(SelectedFigure).ActualPoints[1].x + aDeltaX; BreakedPoints.y := TConnectorObject(SelectedFigure).ActualPoints[1].y + aDeltaY; if CheckByBreakConnectorByCoords(BreakedPoints, PointObject) then begin vSavePM := True; break; end; end; end; end; // {if Pcad.SelectedCount = 1 then if CheckFigureByClassName(TFigure(PCad.Selection[0]), cTConnectorObject) then if TConnectorObject(PCad.Selection[0]).ConnectorType = ct_Clear then if TConnectorObject(PCad.Selection[0]).JoinedConnectorsList.Count = 1 then begin Conn := TConnectorObject(PCad.Selection[0]); PointObject := TConnectorObject(Conn.JoinedConnectorsList[0]); BreakedPoints.x := Conn.ActualPoints[1].x + aDeltaX; BreakedPoints.y := Conn.ActualPoints[1].y + aDeltaY; if CheckByBreakConnectorByCoords(BreakedPoints, PointObject) then vSavePM := True; end; } // проверить на смену нахождения в/вне кабинетов for i := 0 to PCad.SelectedCount - 1 do begin vFigure := TFigure(PCad.Selection[i]); if CheckFigureByClassName(vFigure, cTConnectorObject) or CheckFigureByClassName(vFigure, cTOrthoLine) then begin oldx := vFigure.ActualPoints[1].x; oldy := vFigure.ActualPoints[1].y; newx := vFigure.ActualPoints[1].x + aDeltaX; newy := vFigure.ActualPoints[1].y + aDeltaY; if GetCabinetAtPos(oldx, oldy, False) <> GetCabinetAtPos(newx, newy, False) then begin vSavePM := True; Break; end; end else if vFigure is TNet then //24.01.2011 begin // Если меняем размер окна/двери за мод.поинт то сохраняем МП чтобі сохранились параметры откосов if (DragState = dsMod) and (TNet(vFigure).FComponID <> 0) then vSavePM := True; end; end; if ssCtrl in GGlobalShiftState then begin vSavePM := True; end; // двигаются кабинеты if PCad.ActiveLayer = 9 then if Figure <> nil then if CheckFigureByClassName(Figure, cTCabinet) or CheckFigureByClassName(Figure, cTCabinetExt) then vSavePM := True; SaveForUndo(uat_None, vSavePM, False); end else begin if GFigureSnap = nil then SaveForProjectUndo(vList, False, False) else SaveForProjectUndo(vList, True, False); end; end; end else if FListType = lt_ProjectPlan then begin SaveForUndo(uat_None, False, False); end; except on E: Exception do addExceptionToLogEx('TF_CAD.FOnBeforeMove', E.Message); end; // Tolik -- 07/02/2017 -- if vList <> nil then FreeAndNil(vList); // end; procedure TF_CAD.FOnMoveByArrows(Sender: TObject; dx, dy: Double; var CanMove: Boolean); var vSavePM: Boolean; Conn, PointObject: TConnectorObject; BreakedPoints: TDoublePoint; // Tolik -- SelectedFigure: TFigure; i: Integer; // begin try if (PCad.ActiveLayer = lnArch) or CheckOneOfSCSlayers(PCad.ActiveLayer) then begin vSavePM := false; // будет отвязка соединителя // Tolik 15/11/2017 -- if Pcad.SelectedCount > 0 then begin for i := 0 to PCad.Selection.Count - 1 do begin SelectedFigure := TFigure(PCad.Selection[i]); if CheckFigureByClassName(SelectedFigure, cTConnectorObject) then if TConnectorObject(SelectedFigure).ConnectorType = ct_Clear then if TConnectorObject(SelectedFigure).JoinedConnectorsList.Count >= 1 then begin PointObject := TConnectorObject(TConnectorObject(SelectedFigure).JoinedConnectorsList[0]); BreakedPoints.x := TConnectorObject(SelectedFigure).ActualPoints[1].x + dx; BreakedPoints.y := TConnectorObject(SelectedFigure).ActualPoints[1].y + dy; if CheckByBreakConnectorByCoords(BreakedPoints, PointObject) then begin vSavePM := True; break; end; end; end; end; { if Pcad.SelectedCount = 1 then if CheckFigureByClassName(TFigure(PCad.Selection[0]), cTConnectorObject) then if TConnectorObject(PCad.Selection[0]).ConnectorType = ct_Clear then if TConnectorObject(PCad.Selection[0]).JoinedConnectorsList.Count = 1 then begin Conn := TConnectorObject(PCad.Selection[0]); PointObject := TConnectorObject(Conn.JoinedConnectorsList[0]); BreakedPoints.x := Conn.ActualPoints[1].x + dx; BreakedPoints.y := Conn.ActualPoints[1].y + dy; if CheckByBreakConnectorByCoords(BreakedPoints, PointObject) then vSavePM := True; end; } // *UNDO* if FCanSaveForUndo then begin SaveForUndo(uat_None, vSavePM, False); FCanSaveForUndo := False; end; end; except on E: Exception do addExceptionToLogEx('TF_CAD.FOnMoveByArrows', E.Message); end; end; constructor TListUndoAction.Create(aType: TListUndoActionType; aSavePM: Boolean); begin inherited create; ActionType := aType; FSavePM := aSavePM; FProjectUndoAction := nil; FCadFileName := ''; FBasePath := ''; FIsProject := False; end; destructor TListUndoAction.Destroy; begin inherited; end; { TProjectUndoAction } constructor TProjectUndoAction.Create; begin inherited; FLinkUndoObject := TList.Create; end; destructor TProjectUndoAction.Destroy; begin inherited; end; { TLinkUndoObject } constructor TLinkUndoObject.Create; begin inherited; FCad := nil; FListUndoAction := nil; end; destructor TLinkUndoObject.Destroy; begin inherited; end; function TF_CAD.CheckMakeSaveForUndo: boolean; begin Result := False; try if (FActiveActions = 0) or (FActiveActions mod FSaveUndoCount = 0) then Result := True else Result := False; except on E: Exception do addExceptionToLogEx('TF_CAD.CheckMakeSaveForUndo', E.Message); end; end; procedure TF_CAD.BuildPopupFiguresByLevel(AFiguresList:TList; AOnClick: TNotifyEvent; AX: Double=-1; AY: Double=-1); var i: Integer; FFigure: TFigure; FHeightStr: String; Coord1, Coord2: Double; Item: TMenuItem; begin FSCS_Main.pmFiguresByLevel.Items.Clear; for i := 0 to AFiguresList.Count - 1 do begin FFigure := TFigure(AFiguresList[i]); // Tolik 11/07/2018-- if CheckFigureByClassName(FFigure, cTConnectorObject) then if TConnectorObject(FFigure).ConnectorType = ct_Clear then if TConnectorObject(FFigure).JoinedConnectorsList.Count > 0 then Continue; // Item := TMenuItem.Create(FSCS_Main.pmFiguresByLevel); FHeightStr := ''; if CheckFigureByClassName(FFigure, cTOrthoLine) then begin if TOrthoLine(FFigure).ActualZOrder[1] = TOrthoLine(FFigure).ActualZOrder[2] then FHeightStr := FormatFloat(ffMask, MetreToUOM(TOrthoLine(FFigure).ActualZOrder[1])) else begin //07.02.2011 FHeightStr := FormatFloat(ffMask, MetreToUOM(TOrthoLine(FFigure).ActualZOrder[1])) + '-' + //07.02.2011 FormatFloat(ffMask, MetreToUOM(TOrthoLine(FFigure).ActualZOrder[2])); Coord1 := TOrthoLine(FFigure).ActualZOrder[1]; Coord2 := TOrthoLine(FFigure).ActualZOrder[2]; if Coord2 < Coord1 then ExchangeDouble(Coord1, Coord2); FHeightStr := FormatFloat(ffMask, MetreToUOM(Coord1)) +'-'+ FormatFloat(ffMask, MetreToUOM(Coord2)); end; end else if CheckFigureByClassName(FFigure, cTConnectorObject) then FHeightStr := FormatFloat(ffMask, MetreToUOM(TConnectorObject(FFigure).ActualZOrder[1])); Item.Caption := GetFullFigureName(FFigure, AX, AY) + ' (' + FHeightStr + GetUOMString(GCurrProjUnitOfMeasure) + ')' ; FSCS_Main.pmFiguresByLevel.Items.Add(Item); Item.Tag := FFigure.ID; Item.OnClick := AOnClick; end; end; //Tolik 19/03/2021 -- procedure TF_CAD.cbMagnetToWallsClick(Sender: TObject); begin if GCadForm.cbMagnetToWalls.Down then GCadForm.cbMagnetToWalls.Hint := MagnetMsg1 else GCadForm.cbMagnetToWalls.Hint := MagnetMsg2; end; procedure TF_CAD.cbManualCableTracingModeClick(Sender: TObject); begin //GAutoAddCableAfterDragDrop := false; //cbManualCableTracingMode.Down := not cbManualCableTracingMode.Down; //if GCallElectricAutoTraceMaster then // GAutoAddCableAfterDragDrop := not cbManualCableTracingMode.Down; GAutoAddCableAfterDragDrop := cbManualCableTracingMode.Down; end; // function TF_CAD.RemoveFigureFromSelected(AFigure: TFigure): Integer; begin Result := PCad.Selection.IndexOf(AFigure); if Result <> -1 then begin AFigure.Selected := false; PCad.Selection.Delete(Result); end; end; procedure TF_CAD.RemoveSelectedWithoutCheck; //var //SavedAutoDelete: Boolean; begin FWasDeleteQuery := true; GCanDeleteFigures := true; //SavedAutoDelete := GAutoDelete; //GAutoDelete := False; //try //PCad.OnBeforeDelete := nil; PCad.RemoveSelection; //finally //GAutoDelete := SavedAutoDelete; //end; end; //function TF_CAD.OnGetShowPathLength(Sender: TObject): Double; //begin // Result := TNetPath(Sender).GetLenForShow(FShowPathLineType); //end; function TF_CAD.OnGetShowPathLengthType(Sender: TObject): TShowPathLengthType; begin Result := FShowPathLengthType; if TNetPath(Sender).WStyle = wsLine then Result := sltPoints; end; function TF_CAD.OnGetShowPathTraceLengthType(Sender: TObject): TShowPathLengthType; begin Result := FShowPathTraceLengthType; if TNetPath(Sender).WStyle = wsLine then Result := sltPoints; end; procedure TF_CAD.AddSCSFigure(AFigure: TFigure); begin if FSCSFiguresLockCount = 0 then FSCSFigures.Insert(AFigure, @AFigure.ID); end; procedure TF_CAD.RemoveSCSFigure(AFigure: TFigure); begin if FSCSFiguresLockCount = 0 then FSCSFigures.Remove(AFigure.ID); end; procedure TF_CAD.LockSCSFigures; begin Inc(FSCSFiguresLockCount); end; procedure TF_CAD.UnLockSCSFigures; begin if FSCSFiguresLockCount > 0 then Dec(FSCSFiguresLockCount); end; procedure TF_CAD.ClearFrameFigures; var i: integer; begin Self.FFrameProjectName := nil; Self.FFrameListName := nil; Self.FFrameCodeName := nil; Self.FFrameIndexName := nil; Self.FFrameStampDeveloper := nil; Self.FFrameStampChecker := nil; for i := 0 to Self.FFrameObjects.Count - 1 do Self.FFrameObjects.Objects[i] := nil; end; procedure TF_CAD.SetFrameFigures; //18.11.2011 var i: Integer; Figure: TRichText; ObjIdx: integer; begin for i := 0 to FFrameObjects.Count - 1 do begin Figure := TRichText(FFrameObjects.Objects[i]); ObjIdx := StrToInt(FFrameObjects[i]); case ObjIdx of ftProjectName: FFrameProjectName := Figure; ftListName: FFrameListName := Figure; ftCodeName: FFrameCodeName := Figure; ftIndexName: FFrameIndexName := Figure; ftDeveloperName: FFrameStampDeveloper := Figure; ftCheckerName: FFrameStampChecker := Figure; end; end; end; procedure TF_CAD.DeleteLayerAllObjects(aLayerNumber: Integer; aQuast: Boolean); begin Self.PCad.DeselectAll(0); Self.PCad.SelectAll(aLayerNumber); Self.DeleteSelection(aQuast); end; procedure TF_CAD.DeleteSelection(aQuast: Boolean); var SavedAutoDelete: Boolean; begin if Self.PCad.SelectedCount > 0 then begin SavedAutoDelete := GAutoDelete; if Not aQuast then begin GAutoDelete := false; GCanDeleteFigures := True; FWasDeleteQuery := True; end; try Self.PCad.RemoveSelection; RefreshCAD(Self.PCad); if not GProjectChanged then // Tolik 28/08/2019 -- SetProjectChanged(True); finally GAutoDelete := SavedAutoDelete; end; end; end; procedure TF_CAD.View3D; var File3D: String; begin File3D := F_ProjMan.GSCSBase.CurrProject.GetListBySCSID(FCADListID).File3D; PCad.View3D(File3D); end; function TF_CAD.Get3DModel: TObject; begin Result := PCad.Get3DModel(F_ProjMan.GSCSBase.CurrProject.GetListBySCSID(FCADListID).File3D); end; function TF_CAD.GetMsgLengthToPoint(const aLen: Double): String; begin Result := cCad_Mes15 + FormatFloat(ffMask, MetreToUOM(aLen)) + GetUOMString(GCurrProjUnitOfMeasure); end; function TF_CAD.CreateConnector(x,y,z: Double; aLayerHandle: Integer; aConnectorType: TConnectorType; const aName: string): TConnectorObject; var ObjParams: TObjectParams; begin Result := TConnectorObject.Create(x, y, z, aLayerHandle, PCTypesUtils.mydsNormal, PCad); Result.ConnectorType := ct_Clear; PCad.AddCustomFigure (GLN(aLayerHandle), Result, False); Result.Name := cCadClasses_Mes12; SetNewObjectNameInPM(Result.ID, Result.Name); ObjParams := GetFigureParams(Result.ID); Result.Name := ObjParams.Name; Result.FIndex := ObjParams.MarkID; end; function TF_CAD.CreateConnForFloorRaise(x,y,z: Double; aLayerHandle: Integer): TConnectorObject; //var // RaiseOnFigure: TConnectorObject; // ObjParams: TObjectParams; begin //RaiseOnFigure := TConnectorObject.Create(x, y, z, aLayerHandle, mydsNormal, PCad); // RaiseOnFigure.ConnectorType := ct_Clear; // PCad.AddCustomFigure (GLN(aLayerHandle), RaiseOnFigure, False); // RaiseOnFigure.Name := cCadClasses_Mes12; // SetNewObjectNameInPM(RaiseOnFigure.ID, RaiseOnFigure.Name); // ObjParams := GetFigureParams(RaiseOnFigure.ID); // RaiseOnFigure.Name := ObjParams.Name; // RaiseOnFigure.FIndex := ObjParams.MarkID; // // Result := RaiseOnFigure; Result := CreateConnector(x,y,z, aLayerHandle, ct_Clear, cCadClasses_Mes12); end; procedure TF_CAD.ClearRedoList(AFreeList: Boolean=true); var i: Integer; FileName: string; ListUndoAction: TListUndoAction; begin try if FSCSRedoList <> nil then begin for i := 0 to FSCSRedoList.Count - 1 do begin ListUndoAction := TListUndoAction(FSCSRedoList[i]); FileName := ListUndoAction.FCadFileName; if FileExists(FileName) then DeleteFile(FileName); // очистить ссылки на других этажах if ListUndoAction.ActionType = uat_Floor then begin // завязки на другие этажи - удалить всю цепочку //17.08.2012 - почемуто UndoActions, хотя здесь Redo //17.08.2012 DeleteProjectUndoActions(Self, ListUndoAction); DeleteProjectRedoActions(Self, ListUndoAction); end; // удалить объект UndoAction FreeAndNil(ListUndoAction); end; if AFreeList then FreeAndNil(FSCSRedoList) //13.03.2012 else FSCSRedoList.Clear; end; except on E: Exception do AddExceptionToLogEx('TF_CAD.ClearRedoList', E.Message); end; end; function TF_CAD.SaveForRedo(aType: TListUndoActionType; aSavePM, aIsProject: Boolean; aProjectIndex: Integer): TListUndoAction; var SavedGCadForm: TF_CAD; begin Result := nil; //Tolik 16/08/2021 -- GetPathToSCSCADDir; GetPathToRedoDir; // try SavedGCadForm := GCadForm; GCadForm := Self; if FListType = lt_Normal then Result := SaveForRedoNormalList(aType, aSavePM, aIsProject, aProjectIndex) else if FListType = lt_ProjectPlan then Result := SaveForRedoProjectPlan(aType, aSavePM, aIsProject, aProjectIndex) else if FListType = lt_DesignBox then Result := SaveForRedoDesignList(aType, aSavePM, aIsProject, aProjectIndex) else if FListType = lt_ElScheme then //Result := SaveForRedoElScheme(aType, aSavePM, aIsProject, aProjectIndex); Result := SaveForRedoNormalList(aType, aSavePM, aIsProject, aProjectIndex) else if FListType = lt_AScheme then Result := SaveForRedoNormalList(aType, aSavePM, aIsProject, aProjectIndex); GCadForm := SavedGCadForm; except on E: Exception do AddExceptionToLogEx('TF_CAD.SaveForRedo', E.Message); end; end; function TF_CAD.SaveForRedoDesignList(aType: TListUndoActionType; aSavePM, aIsProject: Boolean; aProjectIndex: Integer): TListUndoAction; var i, j: integer; Count: Integer; OldFName, FName: string; SetUndoName: string; ListUndoAction: TListUndoAction; tmpCad: TPowerCad; Stream: TMemoryStream; size: integer; BasePath: string; begin Result := nil; //Tolik 16/08/2021 -- GetPathToSCSCADDir; GetPathToRedoDir; // try if FSCSRedoList = nil then FSCSRedoList := TList.Create; // кол-во откатов переполнено, сместить. if FSCSRedoList.Count = 10 then begin // удалить первый файл в списке ListUndoAction := TListUndoAction(FSCSRedoList[0]); FName := ListUndoAction.FCadFileName; // удалить файл if FileExists(FName) then DeleteFile(FName); // удалить элемент из списка файлов FSCSRedoList.Delete(0); // *UNDO ProjectManager* DeleteUndoFromPM(FCADListID, ListUndoAction.FBasePath, ListUndoAction.FIsProject); // удалить объект UndoAction if ListUndoAction.ActionType = uat_Floor then begin // завязки на другие этажи - удалить всю цепочку DeleteProjectRedoActions(Self, ListUndoAction); end; FreeAndNil(ListUndoAction); // переприсвоить имена файлов с учетом смещения for i := 0 to FSCSRedoList.Count - 1 do begin ListUndoAction := TListUndoAction(FSCSRedoList[i]); // FName := FRedoDir + FCADListName + IntTostr(FCADListIndex) + '_' + IntToStr(i); FName := FRedoDir + FCADListFileName + '_' + IntToStr(i); OldFName := ListUndoAction.FCadFileName; RenameFile(OldFName, FName); ListUndoAction.FCadFileName := FName; end; end; ListUndoAction := TListUndoAction.Create(aType, aSavePM); // записать последнее изменение в файл, название в FUndoList Count := FSCSRedoList.Count; // SetUndoName := FRedoDir + FCADListName + IntTostr(FCADListIndex) + '_' + IntToStr(Count); SetUndoName := FRedoDir + FCADListFileName + '_' + IntToStr(Count); // сохранить в список файлов ListUndoAction.FCadFileName := SetUndoName; ListUndoAction.FIndex := Count; ListUndoAction.FIsProject := aIsProject; FSCSRedoList.Add(ListUndoAction); // сохранить в темповый файл FUndoFiguresList.Clear; PCad.SavePlanFiguresToFile(SetUndoName); ListUndoAction.FBasePath := ''; Result := ListUndoAction; except on E: Exception do AddExceptionToLogEx('TF_CAD.SaveForRedoDesignList', E.Message); end; end; // Tolik 12/02/2021 -- function TF_CAD.SaveForRedoElScheme(aType: TListUndoActionType; aSavePM: Boolean; aIsProject: Boolean; aProjectIndex: Integer = 0): TListUndoAction; var i, j: integer; Count: Integer; OldFName, FName: string; SetUndoName: string; ListUndoAction: TListUndoAction; tmpCad: TPowerCad; Stream: TMemoryStream; size: integer; BasePath: string; begin Result := nil; //Tolik 16/08/2021 -- GetPathToSCSCADDir; GetPathToRedoDir; // try if FSCSRedoList = nil then FSCSRedoList := TList.Create; // кол-во откатов переполнено, сместить. if FSCSRedoList.Count = 10 then begin // удалить первый файл в списке ListUndoAction := TListUndoAction(FSCSRedoList[0]); FName := ListUndoAction.FCadFileName; // удалить файл if FileExists(FName) then DeleteFile(FName); // удалить элемент из списка файлов FSCSRedoList.Delete(0); // *UNDO ProjectManager* DeleteUndoFromPM(FCADListID, ListUndoAction.FBasePath, ListUndoAction.FIsProject); // удалить объект UndoAction if ListUndoAction.ActionType = uat_Floor then begin // завязки на другие этажи - удалить всю цепочку DeleteProjectRedoActions(Self, ListUndoAction); end; FreeAndNil(ListUndoAction); // переприсвоить имена файлов с учетом смещения for i := 0 to FSCSRedoList.Count - 1 do begin ListUndoAction := TListUndoAction(FSCSRedoList[i]); // FName := FRedoDir + FCADListName + IntTostr(FCADListIndex) + '_' + IntToStr(i); FName := FRedoDir + FCADListFileName + '_' + IntToStr(i); OldFName := ListUndoAction.FCadFileName; RenameFile(OldFName, FName); ListUndoAction.FCadFileName := FName; end; end; ListUndoAction := TListUndoAction.Create(aType, aSavePM); // записать последнее изменение в файл, название в FUndoList Count := FSCSRedoList.Count; // SetUndoName := FRedoDir + FCADListName + IntTostr(FCADListIndex) + '_' + IntToStr(Count); SetUndoName := FRedoDir + FCADListFileName + '_' + IntToStr(Count); // сохранить в список файлов ListUndoAction.FCadFileName := SetUndoName; ListUndoAction.FIndex := Count; ListUndoAction.FIsProject := aIsProject; FSCSRedoList.Add(ListUndoAction); // сохранить в темповый файл FUndoFiguresList.Clear; PCad.SaveElSchemeFiguresToFile(SetUndoName); ListUndoAction.FBasePath := ''; Result := ListUndoAction; except on E: Exception do AddExceptionToLogEx('TF_CAD.SaveForRedoElScheme', E.Message); end; end; procedure TF_CAD.SetShowPathLengthType(AShowPathLengthType: TShowPathLengthType); begin FShowPathLengthType := AShowPathLengthType; SetParamsByShowPathLengthType(tbShowPathLengthType, AShowPathLengthType, FSCS_Main.aPathLengthTypePoints, FSCS_Main.aPathLengthTypeInner, FSCS_Main.aPathLengthTypeOuter, 1); end; procedure TF_CAD.SetShowPathTraceLengthType(AShowPathLengthType: TShowPathLengthType); begin FShowPathTraceLengthType := AShowPathLengthType; SetParamsByShowPathLengthType(tbShowPathTraceLengthType, AShowPathLengthType, FSCS_Main.aPathTraceLengthTypePoints, FSCS_Main.aPathTraceLengthTypeInner, FSCS_Main.aPathTraceLengthTypeOuter, 2); end; procedure TF_CAD.SetParamsByShowPathLengthType(AToolButton: TToolButton; AShowPathLengthType: TShowPathLengthType; APoints, AInner, AOuter: TCustomAction; ACaption: Integer); var SrcAct: TCustomAction; begin SrcAct := nil; case AShowPathLengthType of sltPoints: SrcAct := APoints; sltInner: SrcAct := AInner; sltOuter: SrcAct := AOuter; end; if SrcAct <> nil then begin SrcAct.Checked := true; AToolButton.ImageIndex := SrcAct.ImageIndex; Case ACaption of 1: AToolButton.Hint := cShowPathLengthTypeHint + ' - '+ SrcAct.Hint; 2: AToolButton.Hint := {AToolButton.Caption}cShowPathLengthLineTypeHint + ' - '+ SrcAct.Hint; end; end; end; function TF_CAD.SaveForRedoNormalList(aType: TListUndoActionType; aSavePM, aIsProject: Boolean; aProjectIndex: Integer): TListUndoAction; var i, j: integer; Count: Integer; OldFName, FName: string; SetUndoName: string; ListUndoAction: TListUndoAction; tmpCad: TPowerCad; Stream: TMemoryStream; size: integer; CanProcess: Boolean; BasePath: string; SaveGCadRefreshFlag: boolean; begin Result := nil; //Tolik 16/08/2021 -- GetPathToSCSCADDir; GetPathToRedoDir; // try SaveGCadRefreshFlag := GCanRefreshCad; GCanRefreshCad := false; CanProcess := true; // *UNDO ProjectManager* BasePath := ''; if (aSavePM) and ((not aIsProject) or (aProjectIndex = 0)) then begin BasePath := SavePMForUndo(FCADListID, aIsProject); CanProcess := BasePath <> ''; end; if CanProcess then begin if FSCSRedoList = nil then FSCSRedoList := TList.Create; // кол-во откатов переполнено, сместить. if FSCSRedoList.Count = 10 then begin // удалить первый файл в списке ListUndoAction := TListUndoAction(FSCSRedoList[0]); FName := ListUndoAction.FCadFileName; // удалить файл if FileExists(FName) then DeleteFile(FName); // удалить элемент из списка файлов FSCSRedoList.Delete(0); // *UNDO ProjectManager* DeleteUndoFromPM(FCADListID, ListUndoAction.FBasePath, ListUndoAction.FIsProject); // удалить объект UndoAction if ListUndoAction.ActionType = uat_Floor then begin // завязки на другие этажи - удалить всю цепочку DeleteProjectRedoActions(Self, ListUndoAction); end; FreeAndNil(ListUndoAction); // переприсвоить имена файлов с учетом смещения for i := 0 to FSCSRedoList.Count - 1 do begin ListUndoAction := TListUndoAction(FSCSRedoList[i]); // FName := FRedoDir + FCADListName + IntTostr(FCADListIndex) + '_' + IntToStr(i); FName := FRedoDir + FCADListFileName + '_' + IntToStr(i); OldFName := ListUndoAction.FCadFileName; RenameFile(OldFName, FName); ListUndoAction.FCadFileName := FName; end; end; ListUndoAction := TListUndoAction.Create(aType, aSavePM); // записать последнее изменение в файл, название в FUndoList Count := FSCSRedoList.Count; // SetUndoName := FRedoDir + FCADListName + IntTostr(FCADListIndex) + '_' + IntToStr(Count); SetUndoName := FRedoDir + FCADListFileName + '_' + IntToStr(Count); // сохранить в список файлов ListUndoAction.FCadFileName := SetUndoName; ListUndoAction.FIndex := Count; ListUndoAction.FIsProject := aIsProject; FSCSRedoList.Add(ListUndoAction); // сохранить в темповый файл FUndoFiguresList.Clear; PCad.SaveSCSFiguresToFile(SetUndoName); // *UNDO ProjectManager* //16.08.2011 if (aSavePM) and ((not aIsProject) or (aProjectIndex = 0)) then //16.08.2011 BasePath := SavePMForUndo(FCADListID, ListUndoAction.FIsProject) //16.08.2011 else //16.08.2011 BasePath := ''; ListUndoAction.FBasePath := BasePath; Result := ListUndoAction; end; except on E: Exception do AddExceptionToLogEx('TF_CAD.SaveForRedoNormalList', E.Message); end; GCanRefreshCad := SaveGCadRefreshFlag; end; function TF_CAD.SaveForRedoProjectPlan(aType: TListUndoActionType; aSavePM, aIsProject: Boolean; aProjectIndex: Integer): TListUndoAction; var i, j: integer; Count: Integer; OldFName, FName: string; SetUndoName: string; ListUndoAction: TListUndoAction; tmpCad: TPowerCad; Stream: TMemoryStream; size: integer; BasePath: string; begin Result := nil; //Tolik 16/08/2021 -- GetPathToSCSCADDir; GetPathToRedoDir; // try if FSCSRedoList = nil then FSCSRedoList := TList.Create; // кол-во откатов переполнено, сместить. if FSCSRedoList.Count = 10 then begin // удалить первый файл в списке ListUndoAction := TListUndoAction(FSCSUndoList[0]); FName := ListUndoAction.FCadFileName; // удалить файл if FileExists(FName) then DeleteFile(FName); // удалить элемент из списка файлов FSCSRedoList.Delete(0); // удалить объект UndoAction FreeAndNil(ListUndoAction); // переприсвоить имена файлов с учетом смещения for i := 0 to FSCSRedoList.Count - 1 do begin ListUndoAction := TListUndoAction(FSCSRedoList[i]); // FName := FRedoDir + FCADListName + IntTostr(FCADListIndex) + '_' + IntToStr(i); FName := FRedoDir + FCADListFileName + '_' + IntToStr(i); OldFName := ListUndoAction.FCadFileName; RenameFile(OldFName, FName); ListUndoAction.FCadFileName := FName; end; end; ListUndoAction := TListUndoAction.Create(aType, aSavePM); // записать последнее изменение в файл, название в FUndoList Count := FSCSRedoList.Count; // SetUndoName := FRedoDir + FCADListName + IntTostr(FCADListIndex) + '_' + IntToStr(Count); SetUndoName := FRedoDir + FCADListFileName + '_' + IntToStr(Count); // сохранить в список файлов ListUndoAction.FCadFileName := SetUndoName; ListUndoAction.FIndex := Count; ListUndoAction.FIsProject := aIsProject; FSCSRedoList.Add(ListUndoAction); // сохранить в темповый файл FUndoFiguresList.Clear; PCad.SavePlanFiguresToFile(SetUndoName); ListUndoAction.FBasePath := ''; Result := ListUndoAction; except on E: Exception do AddExceptionToLogEx('TF_CAD.SaveForRedoProjectPlan', E.Message); end; end; procedure TF_CAD.SCSRedoDesignList; var FName: string; i, j: integer; ListUndoAction: TListUndoAction; LinkUndoObject: TLinkUndoObject; Stream: TMemoryStream; size: integer; CountInPrj: Integer; OldTick1, OldTick2, OldTick3, CurTick1, CurTick2, CurTick3: Cardinal; CurListParams: TListParams; ListOfLists: TList; SavedGCadForm: TF_CAD; begin try //Tolik 23/06/2021 -- if FSCSRedoList = nil then FSCSRedoList := TList.Create; PCad.ReDo; exit; // if FSCSRedoList = nil then exit; // IGOR 2017-04-25 если это не сделать, дебагить после анду/реду потом нереально при включенном стоп-он АВ self.UnSnapFigure; GPrevFigureTraceTo := nil; GPrevFigureSnap := nil; GFigureSnap := nil; BeginProgress; if FSCSRedoList.Count > 0 then begin ListUndoAction := TListUndoAction(FSCSRedoList[FSCSRedoList.Count - 1]); FName := ListUndoAction.FCadFileName; // есть файл if FileExists(FName) then begin // Перед UNDO, создается слепок текущего состояния для REDO if ListUndoAction.ActionType = uat_Floor then begin ListOfLists := TList.Create; CountInPrj := ListUndoAction.FProjectUndoAction.FLinkUndoObject.Count; for i := 0 to ListUndoAction.FProjectUndoAction.FLinkUndoObject.Count - 1 do begin LinkUndoObject := TLinkUndoObject(ListUndoAction.FProjectUndoAction.FLinkUndoObject[i]); ListOfLists.Add(LinkUndoObject.FCad); end; SaveForProjectUndo(ListOfLists, ListUndoAction.FSavePM, ListUndoAction.FIsProject); FreeAndNil(ListOfLists); end else begin CountInPrj := 1; SaveForUndoDesignList(ListUndoAction.ActionType, ListUndoAction.FSavePM, ListUndoAction.FIsProject, CountInPrj); end; // ClearPlanFigures; PCad.OnObjectInserted := nil; FUndoFiguresList.Clear; PCad.LoadSCSFiguresFromFile(FName); PCad.OnObjectInserted := PCadObjectInserted; FUndoStatus := True; if GListWithEndPoint = Self then begin GEndPoint := nil; GListWithEndPoint := nil; end; FUndoStatus := False; // удалить файл if FileExists(FName) then DeleteFile(FName); // удалить последний который поднимается из спика FSCSRedoList.Delete(FSCSRedoList.Count - 1); // есть связи с другими этажами - поднять со всех связанных листов if ListUndoAction.ActionType = uat_Floor then begin LoadProjectRedoActions(Self, ListUndoAction); end; // List Params CurListParams := GetListParams(FCADListID); FCanSaveForUndo := False; LoadSettingsForListByParams(CurListParams, True); FCanSaveForUndo := True; end else FSCSRedoList.Remove(ListUndoAction); // удалить объект UndoAction FreeAndNil(ListUndoAction); end; except on E: Exception do AddExceptionToLogEx('TF_CAD.SCSRedoDesignList', E.Message); end; EndProgress; end; procedure TF_CAD.SCSRedoNormalList; var FName: string; i, j: integer; ListUndoAction: TListUndoAction; LinkUndoObject: TLinkUndoObject; Stream: TMemoryStream; size: integer; CountInPrj: Integer; OldTick1, OldTick2, OldTick3, CurTick1, CurTick2, CurTick3: Cardinal; CurListParams: TListParams; ListOfLists: TList; SavedGCadForm: TF_CAD; NetObj: TNet; Figure: TFigure; //Tolik CadFigList: TList; // aNeedEnd: boolean; SaveGCadRefreshFlag: boolean; begin try SaveGCadRefreshFlag := GCanRefreshCad; if FSCSRedoList = nil then exit; GCanRefreshCad := false; // IGOR 2017-04-25 если это не сделать, дебагить после анду/реду потом нереально при включенном стоп-он АВ self.UnSnapFigure; GPrevFigureTraceTo := nil; GPrevFigureSnap := nil; GFigureSnap := nil; FullEndUpdateCad(true); // Tolik 24/03/2021 -- BeginProgress; if FSCSRedoList.Count > 0 then begin ListUndoAction := TListUndoAction(FSCSRedoList[FSCSRedoList.Count - 1]); FName := ListUndoAction.FCadFileName; // есть файл if FileExists(FName) then begin // Перед REDO, создается слепок текущего состояния для UNDO if ListUndoAction.ActionType = uat_Floor then begin ListOfLists := TList.Create; CountInPrj := 0; for i := 0 to ListUndoAction.FProjectUndoAction.FLinkUndoObject.Count - 1 do begin LinkUndoObject := TLinkUndoObject(ListUndoAction.FProjectUndoAction.FLinkUndoObject[i]); if LinkUndoObject.FCad.FListType = lt_Normal then begin CountInPrj := CountInPrj + 1; ListOfLists.Add(LinkUndoObject.FCad); end; end; SaveForProjectUndo(ListOfLists, ListUndoAction.FSavePM, ListUndoAction.FIsProject); FreeAndNil(ListOfLists); end else begin CountInPrj := 1; SaveForUndoNormalList(ListUndoAction.ActionType, ListUndoAction.FSavePM, ListUndoAction.FIsProject, CountInPrj); end; // перед очисткой сбросим чтобы сработала проверка в TConnectorObject.Destroy; PCad.OnObjectInserted := nil; ClearSCSFigures; //PCad.OnObjectInserted := nil; FUndoFiguresList.Clear; PCad.LoadSCSFiguresFromFile(FName); PCad.OnObjectInserted := PCadObjectInserted; FUndoStatus := True; try if GListWithEndPoint = Self then begin GEndPoint := nil; GListWithEndPoint := nil; end; GNeedReRaiseProperties := False; // Tolik CadFiglist := TList.Create; for i := 0 to PCad.FigureCount - 1 do CadFigList.Add(TFigure(PCad.Figures.Items[i])); // for i := 0 to CadFigList.Count - 1 do begin Figure := TFigure(CadFigList[i]); if CheckFigureByClassName(Figure, 'TNet') then begin NetObj := TNet(Figure); if NetObj.FComponID = 0 then begin FActiveNet := NetObj; ActiveNet := FActiveNet; end; end else if CheckFigureByClassName(Figure, cTConnectorObject) then TConnectorObject(Figure).RaiseProperties(CadFigList) else if CheckFigureByClassName(Figure, cTOrthoLine) then TOrthoLine(Figure).RaiseProperties(CadFigList) else if CheckFigureByClassName(Figure, cTSCSFigureGrp) then TSCSFigureGrp(Figure).RaiseProperties(CadFigList) else if CheckFigureByClassName(Figure, cTCabinet) then TCabinet(Figure).RaiseProperties(CadFigList) else if CheckFigureByClassName(Figure, cTCabinetExt) then TCabinetExt(Figure).RaiseProperties(CadFigList) else if CheckFigureByClassName(Figure, cTHouse) then THouse(Figure).RaiseProperties(CadFigList); end; FreeAndNil(CadFigList); { for i := 0 to PCad.FigureCount - 1 do begin Figure := TFigure(PCad.Figures.Items[i]); if CheckFigureByClassName(Figure, 'TNet') then begin NetObj := TNet(Figure); if NetObj.FComponID = 0 then begin FActiveNet := NetObj; ActiveNet := FActiveNet; end; end else if CheckFigureByClassName(Figure, cTConnectorObject) then TConnectorObject(Figure).RaiseProperties else if CheckFigureByClassName(Figure, cTOrthoLine) then TOrthoLine(Figure).RaiseProperties else if CheckFigureByClassName(Figure, cTSCSFigureGrp) then TSCSFigureGrp(Figure).RaiseProperties else if CheckFigureByClassName(Figure, cTCabinet) then TCabinet(Figure).RaiseProperties else if CheckFigureByClassName(Figure, cTCabinetExt) then TCabinetExt(Figure).RaiseProperties else if CheckFigureByClassName(Figure, cTHouse) then THouse(Figure).RaiseProperties; end; if GNeedReRaiseProperties then begin i := 0; while i < PCad.FigureCount do begin Figure := TFigure(PCad.Figures.Items[i]); if CheckFigureByClassName(Figure, cTConnectorObject) then begin TConnectorObject(Figure).ReRaiseProperties; end; if CheckFigureByClassName(Figure, cTOrthoLine) then begin TOrthoLine(Figure).ReRaiseProperties; end; i := i + 1; end; end; } finally FUndoStatus := False; end; FindObjectsForConvertClasses; PCad.DrawFigures(True); // удалить файл if FileExists(FName) then DeleteFile(FName); // удалить последний который поднимается из спика FSCSRedoList.Delete(FSCSRedoList.Count - 1); // *UNDO ProjectManager* UndoListInPM(FCADListID, ListUndoAction.FBasePath, ListUndoAction.FIsProject, 0, CountInPrj); // есть связи с другими этажами - поднять со всех связанных листов if ListUndoAction.ActionType = uat_Floor then begin LoadProjectRedoActions(Self, ListUndoAction); end; // List Params CurListParams := GetListParams(FCADListID); FCanSaveForUndo := False; LoadSettingsForListByParams(CurListParams, True); SetVisibleCabinetsNumbers(FShowCabinetsNumbers); SetVisibleCabinetsBounds(FShowCabinetsBounds); FCanSaveForUndo := True; end else FSCSRedoList.Remove(ListUndoAction); // удалить объект UndoAction FreeAndNil(ListUndoAction); end; except on E: Exception do AddExceptionToLogEx('TF_CAD.SCSRedoNormalList', E.Message); end; GCanRefreshCad := SaveGCadRefreshFlag; EndProgress; end; procedure TF_CAD.SCSRedoProjectPlan; var FName: string; i, j: integer; ListUndoAction: TListUndoAction; Stream: TMemoryStream; size: integer; CountInPrj: Integer; CurListParams: TListParams; SavedGCadForm: TF_CAD; Figure: TFigure; begin try // Tolik 25/06/2021 -- if FSCSRedoList = nil then FSCSRedoList := TList.Create; PCad.ReDo; exit; // if FSCSRedoList = nil then exit; // IGOR 2017-04-25 если это не сделать, дебагить после анду/реду потом нереально при включенном стоп-он АВ self.UnSnapFigure; GPrevFigureTraceTo := nil; GPrevFigureSnap := nil; GFigureSnap := nil; BeginProgress; if FSCSRedoList.Count > 0 then begin ListUndoAction := TListUndoAction(FSCSRedoList[FSCSRedoList.Count - 1]); FName := ListUndoAction.FCadFileName; // есть файл if FileExists(FName) then begin // Перед UNDO, создается слепок текущего состояния для REDO SaveForUndoProjectPlan(ListUndoAction.ActionType, ListUndoAction.FSavePM, ListUndoAction.FIsProject, 1); // ClearPlanFigures; PCad.OnObjectInserted := nil; FUndoFiguresList.Clear; PCad.LoadSCSFiguresFromFile(FName); PCad.OnObjectInserted := PCadObjectInserted; FUndoStatus := True; try for i := 0 to PCad.FigureCount - 1 do begin Figure := TFigure(PCad.Figures.Items[i]); if CheckFigureByClassName(Figure, cTPlanObject) then TPlanObject(Figure).RaiseProperties(PCad.Figures) else if CheckFigureByClassName(Figure, cTPlanConnector) then TPlanConnector(Figure).RaiseProperties(PCad.Figures) else if CheckFigureByClassName(Figure, cTPlanTrace) then TPlanTrace(Figure).RaiseProperties(PCad.Figures); end; finally FUndoStatus := False; end; // удалить файл if FileExists(FName) then DeleteFile(FName); // удалить последний который поднимается из спика FSCSRedoList.Delete(FSCSRedoList.Count - 1); CurListParams := GetListParams(FCADListID); FCanSaveForUndo := False; LoadSettingsForListByParams(CurListParams, True); FCanSaveForUndo := True; end else FSCSRedoList.Remove(ListUndoAction); // удалить объект UndoAction FreeAndNil(ListUndoAction); end; except on E: Exception do AddExceptionToLogEx('TF_CAD.SCSRedoProjectPlan', E.Message); end; EndProgress; end; // Tolik 12/02/2021 -- procedure TF_CAD.SCSRedoElScheme; var FName: string; i, j: integer; ListUndoAction: TListUndoAction; Stream: TMemoryStream; size: integer; CountInPrj: Integer; CurListParams: TListParams; SavedGCadForm: TF_CAD; Figure: TFigure; begin try {if FSCSRedoList = nil then exit;} if FSCSRedoList = nil then FSCSRedoList := TList.Create; PCad.ReDo; exit; // IGOR 2017-04-25 если это не сделать, дебагить после анду/реду потом нереально при включенном стоп-он АВ self.UnSnapFigure; GPrevFigureTraceTo := nil; GPrevFigureSnap := nil; GFigureSnap := nil; BeginProgress; if FSCSRedoList.Count > 0 then begin ListUndoAction := TListUndoAction(FSCSRedoList[FSCSRedoList.Count - 1]); FName := ListUndoAction.FCadFileName; // есть файл if FileExists(FName) then begin // Перед UNDO, создается слепок текущего состояния для REDO SaveForUndoELScheme(ListUndoAction.ActionType, ListUndoAction.FSavePM, ListUndoAction.FIsProject, 1); // ClearPlanFigures; PCad.OnObjectInserted := nil; FUndoFiguresList.Clear; PCad.LoadSCSFiguresFromFile(FName); PCad.OnObjectInserted := PCadObjectInserted; // удалить файл if FileExists(FName) then DeleteFile(FName); // удалить последний который поднимается из спика FSCSRedoList.Delete(FSCSRedoList.Count - 1); CurListParams := GetListParams(FCADListID); FCanSaveForUndo := False; LoadSettingsForListByParams(CurListParams, True); FCanSaveForUndo := True; end else FSCSRedoList.Remove(ListUndoAction); // удалить объект UndoAction FreeAndNil(ListUndoAction); end; except on E: Exception do AddExceptionToLogEx('TF_CAD.SCSRedoElScheme', E.Message); end; EndProgress; end; // procedure TF_CAD.PCadAfterDelete(Sender: TObject); var i: integer; Figure: TFigure; begin try {//17.11.2011 if FFrameProjectName <> nil then if FFrameProjectName.Deleted then FFrameProjectName := nil; if FFrameListName <> nil then if FFrameListName.Deleted then FFrameListName := nil; if FFrameCodeName <> nil then if FFrameCodeName.Deleted then FFrameCodeName := nil; if FFrameIndexName <> nil then if FFrameIndexName.Deleted then FFrameIndexName := nil;} for i := 0 to Self.FFrameObjects.Count - 1 do begin Figure := TFigure(Self.FFrameObjects.Objects[i]); if Figure <> nil then if Figure.Deleted then Self.FFrameObjects.Objects[i] := nil; end; except on E: Exception do AddExceptionToLogEx('TF_CAD.PCadAfterDelete', E.Message); end; end; procedure TF_CAD.TimerFindSnapTimer(Sender: TObject); begin TTimer(Sender).Enabled := false; end; procedure TF_CAD.PCadGetFigureToSelect(Sender: Tobject; var Figure: TFigure; x, y: double); var //Net: TNet; SelPath: TNetPath; FigureIndex: Integer; i: Integer; f: TFigure; FigureChanged: Boolean; FiguresList: TList; FigureI: TFigure; //ClickFigure: TFigure; ExistsSelected: Boolean; begin //21.06.2013 - на TF_CAD.PCadSurfaceMove эти координаты могут не всегда определятся, например если висит PopupMenu GCurrMousePos.x := X; GCurrMousePos.y := Y; if Figure <> nil then begin try FigureChanged := false; if Figure is TNet then begin // Если Figure просто сегмент (без дочернего объекта), а в этой точке есть окно/дверь другого сегмента //Net := TNet(Figure); if TNet(Figure).GetSelPathChild = nil then begin FigureIndex := TPCDrawing(Sender).Figures.IndexOf(Figure); for i := FigureIndex -1 downto 0 do begin f := TFigure(TPCDrawing(Sender).Figures[i]); if (f.LayerHandle = Figure.LayerHandle) and (f is TNet) then begin // Если на этих координатах есть объект с окном if (TNet(f).GetSelPathChild <> nil) and f.isPointIn(x, y) then begin Figure := f; FigureChanged := true; FigureBringToFront(Figure); Break; //// BREAK //// end; end; end; end; if Not FigureChanged And (TNet(Figure).SelPath <> nil) then begin // Если кликаем по сегменту с Alt, то даем возможность выбрать сегмент другого TNet if (ssAlt in GGlobalShiftState) {and (GArchEngine.FPrevSelCADObj = TNet(Figure).SelPath)} then begin // Если не нашли следующий сегмент по этим координатам, то ищем в других TNet if Not TNet(Figure).SelectNextPathByPt(x,y) then begin for i := 0 to TPCDrawing(Sender).Figures.Count -1 do begin f := TFigure(TPCDrawing(Sender).Figures[i]); if (f.LayerHandle = Figure.LayerHandle) and (f is TNet) and (Figure <> f) then begin // Если на этих координатах есть объект с окном if f.isPointIn(x, y) and (TNet(f).SelPath <> nil) then begin Figure := f; FigureChanged := true; FigureBringToFront(Figure); //TPCDrawing(Sender).OrderFigureToFront(Figure); Break; //// BREAK //// end; end; end; if Not FigureChanged then begin // Выделяем первый сегмент TNet(Figure).SelectPath(0); if Not TNet(Figure).SelectNextPathByPt(x,y) then FigureChanged := true; end; end else FigureChanged := true; end; end; // Если изменений небыло, вернуть все внутренние селекты if Not FigureChanged then Figure.isPointIn(x, y); end else if (Figure is TConnectorObject) or (Figure is TOrtholine) then //21.06.2013 begin FClickSCSFiguresList.Clear; // Если в точке есть несколько объектов, которые будут отображены через popupMenu, и нету выделенного среди их, // тогда вернем nil чтобы ничего не выделять if FClickType = ct_Single then begin //try // ClickFigure := CheckBySCSObjects(GCurrMousePos.x, GCurrMousePos.y); //except // ClickFigure := nil; //end; //if ClickFigure <> Figure then // EmptyProcedure; // поиск других объектов на данной высоте if GFigureSnap = nil then if (PCad.ToolIdx = toSelect) and (not GCadForm.FCreateObjectOnClick) then begin // формировать список объектов //FiguresList := GetFiguresByLevel(ClickFigure, GCurrMousePos.x, GCurrMousePos.y, False, true); FiguresList := GetFiguresByLevel(Figure, GCurrMousePos.x, GCurrMousePos.y, False, true); if FiguresList.Count > 1 then begin ExistsSelected := false; for i := 0 to FiguresList.Count - 1 do begin FigureI := TFigure(FiguresList[i]); if FigureI.Selected then //23.06.2013 - Если была выделена трасса, и кликнули по коннектору, то эту выделенную трассу не оставляем для следующего выделения, оставляем только однотипніе if FigureI.ClassName = Figure.ClassName then begin if (FigureI.ClassName = ctConnectorObject) then begin if not TConnectorObject(FigureI).isToRaise then begin ExistsSelected := true; Figure := FigureI; Break; //// BREAK //// end; end else begin ExistsSelected := true; Figure := FigureI; Break; //// BREAK //// end; end; end; {//23.06.2013 - пока оставляем объект, т.к. бывают случаи когда нужно сразу потянуть за него} if Not ExistsSelected then begin FClickSCSFiguresList.Assign(FiguresList); //23.06.2013 Figure := nil; end;{} end else begin if FiguresList.Count = 1 then begin Figure := TFigure(FiguresList[0]); FClickSCSFiguresList.Add(Figure); end; end; FreeAndNil(FiguresList); end; end; end; except on E: Exception do AddExceptionToLogExt(ClassName, 'PCadGetFigureToSelect', E.Message); end; end; end; procedure TF_CAD.PCadGetModPointToSelect(Sender: Tobject; var ModPoint: TModPoint; x, y: double); var i: Integer; f: TFigure; NewFigure: TFigure; NewModPoint: TModPoint; FigureChanged: Boolean; begin try FigureChanged := false; NewFigure := nil; if Assigned(ModPoint.Figure) and (ModPoint.Figure is TNet) then begin if (ssAlt in GGlobalShiftState) then begin if Not TNet(ModPoint.Figure).SelectNextPointByPt(x,y) then begin for i := 0 to TPCDrawing(Sender).Figures.Count -1 do begin f := TFigure(TPCDrawing(Sender).Figures[i]); if (f.LayerHandle = ModPoint.Figure.LayerHandle) and (f is TNet) and (ModPoint.Figure <> f) then begin // Если на этих координатах есть объект с окном if f.isPointIn(x, y) and (TNet(f).SelPt <> nil) then begin NewFigure := f; FigureChanged := true; FigureBringToFront(NewFigure); //TPCDrawing(Sender).OrderFigureToFront(Figure); Break; //// BREAK //// end; end; end; if Not FigureChanged then begin // Выделяем первую точку TNet(ModPoint.Figure).SelectPt(nil); if Not TNet(ModPoint.Figure).SelectNextPointByPt(x,y) then begin NewFigure := ModPoint.Figure; FigureChanged := true; end; end; end else begin NewFigure := ModPoint.Figure; FigureChanged := true; end; end; if NewFigure <> nil then begin //TNet(NewFigure.SelPoints.Add( // CControl.RegisterModPoint(self, ptArcControl, ptRect, clGreen, 3, path.ArcCenter.x, path.ArcCenter.y, i)); if ModPoint.Figure <> NewFigure then begin ModPoint.Figure.deselect; NewFigure.Select; end; //?? NewModPoint := NewFigure.GetModPointBySeqNbr(TNet(NewFigure).FSelPtIdx, x, y); if NewModPoint <> nil then ModPoint := NewModPoint; end; end; except on E: Exception do AddExceptionToLogExt(ClassName, 'PCadGetModPointToSelect', E.Message); end; end; procedure TF_CAD.PCadBeforeEndTrace(Sender: TObject); //25.11.2011 begin if Sender = PCad then begin if PCad.SnapInfo = TPrintRect.ClassName then begin //FSCS_Main.aPrintRect.Checked := false; FSCS_Main.tbPrintRect.Down := false; FSCS_Main.aToolSelect.Execute; end; end; end; function TF_CAD.PCadCheckPrnWithOffset(Sender: Tobject): Boolean; var CurListParams: TListParams; begin CurListParams := GetListParams(FCADListID); Result := Not CurListParams.Settings.CADStampForPrinter; end; procedure TF_CAD.tbDropDownClick(Sender: TObject); var tb: TToolButton; MenuItem: TMenuItem; NextMenuItem: TMenuItem; i: Integer; begin if Sender is TToolButton then begin tb := TToolButton(Sender); if tb.DropdownMenu <> nil then begin NextMenuItem := nil; for i := 0 to tb.DropdownMenu.Items.Count - 1 do begin MenuItem := TMenuItem(tb.DropdownMenu.Items[i]); if MenuItem.ImageIndex = tb.ImageIndex then begin if i < (tb.DropdownMenu.Items.Count-1) then NextMenuItem := TMenuItem(tb.DropdownMenu.Items[i+1]) else NextMenuItem := TMenuItem(tb.DropdownMenu.Items[0]); Break; //// BREAK //// end; end; if NextMenuItem <> nil then begin NextMenuItem.Click; end; end; end; end; procedure TF_CAD.TimerMovePanTimer(Sender: TObject); begin TTimer(Sender).Tag := 999; TTimer(Sender).Enabled := false; if (FDeltaX <> 0) or (FDeltaY <> 0) then begin // Tolik 18/04/2017 -- // if Self.ClassName = 'TPowerCad' then if Self.ClassName = 'TF_CAD' then // MoveCADOnPan(FDeltaX, FDeltaY); end; TTimer(Sender).Tag := 0; end; procedure TF_CAD.TimerShowPopupTimer(Sender: TObject); begin TimerShowPopup.Enabled := False; if GPopupMenu <> nil then begin if PCad.Selection.Count > 0 then GPopupMenu.Popup(Round(gx), Round(gy)); GPopupMenu := nil; end; end; procedure TF_CAD.FormDestroy(Sender: TObject); begin FreeAndNil(FClickSCSFiguresList); FreeAndNil(FFiguresDelManual); FreeAndNil(FSCSFigures); // Tolik -- 28/04/2017 -- if ((GCadForm <> nil) and (GCadForm = Self)) then GCadForm := Nil; // end; procedure TF_CAD.PCadTraceDraw(Sender: TObject; Figure: TFigure; DeltaX: double = -999999; DeltaY: double = -999999); var p: TDoublePoint; pIdx: Integer; pDist, MinDist: Double; i: integer; PolySeg: TPlSegment; FRect: TDoubleRect; CADTraceFigure: TFigure; CADFigure: TFigure; FigurePointCount: Integer; Procedure CADDrawTraceText(x,y:Integer;Color, BColor:TColor; Text,FontName:String;FontSize:Integer;Canvas:TCanvas); var bmp: Graphics.Tbitmap; begin bmp := Graphics.Tbitmap.Create; bmp.Canvas.Font.Name := FontName; bmp.Canvas.Font.Size := FontSize; bmp.Width := bmp.Canvas.TextWidth(text)+10; bmp.Height := bmp.Canvas.TextHeight(text)+2;//10; bmp.Canvas.Brush.Color := BColor; //clSilver; //clGray; //clBlack; bmp.Canvas.Brush.Style := bsSolid; bmp.Canvas.FillRect(Rect(0,0,bmp.Width,bmp.Height)); bmp.Canvas.Font.Color := Color; //clBlack; //Color; bmp.Canvas.TextOut(2,0,Text); Canvas.CopyMode := SRCINVERT; //GTestCopyMode; //SRCINVERT; Canvas.Draw(x,y,bmp); bmp.Free; Canvas.CopyMode := SRCCOPY; end; procedure TraceTextDrawPt(p1, p2, xp: TDoublePoint; const aTextPrefix: String=''; aShowZero: Boolean=true; aWithBrush: Boolean=false); var Len: Double; Text: String; z:Double; Color, bcolor: TColor; begin Len := Pcad.GetLineLengthM(p1, p2); //GetLineLenght(p1, p2) / 1000 * Pcad.MapScale; if Not CmpFloatByPrecision(Len, 0, 3) or aShowZero then begin Text := FormatFloat(ffMask, MetreToUOM(Len)) + GetUOMString(GCurrProjUnitOfMeasure); z := 0; Pcad.Dengine.ConvertCoord(xp.x, xp.y,z); Color := clLime; bcolor := clBlack; Pcad.DEngine.Canvas.pen.mode := pmXor; if aWithBrush then begin Color := clBlack; bcolor := clSilver; Pcad.DEngine.Canvas.pen.mode := pmCopy; end; CADDrawTraceText(Round(xp.x),Round(xp.y), color, bcolor, aTextPrefix + Text, 'Arial', 8, Pcad.Dengine.Canvas); end; end; procedure TraceTextDraw(p1, p2: TDoublePoint; const aTextPrefix: String=''; aShowZero: Boolean=true; aWithBrush: Boolean=false); var xp: TDoublePoint; begin // смещаем влево p1.x := p1.x + 1; p2.x := p2.x + 1; xp := MPoint(p1, p2); TraceTextDrawPt(p1, p2, xp, aTextPrefix, aShowZero, aWithBrush); end; {procedure TraceTextDrawOld(p1, p2: TDoublePoint; const aTextPrefix: String=''; aShowZero: Boolean=true; aWithBrush: Boolean=false); var Len: Double; xp: TDoublePoint; Text: String; z:Double; Color, bcolor: TColor; begin // смещаем влево p1.x := p1.x + 1; p2.x := p2.x + 1; Len := GetLineLenght(p1, p2) / 1000 * Pcad.MapScale; if Not CmpFloatByPrecision(Len, 0, 3) or aShowZero then begin Text := FormatFloat(ffMask, MetreToUOM(Len)) + GetUOMString(GCurrProjUnitOfMeasure); xp := MPoint(p1, p2); //ang := GetRadOfLine(p1, p2); //if EQD(ang , pi) then // ang := 0; //if EQD(ang, 3 * pi / 2) then // ang := pi / 2; //Pcad.DEngine.Canvas.pen.mode := pmXor; //Pcad.DEngine.DrawCenteredText(xp, clLime, Text, 'Arial', 8, ang); //DEngine.DrawCenteredText(xp, clBlack, Info, 'Verdana', 2.5, ang); //Pcad.Dengine.TraceText(xp, clLime, aTextPrefix + Text, 'Arial', 8); z := 0; Pcad.Dengine.ConvertCoord(xp.x,xp.y,z); Color := clLime; bcolor := clBlack; Pcad.DEngine.Canvas.pen.mode := pmXor; if aWithBrush then begin Color := clBlack; bcolor := clSilver; Pcad.DEngine.Canvas.pen.mode := pmCopy; end; CADDrawTraceText(Round(xp.x),Round(xp.y), color, bcolor, aTextPrefix + Text, 'Arial', 8, Pcad.Dengine.Canvas); end; end;} begin //if DragState <> dsMove then begin if Figure.ClassName = TLine.ClassName then TraceTextDraw(Figure.ap1, Figure.ap2) else if Figure.ClassName = TRectangle.ClassName then begin TraceTextDraw(Figure.ap1, Figure.ap2); TraceTextDraw(Figure.ap2, Figure.ap3); end else if Figure.ClassName = TCircle.ClassName then begin p := Figure.ap1; p.x := p.x - 4; // чучть смещаем чтобы текст сдвигался к средине TraceTextDraw(p, DoublePoint(p.x + TCircle(Figure).radius, p.y), cCadClasses_Mes33+' '); end else if Figure.ClassName = TEllipse.ClassName then begin p := Figure.ap1; p.x := p.x - 4; // чучть смещаем чтобы текст сдвигался к средине TraceTextDraw(p, DoublePoint(p.x + TEllipse(Figure).alen, p.y), cCadClasses_Mes33+'1 '); TraceTextDraw(p, DoublePoint(p.x, p.y + TEllipse(Figure).blen), cCadClasses_Mes33+'2 '); end else if Figure.ClassName = TArc.ClassName then begin p := Figure.ap1; p.x := p.x - 4; // чучть смещаем чтобы текст сдвигался к средине TraceTextDraw(p, DoublePoint(p.x + TArc(Figure).radius, p.y), cCadClasses_Mes33+' '); // длина между точками дуги TraceTextDraw(TArc(Figure).actualpoints[2], TArc(Figure).actualpoints[3], '', false); end else if Figure.ClassName = TElpArc.ClassName then begin p := Figure.ap1; p.x := p.x - 4; // чучть смещаем чтобы текст сдвигался к средине TraceTextDraw(p, DoublePoint(p.x + TElpArc(Figure).alen, p.y), cCadClasses_Mes33+'1 '); TraceTextDraw(p, DoublePoint(p.x, p.y + TElpArc(Figure).blen), cCadClasses_Mes33+'2 '); // длина между точками дуги TraceTextDraw(TElpArc(Figure).actualpoints[2], TElpArc(Figure).actualpoints[3], '', false); end; if DragState = dsNone then begin if Figure.ClassName = TOrthoLine.ClassName then TraceTextDraw(Figure.ap1, Figure.ap2) else if Figure.ClassName = TPolyline.ClassName then begin PolySeg := nil; if TPolyline(Figure).Segments.Count > 0 then PolySeg := TPlSegment(TPolyline(Figure).Segments[TPolyline(Figure).Segments.Count - 1]); if PolySeg <> nil then begin if Figure.PointCount > 1 then TraceTextDraw(Figure.actualpoints[Figure.PointCount-1], Figure.actualpoints[Figure.PointCount]); if PolySeg.SType = sArc then begin TraceTextDraw(PolySeg.CPoint1, PolySeg.Cpoint2); end; end; end; end; end; if DragState = dsMove then begin //FRect := Figure.GetBoundRect; //p := DoublePoint(FRect.Left, FRect.Top); //TraceTextDraw(p, DoublePoint(p.x + (FCurrX-DragStartX+dragDeltaX), p.y + (FCurrY-DragStartY+dragDeltaY))); //TraceTextDraw(p, DoublePoint(p.x - (DragStartX+dragDeltaX - FCurrX), p.y - (DragStartY+dragDeltaY - FCurrY))); //TraceTextDraw(DoublePoint(DragStartX, DragStartY), Doublepoint(FCurrX, FCurrY)); if PCad.Selection.Count = 1 then begin //TraceTextDraw(Figure.ActualPoints[1], TFigure(PCad.Selection[0]).ActualPoints[1], cCadClasses_Mes34+' ', true, true); pIdx := 0; MinDist := -1; CADTraceFigure := Figure; CADFigure := TFigure(PCad.Selection[0]); {if PCad.Selection.Count = 1 then CADFigure := TFigure(PCad.Selection[0]) else CADFigure := GetFigureByOrign(PCad.Selection);} FigurePointCount := CADTraceFigure.PointCount; // если попытка переместить TNet, то не выводим инфу if (Figure.ClassName = TPathTrace.ClassName) or (CADFigure.ClassName = TNet.ClassName) then FigurePointCount := 0 else if (Figure.ClassName = TConnectorObject.ClassName) and (Figure.ClassName = CADFigure.ClassName) then begin //CADTraceFigure := TConnectorObject(Figure).DrawFigure; //CADFigure := TConnectorObject(PCad.Selection[0]).DrawFigure; FigurePointCount := 4; end; if FigurePointCount > 0 then begin for i := 1 to FigurePointCount do begin pDist := GetLineLenght(CADTraceFigure.ActualPoints[i], DoublePoint(0,0)); if (MinDist = -1) or (pDist < MinDist) then begin MinDist := pDist; pIdx := i; end; end; //p := CADTraceFigure.ActualPoints[pIdx]; //MPoint(CADTraceFigure.ActualPoints[1], TFigure(PCad.Selection[0]).ActualPoints[1], 5); //p.y := p.y - 5; {TODO} // выводим на панель - доделать что бы на панель только для СКС слоя вывод был //sbView.Panels[1].Text:=cCadClasses_Mes34+' '+FormatFloat(ffMask, MetreToUOM(Pcad.GetLineLengthM(CADTraceFigure.ActualPoints[pIdx], CADFigure.ActualPoints[pIdx]))) + GetUOMString(GCurrProjUnitOfMeasure);//ther test FRect := CADTraceFigure.GetBoundRect; p := DoublePoint(FRect.Left, FRect.Top-5); {//TraceTextDraw(CADTraceFigure.ActualPoints[1], p, cCadClasses_Mes34+' ', true, true);} TraceTextDrawPt(CADTraceFigure.ActualPoints[pIdx], CADFigure.ActualPoints[pIdx], p, cCadClasses_Mes34+' ', false, true); end; end; end; end; procedure TF_CAD.PCadFigureEdit(Sender: TObject; Figure: TFigure; DeltaX: double = -999999; DeltaY: double = -999999); var ObjProps: TSCSComponent; ObjOldProps: TSCSComponent; EnterStr: String; Res: Boolean; p1Idx, p2Idx: Integer; FloatOldVal, FloatNewVal: Double; i: Integer; PName: String; begin TPowerCad(Sender).OnFigureEdit := nil; try Res := true; ObjProps := nil; ObjOldProps := nil; if Figure.ClassName = TRectangle.ClassName then begin {ObjProps := TSCSComponent.Create(F_ProjMan); //ObjProps.AddSimpleProperty(pnLength, cArchParams_Msg01, FloatToStr(GetLineLength(Figure.ap1, Figure.ap2) / 1000 * PCad.MapScale), dtFloat); //ObjProps.AddSimpleProperty(pnWidth, cArchParams_Msg02, FloatToStr(GetLineLength(Figure.ap2, Figure.ap3) / 1000 * PCad.MapScale), dtFloat); ObjProps.AddSimpleProperty(pnLength, cArchParams_Msg01, FloatToStr(GetLineLength(Figure.ap1, Figure.ap2)), dtFloat); ObjProps.AddSimpleProperty(pnWidth, cArchParams_Msg02, FloatToStr(GetLineLength(Figure.ap2, Figure.ap3)), dtFloat);} //Tolik 18/10/2017 -- F_BlockParams.Execute(Figure, false, false, cDrawObjects_Mes14); // end else if Figure.ClassName = TEllipse.ClassName then begin ObjProps := TSCSComponent.Create(F_ProjMan); ObjProps.AddSimpleProperty(pnLength, cCadClasses_Mes33+' 1', FloatToStr(TEllipse(Figure).alen), dtFloat); ObjProps.AddSimpleProperty(pnWidth, cCadClasses_Mes33+' 2', FloatToStr(TEllipse(Figure).blen), dtFloat); end else if Figure.ClassName = TElpArc.ClassName then begin ObjProps := TSCSComponent.Create(F_ProjMan); ObjProps.AddSimpleProperty(pnLength, cDrawObjects_Mes15_1+' 1', FloatToStr(TElpArc(Figure).alen), dtFloat); ObjProps.AddSimpleProperty(pnWidth, cDrawObjects_Mes15_1+' 2', FloatToStr(TElpArc(Figure).blen), dtFloat); end // Tolik 14/07/2017 -- // ; else if Figure.ClassName = 'TPie' then F_BlockParams.Execute(Figure, false, false, cDrawObjects_Mes16); // if ObjProps = nil then begin if Figure.ClassName = Tline.ClassName then begin //ObjProps := TSCSComponent.Create(F_ProjMan); //ObjProps.AddSimpleProperty(pnLength, cCadClasses_Mes4, , dtFloat); FloatOldVal := GetLineLength(Figure.ap1, Figure.ap2); //EnterStr := FloatToStr(RoundX(MetreToUOM(FloatOldVal / 1000 * PCad.MapScale), 4)); //if InputQuery(cDrawObjects_Mes13_1, cDrawObjects_Mes13_2+ ', '+GetNameUOM(GCurrProjUnitOfMeasure, true), EnterStr) then //begin // FloatNewVal := UOMToMetre(StrToFloat_My(EnterStr))*1000/PCad.MapScale; if F_DimLineDialog.Execute(cDrawObjects_Mes13_1, cDrawObjects_Mes13_2, FloatOldVal / 1000 * PCad.MapScale) then begin FloatNewVal := F_DimLineDialog.ResValM * 1000/PCad.MapScale; p1Idx := 1; p2Idx := 2; // Если вторая точка ближе к началу координат if GetLineLength(Figure.ActualPoints[2], Doublepoint(0,0)) < GetLineLength(Figure.ActualPoints[1], Doublepoint(0,0)) then begin p1Idx := 2; p2Idx := 1; end; Figure.ActualPoints[p2Idx] := MPoint(Figure.ActualPoints[p2Idx], Figure.ActualPoints[p1Idx], -1*(FloatNewVal-FloatOldVal)); Res := true; end; end else if Figure.ClassName = TCircle.ClassName then begin FloatOldVal := TCircle(Figure).Radius; if F_DimLineDialog.Execute(cDrawObjects_Mes1, cDrawObjects_Mes2, FloatOldVal / 1000 * PCad.MapScale) then begin FloatNewVal := F_DimLineDialog.ResValM * 1000/PCad.MapScale; if FloatNewVal < 0 then FloatNewVal := 0; TCircle(Figure).Radius := FloatNewVal; Res := true; end; end else if Figure.ClassName = TArc.ClassName then begin FloatOldVal := TArc(Figure).Radius; if F_DimLineDialog.Execute(cDrawObjects_Mes15_1, cDrawObjects_Mes15_2, FloatOldVal / 1000 * PCad.MapScale) then begin FloatNewVal := F_DimLineDialog.ResValM * 1000/PCad.MapScale; if FloatNewVal < 0 then FloatNewVal := 0; TArc(Figure).Radius := FloatNewVal; Res := true; end; end else Res := Figure.Edit; end else begin ObjOldProps := TSCSComponent.Create(F_ProjMan); ObjOldProps.AssignProperties(ObjProps.Properties); // From Cad To Metr for i := 0 to ObjProps.Properties.Count - 1 do begin PName := PProperty(ObjProps.Properties[i])^.SysName; ObjProps.SetPropertyValueAsFloat(PName, Round3(ObjProps.GetPropertyValueAsFloat(PName) / 1000 * PCad.MapScale)); end; if EditObjectProps(F_ProjMan, ObjProps, false) then begin // From Metr To Cad for i := 0 to ObjProps.Properties.Count - 1 do begin PName := PProperty(ObjProps.Properties[i])^.SysName; ObjProps.SetPropertyValueAsFloat(PName, ObjProps.GetPropertyValueAsFloat(PName) * 1000/PCad.MapScale); end; {if Figure.ClassName = TRectangle.ClassName then begin // размер по длине FloatOldVal := ObjOldProps.GetPropertyValueAsFloat(pnLength); FloatNewVal := ObjProps.GetPropertyValueAsFloat(pnLength); Figure.ActualPoints[2] := MPoint(Figure.ActualPoints[2], Figure.ActualPoints[1], -1*(FloatNewVal-FloatOldVal)); Figure.ActualPoints[3] := MPoint(Figure.ActualPoints[3], Figure.ActualPoints[4], -1*(FloatNewVal-FloatOldVal)); // размер по ширине FloatOldVal := ObjOldProps.GetPropertyValueAsFloat(pnWidth); FloatNewVal := ObjProps.GetPropertyValueAsFloat(pnWidth); Figure.ActualPoints[4] := MPoint(Figure.ActualPoints[4], Figure.ActualPoints[1], -1*(FloatNewVal-FloatOldVal)); Figure.ActualPoints[3] := MPoint(Figure.ActualPoints[3], Figure.ActualPoints[2], -1*(FloatNewVal-FloatOldVal)); end;} if Figure.ClassName = TEllipse.ClassName then begin TEllipse(Figure).alen := ObjProps.GetPropertyValueAsFloat(pnLength); TEllipse(Figure).blen := ObjProps.GetPropertyValueAsFloat(pnWidth); end else if Figure.ClassName = TElpArc.ClassName then begin TElpArc(Figure).alen := ObjProps.GetPropertyValueAsFloat(pnLength); TElpArc(Figure).blen := ObjProps.GetPropertyValueAsFloat(pnWidth); end; end; FreeAndNil(ObjProps); FreeAndNil(ObjOldProps); end; if Res then TPowerCad(Sender).Refresh; finally TPowerCad(Sender).OnFigureEdit := PCadFigureEdit; end; end; procedure TF_CAD.FormCanResize(Sender: TObject; var NewWidth, NewHeight: Integer; var Resize: Boolean); begin // if Self.ClassName = 'TF_CAD' then if (GCadForm = nil) and (self.PCad <> nil) then GCadForm := self; end; (* {$IF Defined(SCS_PE) or Defined(SCS_PANDUIT)} {$I ToolBar.pas} {$IFEND} *) procedure TF_CAD.PopupMenuDisconectedPopup(Sender: TObject); begin // F_ProjMan.Act_ConnectedConCompons.; end; procedure TF_CAD.TimerDblClkTimer(Sender: TObject); begin if not TimerDblClk.Enabled then exit; TimerDblClk.Enabled := False; if PCad.ToolIdx <> toSelect then begin FSCS_Main.tbSelectExpert.Down := True; FSCS_Main.tbSelectNoob.Down := True; FSCS_Main.tbPanExpert.Down := False; FSCS_Main.tbPanNoob.Down := False; FSCS_Main.aToolSelect.Execute; end else begin FSCS_Main.tbSelectExpert.Down := False; FSCS_Main.tbSelectNoob.Down := False; FSCS_Main.tbPanExpert.Down := True; FSCS_Main.tbPanNoob.Down := True; FSCS_Main.aToolPan.Execute; end; end; procedure TF_CAD.PCadSurfaceLeave(Sender: TObject); begin {$IF Defined (FINAL_SCS) or defined(TRIAL_SCS)} FIsDragOver := False; if DragState = dsPan then begin DragState := 0; PCAD.SetCursor(crDefault); Cursor := crDefault; Screen.Cursor := crDefault; end; // if FContinueTrace then begin FContinueTrace := False; // IGOR 2017-04-26 // это делается теперь на PCadToolChanged, но если нужно чтобы при уходе с КАДа вообще не создавадись даже // куски недорисованные - то можно это раскоментить здесь, но тогда нужно проверить чтобы // при след.создании срабатывал нормально анду-реду в части addExceptionToLogEx('TConnectorObject.RaiseProperties', 'ReSETDrawFigure'); { Cursor := crDefault; FCreateObjectOnClick := False; GCurrShadowTraceX := -1; GCurrShadowTraceY := -1; if GSnapFiguresList <> nil then begin GSnapFiguresList.Clear; end; if PCad.TraceFigure <> nil then PCad.KillTraceFig; } // Tolik 10/03/2021 -- выключать режим будем если в нормативке выберем линейный объект //FCreateObjectOnClick := False; // if PCad.ToolInfo = 'TOrthoLine' then begin FSCS_Main.aToolSelectExecute(nil); end; end; //D0000006113 UnSnapFigure; //30.10.2013 самыков {$IFEND} end; //D0000006113 procedure TF_CAD.UnSnapFigure; //Отмена выделениия объекта рамкой,30.10.2013 самыков var i : shortint; obj : pointer; begin for i:=0 to 2 do begin case i of 0 : obj:=GPrevFigureTraceTo; 1 : obj:=GPrevFigureSnap; 2 : obj:=GFigureSnap; end; if obj<>nil then begin if CheckFigureByClassName(obj, cTConnectorObject) then TConnectorObject(obj).isSnap := false else if CheckFigureByClassName(obj, cTOrthoLine) then TOrthoLine(obj).isSnap := false else if CheckFigureByClassName(obj, cTHouse) then begin THouse(obj).isSnap := false; THouse(obj).Draw(PCad.DEngine, false); end; end; end; end; procedure TF_CAD.UpdateCheckedFigures(aCheckUpdateCount: boolean = True); var i: integer; CurFigure: TFigure; LHSCSCommon: integer; LHSCSRoom: integer; begin if PCad <> nil then begin if (PCad.UpdateCount > 0) and aCheckUpdateCount then begin FNeedUpdateCheckedFigures := True; exit; end; FCheckedFigures.Clear; LHSCSCommon := PCad.GetLayerHandle(lnSCSCommon); LHSCSRoom := PCad.GetLayerHandle(lnRoom); for i := 0 to PCad.FigureCount - 1 do begin if i < PCad.FigureCount then begin CurFigure := TFigure(PCad.Figures[i]); if Assigned(CurFigure) then begin if( (CurFigure.LayerHandle = LHSCSCommon) or (CurFigure.LayerHandle = LHSCSRoom) ) and (CurFigure.DrawStyle <> dsTrace) then begin if CheckFigureByClassName(CurFigure, cTConnectorObject) then begin FCheckedFigures.Add(CurFigure); end else if CheckFigureByClassName(CurFigure, cTOrthoLine) then begin FCheckedFigures.Add(CurFigure); end else if CheckFigureByClassName(CurFigure, cTHouse) then begin FCheckedFigures.Add(CurFigure); end else if CheckFigureByClassName(CurFigure, cTCabinet) then begin FCheckedFigures.Add(CurFigure); end else if CheckFigureByClassName(CurFigure, cTCabinetExt) then begin FCheckedFigures.Add(CurFigure); end; end; end; end; end; FNeedUpdateCheckedFigures := False; end; end; procedure TF_CAD.SelectTracesAndRaisers; var i, a: integer; f: TFigure; invis: Boolean; layer: TLayer; LayerNbr: integer; begin LayerNbr := PCad.ActiveLayer; If (LayerNbr < 0) or (LayerNbr > PCad.Layers.Count - 1) then exit; //Tolik -- 14/03/2016 -- ищем только в СКС фигурах - будет быстрее //for a := 0 to PCad.figures.count - 1 do for a := 0 to FSCSFigures.count - 1 do // begin //f := TFigure(PCad.figures[a]); f := TFigure(FSCSFigures[a]); invis := false; if (f.LayerHandle <> 0) then invis := (TLayer(f.LayerHandle).Visible = lost); if (not invis) and (not f.InClip) and ((LayerNbr = 0) or (f.LayerHandle = LongInt(PCad.Layers[LayerNbr]))) then begin if not f.LockSelect then begin if CheckFigureByClassName(f, cTOrthoLine) then begin f.Select; PCad.FAnySelected := true; end; end; end; end; PCad.ReDrawSelection; PCad.SyncEnv; end; procedure TF_CAD.SelectTraces; var i, a: integer; f: TFigure; invis: Boolean; layer: TLayer; LayerNbr: integer; begin LayerNbr := PCad.ActiveLayer; If (LayerNbr < 0) or (LayerNbr > PCad.Layers.Count - 1) then exit; // Tolik -- 14/03/2016 -- // for a := 0 to PCad.figures.count - 1 do for a := 0 to FSCSFigures.count - 1 do begin //f := TFigure(PCad.figures[a]); f := TFigure(FSCSFigures[a]); invis := false; if (f.LayerHandle <> 0) then invis := (TLayer(f.LayerHandle).Visible = lost); if (not invis) and (not f.InClip) and ((LayerNbr = 0) or (f.LayerHandle = LongInt(PCad.Layers[LayerNbr]))) then begin if not f.LockSelect then begin if CheckFigureByClassName(f, cTOrthoLine) then begin if Not TOrthoLine(f).FIsRaiseUpDown then begin f.Select; PCad.FAnySelected := true; end; end; end; end; end; PCad.ReDrawSelection; PCad.SyncEnv; end; procedure TF_CAD.InvertSCSSelection; var i, a: integer; f: TFigure; invis: Boolean; layer: TLayer; LayerNbr: integer; begin LayerNbr := PCad.ActiveLayer; If (LayerNbr < 0) or (LayerNbr > PCad.Layers.Count - 1) then exit; for a := 0 to PCad.figures.count - 1 do begin f := TFigure(PCad.figures[a]); invis := false; if (f.LayerHandle <> 0) then invis := (TLayer(f.LayerHandle).Visible = lost); if (not invis) and (not f.InClip) and ((LayerNbr = 0) or (f.LayerHandle = LongInt(PCad.Layers[LayerNbr]))) then begin if not f.LockSelect then begin if f is Tnet then begin TNet(f).SelType := stStruct; TNet(f).SelIndex := 0; end; if f.Selected then f.Deselect else begin if CheckFigureByClassName(f, cTConnectorObject) then begin if TConnectorObject(f).ConnectorType <> ct_Clear then begin f.Select; PCad.FAnySelected := true; end; end else begin f.Select; PCad.FAnySelected := true; end; end; end; end; end; PCad.ReDrawSelection; PCad.SyncEnv; end; procedure TF_CAD.InvertAllSelection; var i, a: integer; f: TFigure; invis: Boolean; layer: TLayer; LayerNbr: integer; begin LayerNbr := PCad.ActiveLayer; If (LayerNbr < 0) or (LayerNbr > PCad.Layers.Count - 1) then exit; for a := 0 to PCad.figures.count - 1 do begin f := TFigure(PCad.figures[a]); invis := false; if (f.LayerHandle <> 0) then invis := (TLayer(f.LayerHandle).Visible = lost); if (not invis) and (not f.InClip) and ((LayerNbr = 0) or (f.LayerHandle = LongInt(PCad.Layers[LayerNbr]))) then begin if not f.LockSelect then begin if f is Tnet then begin TNet(f).SelType := stStruct; TNet(f).SelIndex := 0; end; if f.Selected then f.Deselect else begin f.Select; PCad.FAnySelected := true; end; end; end; // если на подложке, а фигура на ДХФ слое if (not invis) and (not f.InClip) and ((LayerNbr = 1) and TLayer(f.LayerHandle).IsDxf {CheckFigureInDXFLayer(f)}) then begin if not f.LockSelect then begin if f.Selected then f.Deselect else begin f.Select; PCad.FAnySelected := true; end; end; end; end; PCad.ReDrawSelection; PCad.SyncEnv; end; procedure TF_CAD.WriteOnClickParam(Const Value: Boolean); begin if CreateOnClick = Value then exit; CreateOnClick := Value; if not Value then begin DestroyShadowObject; // Pcad.DestroyCreatedOnDropGuides; //Удаляет временные направляющие end; end; procedure TF_CAD.DrawGuidesOnDrop(X, Y: Double; aFromClick: boolean = false); var Z,hX,hY: Double; GL: TGuideLine; needCr: boolean; begin try hX := X; hY := Y; needCr := True; if not aFromClick then begin if Pcad.CalculateSnapPoint(X,Y) then needCr := false; end; if needCr then if GCadForm.FCreateObjectOnClick then begin if not PCad.SnapToGuides then //Если отключенв привязка begin PCad.SnapToGuides := true; //квлючаем её FSCS_Main.aSnaptoGuides.Checked := true; //делаем Check кнопке end; //if not PCad.GuidesVisible then //Если отключено отображение напрявляющих //begin // PCad.GuidesVisible := true; //включаем их // FSCS_Main.aShowGuideLines.Checked := true; //end; Pcad.ConvertXY(X,Y,Z); //конвертация координат if not Pcad.CheckForExistGuide(hX,hY,gtHorz) then //если нет такой напрявляющей begin DragState := dsHRuler; Pcad.DrawGuideOnSurface(Round(x),round(y),gtHorz, False); //создаем горизонтальную направляющую //Махнуть местами Ифы // if Pcad.CheckAndGetGuideDrop(Round(X),round(Y),GL) then //добавляем их в Guides if Pcad.CheckForGuideDrop(Round(X),round(Y), True) then //добавляем их в Guides begin //Разлочить, если потребуется удаление направляющих // Pcad.GuidesCreatedOnDropCompon.Add(GL); //Запоминаем временные направляющие end; end; if not Pcad.CheckForExistGuide(hX,hY,gtVert) then //Все то же самое с вертикальной begin DragState := dsVRuler; Pcad.DrawGuideOnSurface(Round(x),round(y),gtVert, false); //Махнуть местами Ифы // if Pcad.CheckAndGetGuideDrop(Round(X),round(Y),GL) then if Pcad.CheckForGuideDrop(Round(X),round(Y), True) then begin //Разлочить, если потребуется удаление направляющих // Pcad.GuidesCreatedOnDropCompon.Add(GL); dragState := dsNone; Pcad.Refresh; //рефрешим PCad.repaint; //и перерисовываем на всяк случай :) end; end; end; CanChangeDownCoord := true; except end; end; procedure TF_CAD.ShowHintIFFigInsideCab(X, Y: Double); var DropFigure: TFigure; begin if CheckFigure = nil then begin DropFigure := CheckBySCSObjects(X, Y); if DropFigure <> nil then begin Pcad.CheckFigureInsideCabinet(Pcad.Figures, DropFigure); if DropFigure.InsideCabinet then ShowHintRzR('This is an unroutable area. You cannot place anything here!', 2000); end; end; CanChangeDownCoord := true; end; // IGOR 2017-04-26 procedure TF_CAD.PCadToolChanged(Sender: TObject); begin if Self.ClassName = 'TF_CAD' then begin //Self.FCreateObjectOnClick := False; //if GCadForm <> nil then // GCadForm.FCreateObjectOnClick := False; if FSCS_Main <> nil then begin //FSCS_Main.tbCreateOnClickModeExpert.Down := False; //FSCS_Main.tbCreateOnClickModeNoob.Down := False; //FSCS_Main.tbSelectExpert.Down := True; //FSCS_Main.tbSelectNoob.Down := True; //FSCS_Main.tbPrintRect.Down := False; end; Cursor := crDefault; //FCreateObjectOnClick := False; GCurrShadowTraceX := -1; GCurrShadowTraceY := -1; if GSnapFiguresList <> nil then begin GSnapFiguresList.Clear; end; if PCad.TraceFigure <> nil then // остальные TraceFigure лучше не убивать, а то бывает что попадаем сюда // а трейс-фигура TText еще не успела создаться и потом АВ // здесь NewFigure := FigClass.CreateFromShadow(Self,LongInt(Layers[ActiveLayer]),TraceFigure); if CheckFigureByClassName(PCad.TraceFigure, cTOrthoLine) then PCad.KillTraceFig; GisKeyDown := False; // если отжата не Shift, Alt или Control, то вызываем EventEngine // вдруг было удаление, то он почистит FRemFigures и, при необходимости, // выполнит удаление фигур // PCad.EventEngine(95,1,'',0); // Tolik 27/03/2019 end; end; procedure TF_CAD.tbShowTransparencyClick(Sender: TObject); var CurListParams: TListParams; begin {GCadForm.FListSettings.AllowTransparency := tbShowTransparency.down;} try GCadForm.FListSettings.AllowTransparency := tbShowTransparency.down; CurListParams := GetListParams(GCadForm.FCADListID); CurListParams.Settings.AllowTransparency := GCadForm.FListSettings.AllowTransparency; SaveCADListParams(GCadForm.FCADListID, CurListParams); RefreshCAD(GCadForm.PCad); except on E: Exception do addExceptionToLogEx('TFSCS_Main.a100Execute', E.Message); end; end; function GetVisibleLineCount(Memo: TcxMemo; MemoFont: TFont): Integer; var DC: HDC; SaveFont: HFONT; TextMetric: TTextMetric; EditRect: TRect; begin DC := GetDC(0); SaveFont := SelectObject(DC, MemoFont.Handle); GetTextMetrics(DC, TextMetric); SelectObject(DC, SaveFont); ReleaseDC(0, DC); Memo.Perform(EM_GETRECT, 0, LPARAM(@EditRect)); Result := (EditRect.Bottom - EditRect.Top) div TextMetric.tmHeight; end; procedure TF_CAD.mProtocolPropertiesChange(Sender: TObject); var LineCount, TopLine: Integer; begin // if mProtocol.Lines.Count > 1 then // mProtocol.ScrollContent(dirDown); { if mProtocol.Lines.Count >= 1 then begin LineCount := tcxMemo(mProtocol.Controls[0]).Perform(EM_GETLINECOUNT, 0, 0) - 1; TopLine := tcxMemo(mProtocol.Controls[0]).Perform(EM_GETFIRSTVISIBLELINE, 0, 0); if ( TopLine + GetVisibleLineCount( tcxMemo(mProtocol.Controls[0]), mProtocol.style.Font) ) <= LineCount then SendMessage(tcxMemo(mProtocol.Controls[0]).Handle, EM_LINESCROLL, 0, LineCount); mProtocol.Update; mProtocol.ScrollContent(dirUp); end; } if mProtocol.Lines.Count >= 1 then begin SendMessage(tcxMemo(mProtocol.Controls[0]).Handle, EM_LINESCROLL, 0, mProtocol.Lines.Count); mProtocol.Update; mProtocol.ScrollContent(dirUp); end; end; end.