{$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} //{$J+} unit U_Common; interface uses Windows, Forms, StdCtrls, Classes, ComCtrls, Controls, DrawEngine, PCTypesUtils, SysUtils, Dialogs, Contnrs, DrawObjects, PCDrawBox, PCDrawing, PowerCad, Graphics, {Tolik - 18/12/2015 }FastStrings, FastStringFuncs {}, U_Cad, U_ESCadClasess, U_SCSLists, U_SCSComponent, U_Common_Classes, ActnList, U_SCSEngineTest, U_BaseCommon, U_Progress, U_Splash, Math, U_Navigator, Messages, LibJpeg, ClipBrd, ExtCtrls, U_HouseClasses, IniFiles{Tolik 21/02/2017 -- }, Registry, MiTeC_PsAPI, U_SCSInterfPath, cxClasses, GLObjects, {Tolik}GDIPlus, GDIPAPI, GDIPOBJ, cxImage, RzButton, RzRadChk; const // Polly Line Type pltNone = 0; pltConvex = 1; // Выпуклый pltConcave = 2; // Вогнутый cnstPi180 = pi / 180; type //Tolik --13/09/2016 -- TCableWayCompon = class(TMyObject) Public FirstCompon: TSCSComponent; LastCompon: TSCSComponent; WayList: TList; Npp: Integer; Passed: Boolean; CanSeekSide1: Boolean; CanSeekSide2: Boolean; CableInterfName: String; CableInterface: TSCSInterface; Side1ConnectedInterface: TSCSInterface; Side2ConnectedInterface: TSCSInterface; //GroupedNpp: string; GroupedNpp: TIntList; Side1InterfList: TList; Side2InterfList: TList; Constructor Create; Destructor Destroy; override; end; // TMemoryStatusEx = packed record dwLength, dwMemoryLoad : LongWord; //DWORD ullTotalPhys, ullAvailPhys, ullTotalPageFile, ullAvailPageFile, ullTotalVirtual, ullAvailVirtual, ullAvailExtendedVirtual : Int64; //DWORDLONG end; THashedStringListMy = class(TStringList) private procedure UpdateValueHash; procedure UpdateNameHash; protected procedure Changed; override; public FValueHashValid: Boolean; FNameHashValid: Boolean; FValueHash: TStringHash; FNameHash: TStringHash; destructor Destroy; override; function IndexOf(const S: string): Integer; override; function IndexOfName(const Name: string): Integer; override; end; TListFormatType = record PageLayout: TPageLayout; PageOrient: TPageOrient; PageWidth: Double; PageHeight: Double; StampLang: TStampLang; StampType: TStampType; ShowMainStamp: Boolean; ShowUpperStamp: Boolean; ShowSideStamp: Boolean; ListCountX: Integer; ListCountY: Integer; {CADStampMargins: TDoubleRect; CADStampDeveloper: string[255]; //15.11.2011 - разработал CADStampChecker: string[255]; //15.11.2011 - проверил CADStampMainEngineer: string[255]; //02.10.2012 - Главный инженер проекта CADStampApproved: string[255]; //02.10.2012 - Утвердил CADStampDesignStage: string[255]; //02.10.2012 - Стадия проектир.} StampFields: TListStampFields; end; type // настройки листа, для сравнения с примененными настройками TCADParams = record // Вкладка "Общие" CADHeightRoom: Double; // для потолка CADHeightFalseFloor: Double; // для фальш потолка CADHeightConns: Double; // для коннекторов CADHeightLines: Double; // для трасс CADIndexPointObjects: Integer; // индекс для новых РТ CADIndexConnector: Integer; // индекс для новых коннекторов CADIndexLine: Integer; // индекс для новых трасс // Вкладка "CAD" CADPageSizeIndex: Integer; // индекс размера листа А4 CADPageOrient: TPageOrient; // ориентация листа CADStampType: TStampType; // штамп листа CADStampLang: TStampLang; // язык рамки CADStampMargins: TDoubleRect; // отступы рамки листа //11.11.2011 CADWidth: Double; // ширина КАД CADHeight: Double; // высота КАД CADListCountX: Double; // кол-во листов данного формата по горизонтали CADListCountY: Double; // кол-во листов данного формата по вертикали CADFontName: string[255]; // шрифт КАДа CADGridStep: Double; // шаг сетки CADMapScale: Double; // настройка линейки CADTraceColor: TColor; // цвет трассы CADTraceStyle: TPenStyle; // стиль трассы CADTraceWidth: Integer; // ширина трассы CADBlockStep: Double; // шаг блока CADObjectCaptions: TShowType; // вид подписи к объектам CADLinesCaptions: TShowKind; // вид подписей к линиям CADObjectNotes: TShowType; // вид выносок к объектам CADLinesNotes: TShowKind; // вид выносок к линиям CADNotePrefix: string[1]; // префикс отображения CADShowLineObjectCaption: Boolean; // Отображать подписи к линейным объектам CADShowLineObjectLength: Boolean; // Отображать длину линейных объектов CADShowLineObjectNote: Boolean; // Отображать выноски к линейным объектам CADShowConnObjectCaption: Boolean; // Отображать подписи к точечным объектам CADShowConnObjectNote: Boolean; // Отображать выноски к точечным объектам CADShowRaise: Boolean; // отображать символы с-п CADPutCableInTrace: Boolean; // Ложить кабель на трассу CADLinesCaptionsColor: Integer; // цвет подписей трасс CADConnectorsCaptionsColor: Integer; // цвет подписей коннекторов CADLinesNotesColor: Integer; // цвет выносок трасс CADConnectorsNotesColor: Integer; // цвет выносок коннекторов CADLinesCaptionsFontSize: Integer; // размер шрифта подписей трасс CADConnectorsCaptionsFontSize: Integer; // размер шрифта подписей коннекторов CADLinesNotesFontSize: Integer; // размер шрифта выносок трасс CADConnectorsNotesFontSize: Integer; // размер шрифта выносок коннекторов CADLinesCaptionsFontBold: Boolean; // жирный шрифт подписей трасс CADCrossATSFontSize: Integer; // размер шрифта для Кросс АТС CADDistribCabFontSize: Integer; // размер шрифта для РШ CADCrossATSFontBold: Boolean; // жирный шрифт для Кросс АТС CADDistribCabFontBold: Boolean; // жирный шрифт для РШ CADPrintType: TPrintType; // тип печати SCSType: TSCSType; // тип листа СКС CADTraceStepRotate: Integer; // шаг угла поворота трассы AutoCadMouse: Boolean; // мышь Автокад ScaleByCursor: Boolean; // масштабировать по положению курсора AutoPosTraceBetweenRM: Boolean; // трассу между двумя РМ размещать на высоте этих РМ... CADShowMainStamp: Boolean; // показывать основной штамп на рамке листа CADShowUpperStamp: Boolean; // показывать верхний штамп на рамке листа CADShowSideStamp: Boolean; // показывать боковой штамп на рамке листа CADSaveUndoCount: Integer; // кол-во действий после которого следует делать слепок CADAllowSupplieskind: Boolean; // учитывать вид поставки при прокладки КК CADNewTraceLengthType: Byte; CADShowRaiseDrawFigure: Boolean; // Tolik -- CADShowRaiseHeights: Boolean; end; PCADParams = ^TCADParams; // Для схемы проекта // Здание - проект TPlanProject = record FSizeX: Double; FSizeY: Double; FBounds: TDoubleRect; FFloors: TList; end; PPlanProject = ^TPlanProject; // Этаж в здании TPlanFloor = record FSizeX: Double; FSizeY: Double; FBounds: TDoubleRect; FCabinets: TList; end; PPlanFloor = ^TPlanFloor; // Кабинет в этаже TPlanCabinet = record FSizeX: Double; FSizeY: Double; FBounds: TDoubleRect; FObjects: TList; end; PPlanCabinet = ^TPlanCabinet; TNormColumn = record IDNormStruct: Integer; FCableName: string[255]; FColumns: TStringList; end; PNormColumn = ^TNormColumn; TNormStruct = record ID: Integer; FNumber: string[10]; FName: string[255]; FIzm: string[20]; FCount: string[50]; FNormColumns: TList; end; PNormStruct = ^TNormStruct; // тип объекта для отображения групповых свойств TObjectsTypeProp = (otp_Single, otp_ConnObjects, otp_ConnConnectors, otp_ConnRaises, otp_LineTraces, otp_LineRaises); TAngleType = (at_Horizontal, at_Vertical); //Tolik -- 13/09/2016 -- function CheckRaiseIsNotBetweenFloorOrMagistral(aRaise: TOrthoLine; var aMess: String): Boolean; // 11/05/2018 -- function GetCableWayTraceList(aCablecompon: TSCSComponent) : TIntList; // -- вернет путь кабеля (айдишники трасс) с учетом транзитных подключений Function GetUserObjectsQuota: Integer; // Tolik 21/02/2017 -- функция получения квоты на количество объектов USER из реестра пользователя function CheckUserObjQuotaReached(ObjCount: Integer): Integer; // проверка на достижение квоты USERObjects в Windows function GetQuotaMessage(Mess_Kind: Integer; Add_Mess: string): string; function CheckCanCopyComponsFromListToList: Boolean; procedure SelectFigureInTree(aFigure: TFigure; aShiftState: TShiftState; var aFirstNode: Boolean; ClearSelection: Boolean = False); procedure Select_Figures_In_Tree(aSelList: TList; aShiftState: TShiftState); // // получить лист по его ID function GetListByID(AID_List: Integer): TF_CAD; // **** привязки объектов **** // коннектор к трассе Function GetCoordZ(ASnapFigure: TFigure; CoordX, CoordY: Double): Double; // Tolik 27/02/2018 procedure SnapConnectorToOrtholine(AConnector: TConnectorObject; ASnapLine: TOrtholine); // объект к трассе procedure SnapPointObjectToOrthoLine(APointObject: TConnectorObject; ASnapLine: TOrthoLine); // коннектор к коннектору // Tolik -- 22/11/2016 -- // procedure SnapConnectorToConnector(AConnector, ASnapConnector: TConnectorObject; AOnRaise: Boolean = false); Function SnapConnectorToConnector(AConnector, ASnapConnector: TConnectorObject; AOnRaise: Boolean = false): TConnectorObject; // // коннектор к объекту procedure SnapConnectorToPointObject(AConnector, APointObject: TConnectorObject; AOnRaise: Boolean = false; ASnapObjectToLine: Boolean = false); // объект к коннектору Procedure SortConnLineListWithRaise(AConnector: TConnectorObject); // Tolik 10/04/2018 -- // Tolik 13/04/2018 -- //procedure SnapPointObjectToConnector(APointObject, AConnector: TConnectorObject; AOnRaise: Boolean = false); procedure SnapPointObjectToConnector(APointObject, AConnector: TConnectorObject; AConnToPoint: Boolean = false); // // коннектор к Дому procedure SnapConnectorToHouse(aConnector: TConnectorObject; aSnapHouse: THouse); // коннектор к вертикальной трассе //procedure SnapConnectorToVertical(AConnector: TConnectorObject; ASnapLine: TOrtholine); // procedure SnapConnectorToVertical(AConnector: TConnectorObject; ASnapLine: TOrtholine; aOnObjectHeight: Boolean = False); procedure SnapConnectorToVertical(AConnector: TConnectorObject; ASnapLine: TOrtholine; aOnObjectHeight: Boolean = False; CanSaveConnections: Boolean = True); // объект к вертикальной трассе procedure SnapPointObjectToVertical(APointObject: TConnectorObject; ASnapLine: TOrthoLine); // Tolik -- 25/04/2016 -- // преобразовать С/П в вертикаль Procedure ConvertRaiseToVertical(var aRise: TOrthoLine); // 15/03/2017 -- function GetMemInUsePercentage: Integer; function GetMemStatusFull: String; function GetAppMemStatus: String; //Импорт функции GlobalMemoryStatusEx(). function GlobalMemoryStatusEx(var lpBuffer : TMemoryStatusEx) : Bool; stdcall; external 'Kernel32.dll' name 'GlobalMemoryStatusEx'; // // **** выполнить привязку по определенному закону **** // коннектор к трассе procedure CheckingSnapConnectorToOrtholine(AConnector: TConnectorObject; ASnapLine: TOrtholine); // объект к трассе procedure CheckingSnapPointObjectToOrthoLine(APointObject: TConnectorObject; ASnapLine: TOrthoLine); // коннектор к коннектору //Tolik 10/04/2018 -- //procedure CheckingSnapConnectorToConnector(AConnector, ASnapConnector: TConnectorObject); //function CheckingSnapConnectorToConnector(AConnector, ASnapConnector: TConnectorObject): TConnectorObject; // function CheckingSnapConnectorToConnector(AConnector, ASnapConnector: TConnectorObject; aManual: Boolean = False): TConnectorObject; // // коннектор к объекту procedure CheckingSnapConnectorToPointObject(AConnector, APointObject: TConnectorObject; aUseBaseConnector: Boolean); // объект к коннектору //Tolik 23/03/2018 -- //procedure CheckingSnapPointObjectToConnector(APointObject, AConnector: TConnectorObject); Procedure GetConnectedOrthoLinesListOnConn(aConn: TConnectorObject; var aLineList: TList); // procedure CheckingSnapPointObjectToConnector(APointObject, AConnector: TConnectorObject; APointObjectDroppedFromNB: Boolean = False; aConnToPoint: Boolean = False); procedure CheckingSnapPointObjectToConnector(APointObject, AConnector: TConnectorObject; APointObjectDroppedFromNB: Boolean = False; aConnToPoint: Boolean = False; aManual: Boolean = False); //Tolik 03/08/2021 -- //Procedure MoveConnToConn(aConn1, aConn2: TConnectorObject); Procedure MoveConnToConn(aConn1, aConn2: TConnectorObject; AlignConn: Boolean = true); // function CheckAllowTracesBetweenRM(AConn: TConnectorObject): Boolean; // размещать трассы на высоте РМ (из настроек када) // // Tolik 13/09/2017 -- //сбросить пересечения трасс на листе Procedure ClearOrthoLinesCrossInfo(aCad: TF_CAD); // показать пересечения трасс на листе/проекте Procedure ShowTracesIntersections(aCrossType: Integer; aCrossSett: Byte); Procedure DropCalcCrosses(aCheckLine: TOrthoLine; aCheckOtherLines: Boolean); // // c-п // создать ... // на объекте // Tolik -- 17/03/2017 -- старая написана чарез жопу... поубивал бы... Procedure CreateRaiseOnPointObjectNew(APointObject: TConnectorObject; AHeight: Double); // Procedure CreateRaiseOnPointObject(APointObject: TConnectorObject; AHeight: Double; aBaseConnector: TConnectorObject = nil); // на коннекторе Procedure CreateRaiseOnConnector(AConnector: TConnectorObject; AHeight: Double); // на связующем коннекторе/объекте от трассы // Tolik -- 26/04/2016 -- // Procedure CreateRaiseOnNextObject(AConnector: TConnectorObject; AJoinedLine: TOrthoLine; AHeight: Double); // добавить трейслист в параметры для спуска/подъема коннектора по вертикали Procedure CreateRaiseOnNextObject(AConnector: TConnectorObject; AJoinedLine: TOrthoLine; AHeight: Double; ATraceList: TList); // // пересоединение компонент через с-п Procedure AutoConnectOverRaiseInCAD(AObjFromRaise, ARaiseObj: TConnectorObject); // изменить положение ... // на объекте Procedure ChangeRaiseOnPointObject(APointObject: TConnectorObject; AHeight: Double); // на коннекторе Procedure ChangeRaiseOnConnector(AConnector: TConnectorObject; AHeight: Double); // на связующем коннекторе/объекте от трассы // Tolik -- 20/04/2016 -- // Procedure ChangeRaiseOnNextObject(AConnector: TConnectorObject; AJoinedLine: TOrthoLine; AHeight: Double); Procedure ChangeRaiseOnNextObject(AConnector: TConnectorObject; AJoinedLine: TOrthoLine; AHeight: Double; ATracesList: TList); // // удалить ... // с объекта Procedure DestroyRaiseOnPointObject(APointObject: TConnectorObject); // с коннектора Procedure DestroyRaiseOnConnector(AConnector: TConnectorObject); // поднять линию на высоту Procedure RaiseLineOnHeight(ALine: TOrthoLine; AHeight: Double; ATracesList: TList); // нужно ли создавать с-п при подъеме трассы Function CheckNeedCreateRaiseOnRaiseTrace(ALine: TOrthoLine; AJoinedConn: TConnectorObject; ATracesList: TList): Boolean; // c-п межэтажные ... // создать м-э с-п на объекте Function CreateBetweenFloorRaiseOnPointObject(APointObject: TConnectorObject; ARaiseType: TLineRaiseType): TConnectorObject; // создать м-э с-п на коннекторе Function CreateBetweenFloorRaiseOnConnector(AConnector: TConnectorObject; ARaiseType: TLineRaiseType): TConnectorObject; // c-п магистральные ... // создать магистральный с-п на объекте Function CreateTrunkRaiseOnPointObject(APointObject: TConnectorObject; ARaiseType: TLineRaiseType; aTrunkLength: Double): TConnectorObject; // создать магистральный с-п на коннекторе Function CreateTrunkRaiseOnConnector(AConnector: TConnectorObject; ARaiseType: TLineRaiseType; aTrunkLength: Double): TConnectorObject; // отвязать коннектор от объекта procedure UnsnapConnectorFromPointObject(AConnector, APointObject: TConnectorObject; AOnRaise: Boolean = false); // определеть точку привязки коннектора к объекту при одинаковой высоте (красная точка) function GetCrossPoint(X1_Line, Y1_Line, X2_Line, Y2_Line, X1_Object, Y1_Object, X2_Object, Y2_Object: Double): TDoublePoint; // получить УГО с НБ для объекта function GetConnectorImg(aOT: TConnectorType): TFigureGrpMod; // получить УГО с НБ для трассы function GetOrthoLineImg(aOT: TOrthoLineType): TFigureGrpMod; // параметры по дефолту для листа КАДа (только КАДовские настройки) Procedure SetDefaultPageParams; // вернуть параметры для листа КАДа (только КАДовские настройки) после переаквтивации окон КАДа Procedure ReturnListParams; // Принятие компонента из нормативной базы Function GetComponentFromNormBase(X, Y: Double; NB_Component: TSCSComponent; ASnapFigure: TFigure; CompStateType: TCompStateType): TFigure; // автопоиск объекта при DragOver Function FindAutoSnapObject(X, Y: Double; NB_Component: TSCSComponent): TFigure; // Взаимодействие Менеджера проектов и CAD`а ... // Новое имя для объекта Procedure SetNewObjectNameInCad(AID_List, AID_Figure: Integer; AOldObjName, ANewObjName: String); // удалить объект с КАДа Procedure DeleteObjectFromCad(AID_List, AID_Figure: Integer; AObjName: String); // удалить объект с SCSFigureGrp Procedure DeleteObjectFromSCSFigureGrp(ASCSFigureGrp: TSCSFigureGrp; AObjects: TFigure); // выделить объект на КАДе Procedure SelectObjectInCAD(AID_List, AID_Figure: Integer; AObjName: String); // Перемещает объек в конец списка - нужно чтобы он имел высший приоритет для выделения procedure FigureBringToFront(AFigure: TFigure); //29.09.2010 //#From Oleg# procedure FigureSendToBack(AFigure: TFigure); //19.08.2011 //#From Oleg# // Перемещает коннектор без УГО в конец списка - нужно чтобы он имел высший приоритет для выделения procedure SetConnObjectSelectHightPriority(AFigure: TConnectorObject); //29.09.2010 //#From Oleg# // Взаимодействие Листов в МП и на CAD-е ... // переключить лист Procedure SwitchListInCAD(AID_List: Integer; const ListName: String); // переименовать лист Procedure RenameListInCAD(AID_List: Integer; const OldListName, NewListName: String; AOldListParams: PListParams; ARenameOnFrame: Boolean=true); // удалить лист Procedure DeleteListInCAD(AID_List: Integer; ListName: String); // получить листы интерфейсов Procedure FindConnectionsInterfaces(AConnector1, AConnector2: TConnectorObject); // автосоединение по интерфейсам при добавлении кабеля на трассу // Tolik 15/03/2018 -- //Procedure AutoConnectOnAppendCable(AID_List, AID_Line: Integer); Procedure AutoConnectOnAppendCable(AID_List, AID_Line: Integer; aLineList: TList = nil); // // автосоединение по интерфейсам при добавлении объекта на трассу Procedure AutoConnectObjectInTrace(APointObject: TConnectorObject; ATrace1, ATrace2: TOrthoLine); // автосоединение по интерфейсам при соединении коннектора/объекта к коннектору с трассами procedure AutoConnectObjectToConnectors(APointObject, AConnectedConn: TConnectorObject; AConnectorsList: TList); // добавление/удалении комплектующих в объекты ... // добавление в трассу Procedure AppendLineInterfacesToCAD(AID_List, AID_Figure: Integer; AObjName: string; aDivValue: Double); // удаление из трассы Procedure RemoveLineInterfacesFromCAD(AID_List, AID_Figure: Integer; AObjName: string); // добавление в объект Procedure AppendNoLineInterfacesToCAD(AID_List, AID_Figure: Integer; AObjName: string); // удаление из объекта Procedure RemoveNoLineInterfacesFromCAD(AID_List, AID_Figure: Integer; AObjName: string); // выделить всю трассу от точки до точки function SelectTraceInCAD(LinesList: TList): Double; // убрать выделение этой трассы от точки до точки function DeselectTraceInCAD: Boolean; // угол линии function GetLineAngle(AP1, AP2: TDoublePoint): Double; // выровнять линию по сетке Procedure ReAlignLine(aAlignedLine: TOrthoLine); // выровнять точ. объект по сетке Procedure ReAlignObject(aAlignedObject: TConnectorObject); // процедура нахождения трассы на CAD-е function GetAllTraceInCAD(AFigureServer, AFigureWS: TFigure): TList; // процедура нахождения группы путей по отмеченным трассам function GetAllTraceInCADByMarked(aAFigureServer, aAFigureWS: TFigure; SotrListByMarked: Boolean = True): TList; //Tolik function GetAllTraceInCADByMarked_New1(aAFigureServer, aAFigureWS: TFigure): TList; // function CheckConnJoinBetwFloor(aConn: TConnectorObject; CheckRaiseUpDown: boolean = False): Boolean; function CheckOtherTraceBetwFloor(Trace: TOrthoLine; CheckRaiseUpDown: boolean = False; CheckMore: boolean = false): Boolean; function GetAllNoConnectedTraces(aCAD: TF_CAD): TList; // проверка на наличие объекта в текущем листе function CheckNoFigureInList(ACheckFigure: TFigure; AList: TList): Boolean; // проверка на наличие КАД листа в текущем листе function CheckNoCadInList(ACheckCad: TF_CAD; AList: TList): Boolean; // проверка на наличие листа в листе function CheckNoListInList(AInList, AList: TList): Boolean; // выделить подсоединенные коннекторы Procedure SelectConnectedConnector(AID_List, AID_Figure: Integer); // выделить подсоединенные кабели Procedure SelectConnectedCables(AID_List: Integer; ALinesList: TIntList); // Подъемы ... function GetBasisPointByObjFromRaise(aObj: TConnectorObject): TDoublePoint; // получить подъем на объекте function GetRaiseConn(APointObject: TConnectorObject): TConnectorObject; // получить линию типа с-п на объекте function GetRaiseLine(ARaiseConn: TConnectorObject): TOrthoLine; // проверить есть ли подъем на объекте function CheckRaise(APointObject: TConnectorObject): Boolean; // получить вершину межэтажного от трассы function GetRaiseByRaiseLine(aRaiseLine: TOrthoLine): TConnectorObject; // проверить существует ли лист Function CheckListExist(AListID: integer): Boolean; // Установить новый тип заполненности интейфейсов для ... // точ. объектов Procedure SetFullnessTypeForConnector(AID_List, AID_Figure: Integer; AFullnessType: TComponInterfacesFullness); // кабелей Procedure SetFullnessTypeForCable(AID_List, AID_Figure: Integer; ASide: Integer; AFullnessType: TComponInterfacesFullness); // кабельных каналов Procedure SetFullnessTypeForCableChannel(AID_List, AID_Figure: Integer; AFullnessType: TComponInterfacesFullness); // закрытость/открытость каб.каналов Procedure SetClosedTypeForCableChannel(AID_List, AID_Figure: Integer; ASide: Integer; AClosedType: TComponInterfacesFullness); // установить стиль трассы Procedure SetTraceStyle(AID_List, AID_Figure: Integer; ATraceStyle: TTraceStyle); // сравнение двух чисел типа Double function DoubleCMP(Double1, Double2: Double): Boolean; // переместить объект на передний план procedure SetConnBringToFront(AConnector: TConnectorObject); // получить указатель на лист где мэ переход Function GetListOfPassage(AListID: Integer): TF_CAD; function GetAllFiguresByClass(ACADForm: TF_CAD; aClass: TClass): TList; function GetAllFiguresByClassFromProj(aClass: TClass): TList; // получить объект по листу и ID объекта function GetFigureByID(ACADForm: TF_CAD; AID_Figure: Integer): TFigure; //2012-04-18 получить объект который ближе к началу координат function GetFigureByOrign(aFigureList: TList): TFigure; function GetFigureByIDProj(AID_Figure: Integer): TFigure; // получить объект по листу и ID объекта внутри SCSFigureGroups function GetFigureByIDInSCSFigureGroups(ACADForm: TF_CAD; AID_Figure: Integer): TFigure; // получить объект по ID объекта внутри SCSFigureGroup function GetFigureByIDInSCSFigureGrp(ASCSFigureGrp: TSCSFigureGrp; AID_Figure: Integer): TFigure; // получить SCSFigureGroup обьект в котором объект function GetSCSFigureGrp(ACADForm: TF_CAD; AID_Figure: Integer): TSCSFigureGrp; function AutoDivideLine(ALine: TOrthoLine): TConnectorObject; // разделить трассу, на выходе коннектор, котoрый разделил эту трассу function DivideLine(ALine: TOrthoLine): TConnectorObject; function DivideLineSimple(ALine: TOrthoLine; ADivPt: PDoublePoint=nil): TConnectorObject; // соединить трассы связующие с коннектором procedure DisconnectConn(AConn: TConnectorObject); // пересчет Z координат привязанных линий procedure ReCalcZCoordSnapObjects(AConnector: TConnectorObject); // Проверка на класс СКС ... // ортолиния Function OrthoLineDetect(AOrthoLine: TFigure): Boolean; // коннектор Function ConnectorDetect(AConnector: TFigure): Boolean; // общая проверка на один из классов СКС Function SCSClassDetect(ASCSObject: TFigure): Boolean; // создавать объекты в режиме клика на КАД-е procedure CreateOnClickMode(ASnapFigure: TFigure; ALastSCSCompon: TSCSComponent; X, Y: Double); procedure AskMarkInCreateObjectOnClick(aCAD: TF_CAD; aComponID: Integer); // установить индекс объекта procedure SetIndexToFigure(AID_List, AID_Figure: Integer; AIndex: Integer); // установить формат изображения типа краткий/полный на КАД-е procedure SetShowNameTypeInCAD(AShowType: TShowType); overload; // Tolik -- 28/06/2016 -- procedure SetShowNameTypeInCAD; overLoad; // // проложить короб по выделенным участкам // Tolik --15/03/2018 -- procedure TraceCableChannelBySelectedLines(CableChannelID: Integer; aIsCable: Boolean = False); // // проверить есть ли хоть одна выделенная линия function IsSelectedLinesExist: Boolean; function IsSelectedFigure(aListID, aFigureID: Integer): Boolean; // выдать координаты дропа объекта с учетом привязки к сетки // по оси X function GetCoordXWithSnapToGrid(X: Double): Double; // по оси Y function GetCoordYWithSnapToGrid(Y: Double): Double; // по обоим осям function GetCoordsWithSnapToGrid(X, Y: Double): TDoublePoint; // был ли клик на объекте function IsClickOnFigure: Boolean; // автотрассировать кабелем из НБ Procedure AutoTraceCableFromNB(AID_Cable: Integer; ACable: TSCSComponent; aFromDropConnObj: Boolean=false; aShowFirstMsg: Boolean=true; aSaveForUndo: Boolean=true; aNeedShowAutoTraceType: boolean = True; aFromDrop: boolean = False); // трассировать до конечной точки Function TracingToEndPoint(ACurrentWS, AEndPoint: TConnectorObject; AID_Cable: Integer; aConsiderBoxAndRack: Boolean=false): Boolean; // главный цикл автотрассировки procedure DoAutoTraceCycle(AFiguresList: TList; AID_Cable: Integer; aConsiderBoxAndRack: Boolean=false; aSaveForUndo: Boolean=true); // автосоединить с-п на межэтажных переходах Procedure AutoConnectBetweenFloorPassage(ACable: TOrthoLine; ASide: Integer; ARaise: TConnectorObject); // проверить являеться ли трасса межэтажным с-п Function GetBetweenFloorRaiseLine(ALine: TOrthoLine): TOrthoLine; // применение настроек параметров листа для всех объектов Procedure ApplyParamsForAllSCSObject(AConnHeight, ALineHeight: Double; AConnCaptionsShowType, AConnNotesShowType: TShowType; ALineCaptionsShowType, ALineNotesShowType: TShowKind; aCADParams: TCADParams); // для точечных объектов Procedure ApplyParamsForObjects(AObject: TConnectorObject; AHeight: Double); // для линейных объектов Procedure ApplyParamsForTraces(ATrace: TOrthoLine; AHeight: Double; ATracesList: TList); // применение типа уголков для всех коннекторов Procedure ApplyCornerTypeForConnectors(aCornerType: TCornerType); // проверка можно ли сменить тип уголка для объекта Function CheckCornertypeMaybeChanged(aConnector: TConnectorObject; aCornerType: TCornerType): Boolean; // получить угол между двумя трассами function GetAngleBetweenLines(AListID, AIDLine1, AIDLine2, AIDConnector: Integer; aAngleType: TAngleType): Double; Function CalcAngleBetweenLines(aLine1, aLine2: TOrthoLine; aConnector: TConnectorObject): Double; // установить тип уголка Function GetCornerTypeByConnectorID(AID_List, AID_Object: Integer): TCornerType; // получить тип уголка Procedure SetCornerTypeByConnectorID(AID_List, AID_Object: Integer; ACornerType: TCornerType); // получить тип уголка по определенным законам Function GetCheckedCornerType(aConnector: TConnectorObject): TCornerType; // получить стороны присоединенных объектов (0 - если коннектор, 1-2 - стороны трассы) Procedure GetSidesByConnectedFigures(AID_List1, AID_List2, AID_Figure1, AID_Figure2: Integer; var Side1: Integer; var Side2: Integer); // получить высоты трассы Procedure GetLineFigureHeghts(AID_List, AID_Line: Integer; var AHeight1: Double; var AHeight2: Double); // обновить слои после изменения настроек procedure UpdateForLayers; // обновить все КАДы Procedure RefreshAllLists; // передать в объект типы сетей которые в нем присутствуют Procedure SetNetworkTypesForObject(AID_List, AID_Object: Integer; ANetworkTypes: TObjectNetworkTypes); // проверить есть ли совпадения с сетями Function IsViewObjectInCurrentNetwork(AObject: TFigure): Boolean; // установить данные усл.обозначения для объекта Procedure SetBlockParamsForObject(AID_List, AID_Object: Integer; ABlockGUID: string; AObjectType: Integer; ABlockStreams, ABlockStreamsOtherType: TObjectList; aSysName: string = ''); // установить новое УГО для коннектора Procedure SetBlockForConnObject(AConnector: TConnectorObject; ABlockStreams: TObjectList; aSysName: string = ''); procedure SetLayerHandleForFigureGrp(BlockFig: TFigureGrp; LayHandle: integer); // установить новое УГО для линии Procedure SetBlockForLineObject(ALine: TOrthoLine; ABlockStreams, ABlockStreamsOtherType: TObjectList); // возможность соединения на КАДе, могу ли эти объекты соединиться на КАДе Function CheckCanConnectInCAD(AID_List1, AID_List2, AID_Object1, AID_Object2: Integer): Boolean; // Выводить имя объекта на КАД в подписи procedure SetConnNameInCaptionOnCAD(AConnector: TConnectorObject); // установить подпись к точечному обьекту procedure SetConnCaptionsInCAD(AID_List, AConnID: Integer; ACaption: TStringList); // установить выноску на точечном объекте procedure SetConnNotesInCAD(AID_List, AConnID: Integer; ANote: TStringList); // установить выноску на линейном объекте procedure SetLineNotesInCAD(AID_List, ALineID: Integer; ANote: TStringList); // установить подпись на линейном объекте procedure SetLineCaptionsInCAD(AID_List, ALineID: Integer); // краткий формат Double Function BriefFormat(ADbl: Double): Double; // проверка изменять ли поля объектов ... function CheckIsNameChanged(AID_List, AID_Figure: Integer): Boolean; // имя function CheckIsCaptionsChanged(AID_List, AID_Figure: Integer): Boolean; // подпись function CheckIsNotesChanged(AID_List, AID_Figure: Integer): Boolean; // выноска function CheckIsBlockChanged(AID_List, AID_Figure: Integer): Boolean; // изображение // получить список всех присоединенных трасс к объекту, их ID Function GetAllConnectedTracesID(AID_List, AID_Object: Integer): TIntList; // получить список всех присоединенных трасс к объекту, сами объекты Function GetAllConnectedTraces(AObject: TConnectorObject): TList; // поиск объектов (аналог CheckByPoint) Function CheckBySCSObjects(X, Y: Double; TracedFigure: TFigure = nil): TFigure; procedure CheckBySCSObjectsNear(X, Y: Double; var ResFindedFigures: TList; TracedFigure: TFigure = nil); // поиск списка объектов (аналог CheckByPoint) Function CheckBySCSObjectsList(X, Y: Double): TList; // автосдвиг точ. объекта Procedure AutoShiftObject(AObject: TConnectorObject); // получить присоединенные трассы для установки заглушек Function GetObjectsListForCork(AListID, AID_LineFigure, ALineSide: Integer; var AID_Connector: Integer): TIntList; // блокировка всех действий пока идет оброботка ... //Tolik //Procedure BeginProgress(ACaption: String = ''; AMaxPos: Integer = -1); // начало Procedure BeginProgress(ACaption: String = ''; AMaxPos: Integer = -1; MustShowProgress: Boolean=False); // Procedure EndProgress; // окончание procedure SetCADsProgressMode(AIsProgress: Boolean); procedure CADBeginUpdate(aCAD: TObject); //07.11.2011 procedure CADEndUpdate(aCAD: TObject); //07.11.2011 procedure StepProgress; // шаг // Tolik --28/10/2016-- если был нахальный вызов формы прогресса вопреки всем прогрессам, то нужен и нахальный шаг ... procedure StepProgressRE; // шаг -- типа внаглую прогрессбар увеличить без проверок // ProgressBar при загрузке приложения procedure StartUpProgress; // переименовка проекта - переименовать поле FCADProjectList у листов Procedure SetListsNamesInProject(AProjectName: string); // добавлять и удалять shadow объекты при DragOver c НБ procedure CreateShadowObject; procedure DestroyShadowObject; // вернуть Stream с КАДом по ИД листу function GetCADStreamByIDList(AID_List: Integer; aFileName: string = ''): TMemoryStream; // можно ли двигать DrawFigure function IfDrawFigureMoveCan(AObject: TConnectorObject; ADeltaX, ADeltaY: Double): Boolean; // переприсвоить параметры листа Навигатору procedure ReAssignNavigatorParams; {****************************************************************************} // загрузка настроек для листа Procedure LoadSettingsForList(AListID: Integer; aApplyListFormat: Boolean); // загрузка настроек для листа по параметрам procedure LoadSettingsForListByParams(AListParams: TListParams; aApplyListFormat: Boolean); // Устанавливает параметры в рамку листа procedure SetCADFrameParams(ACadForm: TF_CAD); // переоткрывать закрытый лист на CAD Procedure ReOpenListInCAD(AListID: Integer; const AListName: string); // переоткрывать закрытый лист на CAD, с проверкой Procedure ReOpenListInCADIfClosed(AListID: Integer; const AListName: string); //17.08.2012 // открыть листы в проекте procedure OpenListsInProject(AListID: Integer; AListName: string); // сделать дубликат для листа function CreateListDuplicate(AListParams: TListParams; AListStream: TMemoryStream; AFileName: string = ''; aCopySCSFigures: Boolean=true): TF_CAD; // выгрузка старого проекта Procedure UnloadCurrentProject; // загрузка нового проекта Procedure LoadNewProject(AListsID: TList; ACurrentListID: Integer); // создание/редактирование листа function MakeEditList(AMakeEdit: TMakeEdit; var AListParams: TListParams; AShowForm: Boolean; ASpravochnikKind: TViewKind = vkNone; AGUIDToLocate: String = ''): Boolean; // утсановить новые параметры для листа //Tolik 31/05/2021 -- //procedure SetNewListParams(aCADParams: TCADParams); procedure SetNewListParams(aCADParams: TCADParams; AMakeEdit: TMakeEdit = meEdit); // procedure SetNewListParamsForMaster(aCADParams: TCADParams); // применить настройки к подписям и выноскам procedure ApplyCaptionNotesParams(aCADParams: TCADParams); // установить статус лимитности procedure SetTraceLimitStatus(AID_List, AID_Object: Integer; AStatus: Boolean); // STAMP // загрузить рамку листа procedure LoadFrameToList(aCad: TF_CAD; aMainStampName, aSideStampName: string; aListFormat: TListFormatType); // удалить рамку листа procedure RemoveFrameFromList(aCad: TF_CAD); // загрузить подписи на рамку листа // ACreateForLack - Создавать подпись, если отсутствует procedure LoadCaptionsOnFrame(ACAD: TF_CAD; AStampType: TStampType; ACreateForLack: Boolean=true; AEnabledCaptions: TintList=nil); // вписать подписи к рамке листа в поля function CreateStampCaptionToField(ACAD: TF_CAD; aFieldBnd: TDoubleRect; const aText: String; ATextHorzCenter: Boolean=true; ATextSize: Integer=14): TRichText; // Пересоздает подпись к рамке листа function ReCreateStampCaptionToField(ACAD: TF_CAD; ACurrStampField: TRichText; ADataID: Integer; aFieldBnd: TDoubleRect; const aText: String; ACreateForLack: Boolean=true; AEnabledCaptions: TintList=nil; ATextHorzCenter: Boolean=true; ATextSize: Integer=14): TRichText; // получить имя файла из полного пути function GetFileNameFromFullPath(aFullPath: string): string; // получить номер слоя из его Handle function GLN(aLHandle: LongInt): integer; // загрузить рамку на макет procedure LoadFrameOnMaket(aPCad: TPowerCad); // для листа Дизайна Шкафа ... // создать лист Дизайна шкафа procedure CreateDesignList(ABox: TConnectorObject); // открыть дизайнерский лист procedure OpenDesignList(ABox: TConnectorObject; AList: TF_CAD); // создать/открыть дизайн-лист из менеджера проектов procedure CreateOpenDesignListFromPM(AID_List, AID_Box: Integer); // обновить дизайнерский лист procedure UpdateDesignList(AList: TF_CAD; ABox: TConnectorObject); // обновить дизайнерский лист после изменения в объекте Шкаф procedure UpdateDesignListOnBoxChange(AListID: Integer; ABoxID: Integer); // перемасштабировать УГО procedure ReScaleImage(aBlock: TBlock; aCurrX, aCurrY, aTotalX, aTotalY: Double); // высчитать коэф. с учетом перемасшабирования по листу function CalcListFormatKoef(aBoxWidth, aBoxHeight: Double; AList: TF_CAD): Double; // нарисовать линейку к дизайну шкафа ... // в иетрах procedure DrawDesignRulerInMetres(aList: TF_CAD; aRulerHeight, aCadRulerWidth, aCadRulerHeight: Double; aBeginDrawPoint: TDoublePoint); // в юнитах procedure DrawDesignRulerInUnits(aList: TF_CAD; aRulerHeight, aCadRulerWidth, aCadRulerHeight: Double; aBeginDrawPoint: TDoublePoint); // опции для типов листов (запрет/разрешение пунктов меню)... // для обычного листа procedure EnableOptionsForNormalList; procedure DisableActForReadOnlyMode; // для Дизайна шкафа procedure DisableOptionsForDesignList; // для Схемы проекта procedure DisableOptionsForProjectPlan; // Tolik 10/02/2021 -- // для однолинейной электрической схемы Procedure DisableOptionsForEl_Scheme; // // выдать присоединенные Обьекты к трассе procedure GetConnObjectsByLine(AIDList, AIDLine: Integer; var AConnAtSide1: Integer; var AConnAtSide2: Integer); // переименовать названия проекта в рамке листа procedure RenameProjectOnFrame(AOldProjParams: TProjectParams); // переименовать названия листа в рамке листа procedure RenameListOnFrame(ACadForm: TF_CAD; AOldProjParams: TProjectParams; AOldListParams: TListParams); // проверка на отсоединение коннектора от объекта function CheckByBreakConnector(aClearConn, aPointObject: TConnectorObject): Boolean; // проверка на отсоединение коннектора от объекта по координатам коннектора function CheckByBreakConnectorByCoords(aConnPoints: TDoublePoint; aPointObject: TConnectorObject): Boolean; // Обновление КАДа (REFRESH) procedure RefreshCAD(aPCAD: TPowerCad); // обычный procedure RefreshCAD_T(aPCAD: TPowerCad; AExecPrev: Boolean=false); // по таймеру procedure RefreshCADs(aCADs: TList); //17.01.2011 Обновить список листов // усовершенствованный ProcessMessages procedure ProcessMessagesEx; // удаление внутри объектов FigureGrp (для корректрой очисти объектов данного класса) procedure RemoveInFigureGrp(aFigureGrp: TFigureGrp); // перерисовать тек. Шадоу текущего листа procedure ReDrawCurrShadowOnCAD; // Unselect объектов на SelectionChange (убирается селект с с-п и вершин с-п) procedure UnSelectFiguresOnSelectedChange(aSelectedList: TList); // пересчитать длинны линий на изменении Mapscale procedure ReCalcAllLinesLength; // поднять ActiveNet после поднятия листа procedure RaiseActiveNet(aCad: TF_CAD); // Устанавливает параметры с КАДа на объект procedure SetCADParamsToNet(aCad: TF_CAD; ANetObj: TObject); procedure SetMapScaleToNets(aCad: TF_CAD); // получить все внутренние фигуры с Stamp ... // установить видимость для внутренних штампов procedure SetAllInFiguresVisible(AGroup: TFigureGrp; AVisible: Boolean); // установить все внутр. объектам слой самого объекта procedure SetAllStampFiguresLayer(AGroup: TFigureGrp; ALHandle: Integer); // установить всем внутр. текстам текущий шрифт procedure SetAllStampTextsFont(AGroup: TFigureGrp; aFontName: string); // установить всем текстовым объектам на КАде текущий шрифт procedure UpdateForTexts(aFontName: string); // Смена ID листа procedure ChangeObjectID(aListID, aOldID, aNewID: Integer); // Смена ID кабинета procedure ChangeCabinetID(aListID, aOldID, aNewID: Integer); // вернуть ID межэтажных переходов с листа (линии) function GetBetweenFloorObjectsID(AID_List: Integer; aClearJoins: Boolean = False): TIntList; // удалять фигуры с листа перед удалением листа procedure ClearFiguresonListDelete(aCAD: TF_CAD); procedure ClearFiguresOnListUndoRedo; // Tolik 19/09/2022 -- // запрос на перемещение листов в менеджере проектов function CanListsInterchange(AIDMoveList, AID_List2: Integer; aMessRes: PInteger=nil; aMsg: Boolean=true): Boolean; // Есть ли на листе м.э переходы function CheckListWithFloorRaise(aListID: Integer): Boolean; // выдать лист со всеми типами трасс function GetTraceInfo(AID_List: Integer): TList; // Сравнить TStringList и TStrings Function IsStringListsDifferent(aStringList: TStringList; aStrings: TStrings): Boolean; // Конвертация TFigureGrpNotMod в TRichTextMod ... // поиск объектов для конвертации procedure FindObjectsForConvertClasses; // конвертировать подписи Function ConvertCaptionsGroupToRichText(aCaptionsGroup: TFigureGrpNotMod; aIsLine: Boolean): TRichTextMod; // конвертировать выноски Function ConvertNotesGroupToRichText(aNotesGroup: TFigureGrpNotMod; aIsLine: Boolean): TFigureGrpNotMod; // получить лист объектов одного уровня Function GetFiguresByLevel(aFigure: TFigure; X, Y: Double; aSameType: Boolean; ASort: Boolean=false): TList; // получить лист объектов на одной вертикале //Tolik 11/04/2018 -- Function GetVLinesOnConnector(AConnector: TConnectorObject): TList; // Function GetObjectsByVertical(aSelf, aSnapConnector: TConnectorObject): TList; Function GetLinesByVertical(aSelf: TConnectorObject; aSnapLine: TOrthoLine): TList; Function CheckVerticalInInterval(aVertical: TOrthoLine; aZ: Double): Boolean; // удалить м-э с другого этажа Procedure DeleteRaiseOtherFloor(aItRaise: TConnectorObject); // доложить кабели к противоположной трассе Function MirrorCables(aClearConn: TConnectorObject; aNearTracedLine: TOrthoLine): Integer; // получить лист м-э с-п для трассировки через несколько этажей ... // проверить можно ли трассировать между этажами Function CheckCanTracingBetweenFloor(aLists: TIntList; aRaises: TList): Boolean; // получить список этажей для трассировки между ними Function GetSortedListOfRaises(var aLists: TIntList; aRaiseType: TConnRaiseType; aEndPoint, aBeginPoint: TConnectorObject): TList; // получить список этажей для трассировки между ними начиная от текущего Function GetSortedListOfRaisesFromCurr(var aLists: TIntList; aRaiseType: TConnRaiseType; aBeginPoint, aEndPoint: TConnectorObject): TList; // получить трассу от м-э на другом этаже Function IsBetweenFloorObject(AListID, AIDFigure: Integer; var AIDOtherFloorFigure: Integer): Boolean; // установить структуру КАД параметров Function SetCADParamsStruct(aListParams: TListParams): TCADParams; // функции для свойств подписей и выносок ... // проверить клик в области подписи/выноски Procedure CheckByCaptionsNotes(X, Y: Double); // открыть подпись от данного объекта в свойствах СКС объекта Procedure OpenCaptionAtPos(aObject: TFigure; aCaption: TRichTextMod; X, Y: Double); // открыть выноску от данного объекта в свойствах СКС объекта Procedure OpenNoteAtPos(aObject: TFigure; aNote: TRichTextMod; X, Y: Double); // модификация выносок после перемещения ... // для коннекторов procedure ModifyConnNoteAfterMove(aConn: TConnectorObject; aDeltaX, aDeltaY: Double); // для трасс procedure ModifyLineNoteAfterMove(aLine: TOrthoLine; aDeltaX, aDeltaY: Double); // установить высоту размещения объекта procedure SetFigureCoordZ(AIDList, AIDFigure: Integer; ACoordZ: Double); // получить тип спуска-подъема (подъем или спуск) Function GetRaiseType(aObjFromRaise, aRaise: TConnectorObject): TLineRaiseType; // получить формат подписи к линии function GetLineCaptionFormat(aLine: TOrthoLine; aShowKind: TShowKind): string; // получить полное имя объекта Function GetFullFigureName(aFigure: TFigure; x: Double=-1; y: Double=-1): string; function GetFullFigureLenName(aFigure: TFigure; x: Double=-1; y: Double=-1): string; // авто разрыв соединения соеднинения через с-п после удаления с-п Procedure AutoDisconnectOverRaiseInCAD(AConnector, ARaiseConnector: TConnectorObject; ARaiseLine: TOrthoLine); // редактирование условного обозначения Procedure EditBlockOnCAD(aActiveBlockStream, aProjectBlockStream: TMemoryStream); // функции переноса объекта на высоту основания/вершины // смена высот между РМ и РМ procedure RemoveRMWithRM(aRM1, aRM2: TConnectorObject); // смена высот между РМ и пустым соединителем procedure RemoveRMWithClear(aRM, aClear: TConnectorObject); // реверсировать вершину с-п (ТО) с основанием (пустой) procedure ReverseRaise(aPointObject: TConnectorObject); // проверить, что лист обычного типа function CheckListNormalType(aListID: Integer): Boolean; // вызвать схему проекта из НБ procedure CallProjectPlanFromNB; // Кабинеты ... // создать кабинет на КАДе procedure CreateCabinetOnCAD(aSCSID, aIndex: Integer); // удалить кабинет на КАДе procedure DeleteCabinetOnCAD(AID_List, aSCSID: Integer); // выделить кабинет на КАДе procedure ActivateCabinetOnCAD(AID_List, aSCSID: Integer); // убрать выделение с кабинета на КАДе procedure DeactivateCabinetOnCAD(AID_List, aSCSID: Integer); // найти кабинет по его ID function FindCabinetBySCSID(aList: TF_CAD; aSCSID: Integer): TFigure; // создать объект номер кабинета для кабинета на КАДе function CreateNumberObjectOnCAD(aCabinet: TFigure; aVisible: Boolean): TCabinetNumber; // изменить параметры кабинета procedure ChangeCabinetParams(AID_List: Integer; AObjectParams: TObjectParams); // установка видимости/невидимости номеров кабинетов procedure SetVisibleCabinetsNumbers(aVisible: Boolean); // установка видимости/невидимости границ кабинетов procedure SetVisibleCabinetsBounds(aVisible: Boolean); // получить кабинет в котором находится указанный объект function GetCabinetWhereObject(aObject: TFigure): TFigure; // получить кабинет в данной точке КАДа function GetCabinetAtPos(aX, aY: double; aCheckAllFigInside: boolean = True; aMovedFigure: TFigure = nil): TFigure; // переместить объекты на КАДе в кабинет при создании procedure MoveObjectsToCabinetOnCreate(aCabinet: TFigure); // переместить объекты на КАДе в кабинет при перемещении procedure MoveObjectsToCabinetOnMove(aCabinet: TFigure); // найти виртуальный кабинет function GetVirtualCabinet: TFigure; // показывать ли выноску (если она пустая то она не отображается) function IsNoteExist(aNoteObject: TFigureGrpNotMod): Boolean; // утилиты для удаления с-п после некоторых изменений в случаях когда они пустые и не присоединенные ... // проверить все с-п на КАДе procedure CheckDeleteAllRaises(aPCad: TPowerCad); // удалить данный с-п если это следует делать procedure CheckDeleteRaise(aRaiseLine: TOrthoLine); // проверка можно пустой и не нужный ли С/П function isRaiseEmptyAndNotNeed(aRaiseLine: TOrthoLine): boolean; // выделен ли объкт на КАДе function CheckCADObjectSelect(AID_List, AID_Object: Integer): Boolean; // выдать список всех путей от всех РМ на листе (для конфигуратора) function GetPointObjectsRelations(AID_List: Integer): TObjectList; // после изменения Mapscale на КАДе изененить данные всех измерительных линий Procedure ReScaleAllDimLines; // проверка, удален ли объект Function CheckObjectDeleted(AID_List, AID_Object: Integer): Boolean; // модификация подписи после смены типа подписи procedure ReverseCaptionAfterTypeChange(aLine: TOrthoLine; aOldType, aNewType: TShowKind); // установка типа размерных линий procedure SetDimLinesType(aType: TDimLinesType); // проверка на тип объекта Кросс АТС или РШ function CheckTrunkObject(aObject: TConnectorObject): Boolean; // создание дубликатов из цепи выделенных СКС объектов function CreateSCSObjectDuplicates(ACad: TF_CAD; aObjects: TList): TList; // получить привязанный коннектор для восстановления привязки после дублирования цепи function GetJoinedConnForDuplicate(aClearConns: TList; aParentDupID: Integer): TConnectorObject; // Tolik 26/09/2018 -- // авто соединение интерфейсов после разделения трассы //Procedure AutoConnectOverDivideLine(AConnDivider, AConnOther: TConnectorObject; ADividedLine, ANewLine: TOrthoLine); Procedure AutoConnectOverDivideLine(AConnDivider, AConnOther: TConnectorObject; ADividedLine, ANewLine: TOrthoLine; aNoCopyList: TList = nil); // // авто рассоединение интерфейсов после слияния трассы Procedure AutoDisconnectOverDivideLine(AConn1, AConn2: TConnectorObject; ALine: TOrthoLine); // получить объекта на КАДе по ID в виде TObject function GetFigureObjectByID(aListID, aObjectID: Integer): TFigure; // установить новые ID для объектов procedure SetNewObjectsIDs(aObjects: TObjectList; aIDs: TIntList); // можно ли удалять объект с МП function CanDeleteObjectFromPM(aListID, aObjectID: Integer): Boolean; // установить все трассы в нужный режим отображения длины ... // установить всем трассам авто длинну procedure SetAllTracesAutoLength; // установить всем трассам пользовательскую длинну procedure SetAllTracesUserLength; // проверка объекта на имя класса function CheckFigureByClassName(aFigure: TFigure; const aClassName: string): Boolean; function CheckFigureByClassIdx(aFigure: TFigure; const aClassIdx: Integer): Boolean; // установка объекту присутствует или нет другой тип комплектующей procedure SetExistOtherObjectType(aListID, aObjectID: Integer; aExist: Boolean); // получение номера магистрали на кросс АТС для трассы (внешние СКС) function GetTrunkNumber(aLine: TOrthoLine): string; // Группировка выделенных СКС объектов function SCSGroupSelection: TSCSFigureGrp; // Группировка заданных СКС объектов function SCSGroupObjects(aObjects: TList): TSCSFigureGrp; // Разгруппировка СКС объектов Procedure SCSUngroupSelection; // залочен ли объект function IsLockedObject(aListID, aObjectID: Integer): Boolean; // рассоединение трасс procedure DisconnectTraces(aConn: TConnectorObject); // отсоединение ТО procedure DisconnectPointObject(aObject: TConnectorObject); // удаление всех трасс на листе procedure DeleteAllTraces; // удаление SCSFigureGrp procedure DeleteSCSFigureGrps(aListID: Integer); // проверить есть ли что то кроме группировки function CheckAnyButFigureGrp(aFiguresList: TList): Boolean; // применить процент размера УГО для объекта procedure ChangeDrawFigurePercentForObject(aObject: TConnectorObject; aPercent: Double); // применить процент размера УГО для трассы procedure ChangeDrawFigurePercentForLine(aLine: TOrthoLine; aPercent: Double); // отдать длинну трассы function GetTraceLength(aListID, aTraceID: Integer): Double; // закрыть форму КАДа procedure CloseCad(aListID: Integer); // установка режима наличия изменений в проекте procedure SetProjectChanged(aChanged: Boolean); // получить структуру параметров УГО объекта function GetFigureIconParams(aListID, aObjectID: Integer): TFigureIconParams; // утилита сортировки РМ для автотрассировки function GetSortedListForAutoTrace(aFiguresList: TList): TList; // получение УГО объекта по ID function GetObjectBlockbyID(aListID, aObjectID: Integer; aCanLoadIcons: Boolean): TObjectIconParams; // получение Stream УГО от обьекта function GetObjectBlockStream(aListID, aObjectID: Integer): TMemoryStream; // Установит УГО объекта в подложку function GetObjectBlockToSubstrateLayer(aListID, aObjectID: Integer): Boolean; // при автотрассировке окно порядка выбора подключений к панелям function ChoiceAutoTraceConnectOrder(AProjectSetting: PProjectSettingRecord = nil; AIsTracing: Boolean = true; ATraceCompon: TSCSComponent=nil; aFromDropConnObj: Boolean=false; aTracingFigInfo: Pointer=nil): Boolean; // убрать Шадоу со всем трасс procedure SkipAllLinesShadows(aForm: TF_CAD); // печать нескольких листов procedure PrintCADLists(aAllLists, aCheckedLists: TIntList); // авторазмещение трасс на высоту РМ мжду ними procedure AutoPosTracesBetweenRM(aConns, aTraces, aSnaps: TList); // авторазмещение трасс на высоту РМ мжду ними после всех привязок procedure AutoPosTracesBetweenRMAfterSnap(aTraces: TList); // установить высоту фальш-потолка для кабинета procedure SetCabinetFalseFloor(aCabinet: TFigure); // проверить все высоты кабинетов на предмет превышения высоты фальш потолка относительно высота этажа procedure CheckAllCabinetsFalseFloorHeights; // установить формат КАД листа procedure SetCadListFormat(aListFormat: TListFormatType); // установить высоту фальш-потолка для кабинета из МП procedure SetCabinetFalseFloorHeightFromPM(aListID, aCabinetID: Integer; aSettings: TRoomSettingRecord); // проверить изменялись ли какие то параметры листа function CheckListFormatChanged(aCad: TF_CAD; aListFormat: TListFormatType): Boolean; // восстоновление визибл/инвизибл для штампов и надписей рамки листа после загрузки procedure CorrectStampView; // если трасса горизонтальная function IfTraceHorizontal(aTrace: TOrthoLine): Boolean; // если трасса вертикальная function IfTraceVertical(aTrace: TOrthoLine): Boolean; // получение кол-ва м-э вершин у присоединенной к заданной трассе // Tolik 13/03/2018 -- немножко поправлено, так как при расчете длины кабеля не следует учитывать // длину(высоту) м-э перехода для магистралей //function GetRaiseCountConnectedToFigure(AIDList, AIDFigure: Integer): Integer; function GetRaiseCountConnectedToFigure(AIDList, AIDFigure: Integer; aWithTrunk: Boolean = False): Integer; // // переставить все высоты межэтажных подъемов после изменения высота этажа procedure SetAllBetweenFloorRaises; // сейчас идет создание трассы function IsNowTracingByUser: Boolean; // сейчас на КАДе нажата левая кнопка мыши //function IsMousedPressed: Boolean; // процедуры для сдвига УГО для обьектов и трасс // УГО объекта вверх procedure ObjectsShiftUp(aObjList: TList); // УГО объекта вниз procedure ObjectsShiftDown(aObjList: TList); // УГО объекта влево procedure ObjectsShiftLeft(aObjList: TList); // УГО объекта вправо procedure ObjectsShiftRight(aObjList: TList); // УГО трассы вверх procedure LinesShiftUp(aLinesList: TList); // УГО трассы вниз procedure LinesShiftDown(aLinesList: TList); // УГО трассы влево procedure LinesShiftLeft(aLinesList: TList); // УГО трассы вправо procedure LinesShiftRight(aLinesList: TList); // установка значения "Есть кабельный канал" procedure SetIsCableChannel(aListID, aLineID: Integer; aFlag: Boolean); // UNDO для проекта ... //Tolik 17/07/2025 - //procedure SaveForProjectUndo(aLists: TList; aSavePM: Boolean; aIsProject: Boolean); procedure SaveForProjectUndo(aLists: TList; aSavePM: Boolean; aIsProject: Boolean; a3d: boolean = false); // // удалить всю цепочку Undo в связке с другими этажами procedure DeleteProjectUndoActions(aCad: TF_CAD; aListUndoAction: TListUndoAction); // поднять всю цепочку UNdo в связке с другими этажами procedure LoadProjectUndoActions(aCad: TF_CAD; aListUndoAction: TListUndoAction); // вызов сохранения листа или нескольких листов для Undo из Менеджера проектов procedure SaveForUndoFromPM(aListsIDs: TIntList; aIsProject: Boolean = False); // REDO для проекта ... procedure SaveForProjectRedo(aLists: TList; aSavePM: Boolean; aIsProject: Boolean); // удалить всю цепочку Undo в связке с другими этажами procedure DeleteProjectRedoActions(aCad: TF_CAD; aListUndoAction: TListUndoAction); // поднять всю цепочку UNdo в связке с другими этажами procedure LoadProjectRedoActions(aCad: TF_CAD; aListUndoAction: TListUndoAction); // вызов сохранения листа или нескольких листов для Undo из Менеджера проектов procedure SaveForRedoFromPM(aListsIDs: TIntList; aIsProject: Boolean = False); // получить ИД другого листа на котором связь с межэтажным function GetOtherListRelatedToFigure(AListID, AFigureID: Integer): Integer; // при перемещении и удалении проверить задействованы ли другие листы, выдать список листов function GetRelatedListsBySelected(aObjects: TList; aCheckBySelectedType: TCheckBySelectedType): TList; // проверить что это один из СКС слоев (2, 3, 4, 5, 6, 8, 9) function CheckOneOfSCSlayers(aLNbr: Integer): Boolean; // убрать выделение со всех СКС объектов на указанном листа procedure DeselectAllSCSObjectsInCAD(AListID: Integer); // убрать выделение со всех СКС объектов на всех листах procedure DeselectAllSCSObjectsInProject; // убрать выделение с неотрисованых объектов procedure DeselectNoDrawed(aPCAD: TPowerCad); // выделить группу объектов procedure SelectObjectsInCADByIDs(aListID: Integer; aObjectsID: TIntList); // получить интлист с выделенными объектами на КАДе function GetObjectsListWithSelectedInCAD(aListID: Integer): TIntList; // получение новостей function Get_News(ParentWin : THandle; gpid, gURL_p, gURL_a, gfil : string; func : byte; var timr :word): byte; // автоподгонка изображения под формат листа procedure ReScaleDrawingToListFormat(aOldListW, aOldListH: double); // создание виртуального кабинета на КАДе procedure CreateVirtualCabinetInCAD(vList: TF_CAD); // удаление дхф слоев procedure DeleteDxfLayers(aPCad: TPowerCad); // проверить что обьект находится на одном из ДХФ слоев function CheckFigureInDXFLayer(aFigure: TFigure): Boolean; // применить систему измерений procedure ApplyUOMForProject(aOldUOM, aNewUOM: Integer); // получить обозначение стригновое системы измерений function GetUOMString(aUOM: Integer): string; // перевести метры в текущую систему измерений function MetreToUOM(aValue: Double): Double; // перевести текущую систему измерений в метры function UOMToMetre(aValue: Double): Double; // обновить все длины трасс на всех листах после смены СИ procedure UpdateAllTracesLengthOnAllLists; // получить площать и объем кабинета в метрах function GetRoomSquare(AListID, ARoomID: Integer; RecalcSquare: Boolean = False): Double; //Tolik //function GetRoomVolume(AListID, ARoomID: Integer ): Double; function GetRoomVolume(AListID, ARoomID: Integer; ARoomSquare: Double): Double; Function GetDoorHeightfor3DModel: Double; Function GetWndHeightFor3DModel: Double; function Get3DWallHeight: Double; // // преобразование TList в TIntList и наоборот для списка листов КАДа function CadsToIntCads(aList: TList): TIntList; function IntCadsToCads(aIntList: TIntList): TList; function FiguresToIntFigures(aList: TList): TIntList; function IntFiguresToFigures(aIntList: TIntList): TList; // проверить есть ли м-э с-п на листе function CheckExistBetweenFloorOnList(aCad: TF_CAD): Boolean; // временная функция для ДХФ (есть ли TTEXT в блоке) function CheckTTextExistForDXF(aBlock: TBlock): Boolean; // ПОЛУЧИТЬ БМП с подложкой и арх. планом procedure SaveSubstrateArchPlan(aFileName: string); procedure ConvertBMPToJpeg(aBmp: TBitmap; aFileName: string); // Для Дома Procedure SelectHouseInCAD(AID_List, AID_Figure: Integer); Procedure SelectApproachInCAD(aListID, aHouseID, AComponID: Integer); procedure DeleteHouseOnCAD(aListID, AObjectID: Integer); procedure DeleteApproachOnCAD(aListID, aHouseID, AComponID: Integer); function GetIDElementFromComplexObjByTrace(AID_List, AIDComplexFigure, AIDTrace: Integer): Integer; function GetHouseByID(ACADForm: TF_CAD; AID_Figure: Integer): THouse; function GetApproachByComponID(ACADForm: TF_CAD; AID_Compon: Integer): TConnectorObject; function GetEndPointByHouse(aHouse: THouse; aCurrentWA: TConnectorObject): TConnectorObject; // From BaseCommon function GetConnectedTracesToConnetorByID(AIDList, AIDConnectorFigure: Integer): TIntList; // Получить список подсоединенных объетов // (AClearConnToRes = true) ? В результат попадут соединители трассы : подключенные трассы function GetConnectedFigures(AFigure: TFigure; AClearConnToRes: Boolean=false; ASkipList: TList=nil): TList; //#From Oleg# //15.09.2010 //24.07.2013 Вернет соединители с других сторон соединенніх страсс от соединителя function GetConnectorsOtherSides(aConnector: TConnectorObject): TList; procedure SetLineStatusInfo(aLineParams: PLineFigureParams); procedure SetConnStatusInfo(aConnParams: PConnFigureParams); procedure SetLiteStatus(aStatus: Boolean); procedure LoadSubWithMaster(aFName: string); // Tolik 27/03/2018 - - //procedure CreateVerticalOnConnector(aConnector: TConnectorObject; aHeight: Double); //procedure CreateVerticalOnPointObject(aPointObject: TConnectorObject; aHeight: Double); Function CreateVerticalOnConnector(aConnector: TConnectorObject; aHeight: Double): TOrthoLine; Function CreateVerticalOnPointObject(aPointObject: TConnectorObject; aHeight: Double): TOrthoLine; // Tolik // два ТОЧЕЧНЫХ объекта в одной точке function CheckTheSamePoint(Figure1, Figure2: TFigure): Boolean; //полусить присоединенный к коннектору райз function RaiseFromConnector(aConn: TConnectorObject): TOrthoLine; // вертикальная линия по двум точкам procedure CreateVerticalOnTwoPointObjects(aPointObject1, APointObject2: TConnectorObject; aHeight: Double); // function CheckOtherConnectorsOnLevel(aSelf: TConnectorObject; X, Y: Double): TList; function CheckJoinVertical(aObject: TConnectorObject; aHeight: Double = -1): Boolean; // Tolik // procedure PutObjectOnHeight(aObject: TConnectorObject; aHeight: Double); procedure PutObjectOnHeight(aObject: TConnectorObject; aHeight: Double; ATraceList: TList = nil); // Ищет список объектов по вертикали, подключенные через AObject function GetJoinedVerticalObjects(AObject: TFigure; AOnlyConnectorCoordZ: PDouble=nil): TList; //#From Oleg# //15.09.2010 function GetJoinedVerticalConnectorByCoordZ(AStartConnector: TConnectorObject; ACoordZ: Double): TConnectorObject; // Вернет номер слоя для компонента function GetCADLayerNumByComponIsLine(AIsLine: Integer): Integer; procedure DefineCurrLayerByCompon; procedure DropCreateObjectOnClickMode; // Для блоков procedure BlockToNormalSize(ABlock: TBlock; AMaxSideSize: Integer); procedure Remove3DModelStream; // Создает трассу с соединителями // Tolik 06/11/2019 -- //function CreateTraceByPoints(APCAD: TPowerCad; AP1, AP2: TDoublePoint; aPosTraceBetweenPM: boolean = false; aH1: double = 0; aH2: double = 0): TOrtholine; function CreateTraceByPoints(APCAD: TPowerCad; AP1, AP2: TDoublePoint; aPosTraceBetweenPM: boolean = false; aH1: double = 0; aH2: double = 0; aTraceHeight: double = -1): TOrtholine; //function CreateTraceByConnectors(aCAD: TF_CAD; aConn1, aConn2: TConnectorObject; aOrthogonally: Boolean=false; aTraceBetweenPM: Boolean = False): TOrtholine; function CreateTraceByConnectors(aCAD: TF_CAD; aConn1, aConn2: TConnectorObject; aOrthogonally: Boolean=false; aTraceBetweenPM: Boolean = False; aOnCadTraceHeight: Boolean = True): TOrtholine; // // Разделить трассу в точке function DivTraceOnPt(ATrace: TOrtholine; APt: TDoublePoint; ATraceList: TList): TConnectorObject; // Вернет соединитель который ближе к началу координат function GetMinConnector(AConn1, AConn2: TConnectorObject): TConnectorObject; procedure ChangeObjZ(aObject: TConnectorObject; aZ: Double); // Создает трассы между точ.объектами function AutoCreateTraces(aSimulate: Boolean=false; aSimulateForAllObj:Boolean=false; aSimulateForAnyTrace: Boolean=false): Integer; function AutoCreateTracesParallel(aSrcFigure: TFigure; aSimulate: Boolean=false; aSimulateForAllObj:Boolean=false; aSimulateForAnyTrace: Boolean=false): Integer; function AutoCreateTracesToTraceList(aTraces: TList; aSimulate: Boolean=false; aSimulateForAllObj:Boolean=false; aSimulateForAnyTrace: Boolean=false): Integer; //Tolik 19/08/2021 -- //function AutoCreateTracesMaster(aSrcFigure: TFigure): Boolean; //function AutoCreateTracesMaster(aSrcFigure: TFigure): Boolean; //Tolik 26/01/2022 //function AutoCreateTracesMaster(aSrcFigure: TFigure; FoCable: Boolean = False): Boolean; function AutoCreateTracesMaster(aSrcFigure: TFigure; aFromNB: Boolean = false; FoCable: Boolean = False): Boolean; // function GetConnFiguresForAutoCreateTraces(aCad: TF_CAD; aSimulate: Boolean=false; aSimulateForAllObj:Boolean=false; aSimulateForAnyTrace: Boolean=false): TList; // Tolik 08/11/2019 -- Function CheckCanDrawOneTrace(aConn: TConnectorObject): Boolean; // // Разделяет трассы на стенах кабинетах procedure DivideTracesOnRoowWalls(aCad: TF_CAD); //15.03.2014 - Применить свойство "размер отрезка" procedure ApplySectionSideForTraces(aCad: TF_CAD); // Устанавливает точ.компоненты на трассы с шагом procedure SetConnComponToTraces(aCad: TF_CAD; ACompon: TSCSComponent; AStep: Double; ASetToConnectors: Boolean); procedure MirrorFigure(AFigure: TFigure); // Сдвигает объекты из списка procedure MoveFigures(AFigures: TList; x, y: Double); procedure RotateFigure(AFigure: TFigure; Angle: Double); procedure RotateBitmap(Bitmap: TBitmap; aAngle: Double; BackColor: TColor); // Длина дуги function GetArcLen(Radius, RadAngle: Double): Double; overload; function GetArcLen(CenterPoint, LinePoint: TDoublePoint; RadAngle: Double): Double; overload; function GetArcLenByPoints(p1, p2, ArcCenter: TDoublePoint; AInverted: Boolean): Double; function GetPolylineFromArc(ACornerCount: Integer; cp:TdoublePoint; radius, ArcAng: Double; p1, p2: PDoublePoint): TDoublePointArr; // Угол между линиями function GetLinesAngle(AP1, AP2, AP3, AP4: TDoublePoint): Double; function GetAreaFromPolygon3D(APoints: PDoublePointArr): Double; function GetPerimetrFromPolygon(APoints: PDoublePointArr): Double; procedure GetLinesNearPoints(ap1, ap2, bp1, bp2: PDoublePoint; var ap, bp: TDoublePoint); function IsConvexPolygon(APoints: PDoublePointArr; ALastPtInFirst: Boolean): Integer; function OverlapDoubleRects(const R1, R2: TDoubleRect): Boolean; function CorrectAngle(aAngle: Double; AStep: Integer=360): Double; function GetTextHeight(FontHandle: HWND; AFont: TFont): Double; procedure GetTextSize(AFontSize: Integer; AStyles: TFontStyles; const AFontName, AText: String; AStrings: TStrings; var h, w: Double; AStrH: Pointer=nil); //Tolik -- 25/11/2015 Procedure GetTextSizeCapt(AFontSize: Integer; AStyles: TFontStyles; const AFontName, AText: String; AStrings: TStrings; var h, w: Double; AStrH: Pointer=nil; CenterPoint: Boolean = False); //Tolik -- 23/12/2015 function GetOneStringSize(AFontSize: Integer; AStyles: TFontStyles; const AFontName: String; MayZero: boolean): Double; function GetEmptyLinesCount(aLine: TOrthoLine): Integer; // function DefineFrameByPrinter(aRect: TDoubleRect): TDoubleRect; function RoundN(Num: Extended; Dig: integer): Extended;//Extended; //Tolik 12/01/2017 -- function GetGdiMess(amess: string): string; Function ListNotUnderFloor(aCad: TF_Cad): Boolean; // 02/05/2018 -- определить находится ли этаж ниже нулевого уровня (под землей) function Get3DFloorHeight(aCad: TF_CAD): Double; //27/04/2018 -- определить высоту этажа function GetTrunkZ(aConn: TConnectorObject; aZ: Double): Double; // 27/04/2018 -- определить длину (высоту для дорисовки) магистрали для 3Д модели // Function CheckAssignedPCAD(aPcad: TPCDrawing): Boolean; // From Dimon ;) //Отсоединяем нужные нам соединения... Procedure ClearLineInterfaces(APointObject, AConnector: TConnectorObject; var CurrLine: TOrtholine; FindFreeInterfac: Boolean); //Проверяем, чтоб параметри былы одинаковыми Function CheckInterfacesSideSection(APointObject, AConnector: TConnectorObject; CurrLine: TOrtholine): Boolean; //Проверяем текущую Ортолинию на наличие свободных интерфейсов Function CheckCurrLine(CurrLineInterf: TSCSInterfaces; APointObject: TConnectorObject):Boolean; //Функция сравнивает параметры выбранного компонента из дерева с тем, что уже имеется на каде Function CheckComponentsForSideSection(CurrCompon: TSCSComponent):Boolean; //From Dimon ;) function GetMultipleFromNB:Boolean; //From Dimon ;) function GetFigureParams(AIDFigure: Integer; AObjectCatalog: TSCSCatalog = nil): TObjectParams; // Tolik 07/11/2018 -- // Tolik 08/08/2019 -- //Procedure DrawGdiImage(agdigraphics: TGPGraphics; aGpImage: TGPImage; x, y, aWidth, aHeight : Integer); // // Tolik 30/08/2019 -- процедура проверки, есть ли фигуры на определенном слое, принадлежащие групповым фигурам других слоев // нужна для выполнения перед удалением конкретного слоя с КАда // если такие фигуры есть -- нех такой слой вручную удалять, дабы... function CheckCanDelLayer(aLayer: TLayer): Boolean; // function CheckProjForOptimizedRasterImageLoad: Boolean;// Tolik 31/01/2020 // Procedure BuildElectricianChemeList(aAVR_Compon: TSCSComponent; aBoxList: TSCSComponents; aSwitchList, aConnectedList: TList; aCableList: TSCSComponents);//26/01/2020 -- Tolik ---- Схема однолинейная(Электрика) // Tolik 10/02/2021 -- Procedure DropDownNextToolbar; Procedure DropDownFirstToolbar; Function CreateTextObject(x,y: Double; aCaption: TStringList; aisBold: Boolean = False): TRichText; // procedure RestoreCadGridStatus; Function GetPropValFromFigure(aFigureID: Integer; aCad: TF_Cad; aPropValSysName: String): string; // Tolik 09/03/2021 -- function CheckConnectorUseUGOBounds(aConnector: TConnectorObject): Integer; // Tolik 09/03/2021 -- Procedure ClearCADsInProgress(var aCadList: TList); // Tolik 24/03/2021 -- function CheckNeedDrawGuides(aPortCount: integer): Boolean; function CheckCanMovePointOnSnap(aObject, AConn: TConnectorObject): Boolean; Procedure DeSelectSCSFigureInPM(aID: Integer); // Tolik 28/04/2021 -- Procedure CheckCloseReportForm; // Tolik 30/04/2021 -- Procedure DeleteCableBySelFigures(aDelList: TList; aDelAllFromTrace, aDelFomPoint: Boolean); // Tolik 20/05/2021 -- Procedure DeleteConnectedToPointsCable; // Tolik 24/05/2021 -- Procedure DelCableByAllLengthFromSelected; // Tolik 25/05/2021 -- function GetListsByDeleteCable(aDelCableFromPoint: Boolean; aDelComponMode: TDelComponMode): TList; //Tolik 25/05/2021 -- function CheckAllCadFiguresSelected: Boolean; // Tolik 26/05/2021 -- function CheckNeedInputBox: boolean; // Tolik 26/05/2021 -- перенесено из USCS_Main function CheckHasCadSelectedPoints: boolean; // 08/06/2021 -- function GetNormalSTRUom: string; // Tolik 04/02/2022 -- Procedure GetUserScaleVal; // Tolik 11/08/2021 -- запрос пользовательского масштаба Procedure SetHScale; // Tolik 12/08/2021 -- Procedure DropTool;//Tolik 16/08/2021 -- Procedure SetUserLineHeightForAllProj;//Tolik 18/08/2021 -- Это типа, для дебилов - РОМА ПРИДУМАЛ -- если еще на проекте не создавались трассы, то спросить у пользователя, на какой высоте их располагать // и применить ко всему проекту function CheckNormBaseSCSCableSelected: Boolean; // Tolik 30/08/2021 -- function CheckSCSRack(aFigure: TFigure): Boolean; // Tolik 30/08/2021 -- procedure RemoveByNetType(var aList: TList); // Tolik 24/09/2021 -- Procedure ClearTreeSelection; // Tolik 25/11/2021 -- Procedure MagnetConnectorToNearestWall(aPoint: TConnectorObject); // Tolik 24/12/2021 -- Procedure CalcShadowPoint(ax,ay: Double); function isPointClose(ap1, ap2: TDoublePoint; adelta: Double): Boolean; Procedure CreateArchGuidesLines; Procedure DestroyArchGuidesLines; Procedure DrawShadowCrossPoints; // Tolik 14/01/2022 -- //Procedure DefineShadowCrossPoints(var x,y: Double);//Tolik 17/01/2022 Procedure DefineShadowCrossPoints(x,y: Double);//Tolik 17/01/2022 function GetStrUnitsOfMeasure: String; // Tolik -- вынес сюда из SetUserLineHeightForAllProj, чтобы можно было юзать и в других модулях //Tolik 24/01/2022 -- function StrToFloat_My(const S: string; const AFormatSettings: TFormatSettings): Extended; overload; function StrToFloat_My(const S: string): Extended; overload; function StrToFloatDef_My(const S: string; const Default: Extended; const AFormatSettings: TFormatSettings): Extended; overload; function StrToFloatDef_My(const S: string; const Default: Extended): Extended; overload; //Tolik 17/02/2022 -- Procedure ShowInvoice; //Tolik 24/08/2025 -- Procedure CreateBFMagistralTr(aFull: Boolean = true; aDown: Boolean = False; aUp: Boolean = False; aCompon: TSCSComponent = nil); function GetAllProjNormLists: TList; // Tolik 29/08/2025 -- procedure SaveUndoProjBefore3D; // Tolik 29/08/2025 -- // const {$IF Defined(SCS_PANDUIT) or Defined(SCS_PE)} urlSupport = 'http://cableproject.net/chat.php'; {$ELSE} urlSupport = 'http://support.expertsoft.com.ua/index/index/type/question'; {$IFEND} epsilon: Double = 0.000001; {$if Defined(ES_GRAPH_SC)} VersionEXE = '2.0.0'; {$else} //28.03.2011 VersionEXE = '1.5.7 alfa'; //16.03.2011 '1.5.6'; //VersionEXE = '3.0.3'; //27.12.2011 '1.5.7'; // VersionEXE = '3.0.4'; //30.05.2022 // VersionEXE = '3.0.5'; //09.12.2022 //VersionEXE = '3.0.6'; //08.12.2023 VersionEXE = '3.0.7'; //09.01.2025 {$ifend} {$IF Defined(SCS_RF) or Defined(SCS_PE) or Defined(SCS_SPA)} {$IF Defined(SCS_PE)} PROG_NEWSID = '-1'; SiteUrlNews = 'http://www.cableproject.net/'; {$ELSEIF Defined(SCS_SPA)} PROG_NEWSID = '-1'; SiteUrlNews = 'http://www.telcocad.net/'; {$ELSE} PROG_NEWSID = '-1'; SiteUrlNews = 'http://www.expertsoft.ru/'; {$IFEND} {$ELSE} {$IF Defined(TELECOM)} PROG_NEWSID = '22'; SiteUrlNews = 'http://www.expertsoft.com.ua/'; {$ELSE} {$if Defined(ES_GRAPH_SC)} PROG_NEWSID = '-1'; {$else} PROG_NEWSID = '3'; {$ifend} SiteUrlNews = 'http://www.expertsoft.com.ua/'; {$IFEND} {$IFEND} // форматы листов cA0x = 1189; cA0y = 841; cA1x = 841; cA1y = 594; cA2x = 594; cA2y = 421; cA3x = 421; cA3y = 297; cA4x = 297; cA4y = 210; cA5x = 210; cA5y = 148; cA6x = 105; cA6y = 74; cB4x = 353; cB4y = 250; cB5x = 250; cB5y = 176; cLetterx = 279; cLettery = 215; cTabloidx = 431; cTabloidy = 279; cSCSExpert = 120; cCADNoobAdd = 94; //Tolik 17/08/2021 -- //cCADNoob_PE = 840+cCADNoobAdd; cCADNoob_PE = 440+cCADNoobAdd; // cSCSNoob_PE = 240; //Tolik 17/08/2021 -- //cCADNoob_SCS = 940+cCADNoobAdd; cCADNoob_SCS = 540+cCADNoobAdd; // cSCSNoob_SCS = 200; cCADNoob_TEL = 890+cCADNoobAdd; // Индексы классов ciOrthoLine = 01; ciConnectorObject = 02; ciTextMod = 03; ciFigureGrpMod = 04; ciFigureGrpNotMod = 05; ciFrame = 06; ciSCSHDimLine = 07; ciSCSVDimLine = 08; ciRichTextMod = 09; ciCabinet = 10; ciCabinetExt = 11; ciCabinetNumber = 12; ciPlanObject = 13; ciPlanConnector = 14; ciPlanTrace = 15; ciCadNorms = 16; ciSCSFigureGrp = 17; ciHouse = 18; ciApproach = 19; ciFigureGrp = 20; // Номера слоев lnSubstrate = 1; lnSCSCommon = 2; lnArch = 8; lnRoom = 9; // Направление сдвига объектов - shift direction sdUp = 1; sdDown = 2; sdLeft = 3; sdRight = 4; // Типы объектов рамки ftProjectName = 100; ftListName = 200; ftCodeName = 300; ftIndexName = 400; ftDeveloperName = 500; ftCheckerName = 600; //03.10.2012 ftMainEngineer = 700; ftApproved = 800; ftDesignStage = 900; ftOrgName = 1000; ftListDescription = 1100; ctFrameTypeCount = 11; ctCoordNearDelta = 0.8; //1.5; //23.04.2012 1.1; var //Tolik 23/10/2023 -- GPortsCupBoard: string = ''; GReportBusyPortsCount: string = ''; GReportFreePortsCount: string = ''; // Tolik 26/04/2018 -- HListOfCadsFor3DModel: TList = nil; // отсортированный список листов проекта (при формировании 3-D модели проекта) LListOfCadsFor3DModel: TList = nil; // список кадов выше или на нуле для 3Д модели проекта ListOfCadsFor3DModel: TList = nil; // список кадов ниже нуля на 3Д модели проекта F3DFloors: TList = nil; // список объектов подложки(планов) на 3Д модели проекта F3DPlaneNotLoaded: Boolean = True; // флаг показывает, что базовая (на 0-уровне) подложка еще не была загружена в 3Д модель проекта NotBase3DPlane: TGLPlane = nil; // дополнительная(не базовая) подложка для добавления в 3Д модель проекта, если пока Nil - то добавляется базовая, что на уровне 0 по флагу F3DPlaneNotLoaded F3DSavedCad: TF_Cad = nil; // Текущая GCadForm нужна для правильного определения высоты этажа и его порядка расположения при формировании 3Д модели проекта // GCheckAccessory: Boolean = False; GReadOnlyMode: Boolean = False; Newshandle : THandle; GNowRefresh: Boolean = False; // флаг обновления КАД при PCad.Refresh GExitProg: Boolean = False; // флаг выхода их приложения GTraceStatus: Boolean = False; // флаг статуса трассы (режим трейса/нормальный) GObjectStatus: Boolean = False; // флаг статуса РТ (режим трейса/нормальный) GIsLastShadowCleared: Boolean = False; // флаг был ли очищен последний Shadow при восстоновлении трассы GTraceNotMove: Boolean = False; // флаг был ли перемещен РТ в режиме трейса GNormalNotMove: Boolean = False; // флаг был ли перемещен РТ в норм. режиме GIsConnMoved: Boolean = False; // флаг РТ был перемещен GIsMousePressed: Boolean = False; // флаг левая кнопка мыши сейчас нажата GIsDrawShadow: Boolean = False; // флаг рисования Shadow на DragOver GReDrawAfterRefresh: Boolean = False; // флаг перерисовать Shadow трассы после обновления КАДа GIsProgress: Boolean = False; // флаг наличие прогресс-бара в данный момент GMoveWithRaise: Boolean = True; // флаг перемещать Рт вместе с с-п GAppMinim: Boolean = False; // флаг приложение минимизировано GAutoDelete: Boolean = False; // флаг - удалить объекты без вопросов // GWasDeleteQuery: Boolean = False; // флаг был ли выдан запрос на удаление объектов GCanDeleteFigures: Boolean = False; // флаг удалять ли объекты по запросу GMoveByArrow: Boolean = False; // флаг - перемещение курсором на клаве GIsProgressHandling: Boolean = False; // флаг прогресс-баг сейчас активен (на экране) GtmpIsRaise: Boolean = False; // сохр. свойства с-п или не с-п для текущей трассы GListRaiseWithErrors: Boolean = False; // флаг - лист был поднят с ошибками GDisableMove: Boolean = False; // запрещать все связанные перемещения (для сгруппированных) GMovedByLine: Boolean = False; // флаг, что перемещение идет через линию GMovedByOtherObject: Boolean = False; // флаг, что перемещение идет через другой объект GMovedBySelf: Boolean = False; // флаг, что перемещение идет через себя GProjectChanged: Boolean = False; // в текущем проекте были изменения GCanRefreshProperties: Boolean = True; // можно обновлять свойства на обработчике ShowCreateRaiseQuery: Boolean = True; // выдавать запрос на подтверждение создания м-э с-п GOrthoStatus: Boolean = False; // статус ортогональности по дефолту GLastClickOrtho: Boolean = False; // последний клик орто GNotNeedCheckRaisesBeforeClose: Boolean = False; // не проверять лист на наличие м-э с-п перед закрытием GPreview: Boolean = False; // запуск с превью, установить формат листа принудительно GCloseProg: Boolean = False; GDefaultAngle: Integer = 90; // угол ортогонального поворота трассы по дефолту GDefaultNum: Integer = 1; // кол-во линий в трассе по дефолту GClickIndex: Integer = 0; // кол-во кликов в режиме создания трассы GIsProgressCount: Integer = 0; // кол-во созданных прогресс-баров в цикле GSavedScrollPosX: Integer = -1; // сохр. позиция скролла по Х GSavedScrollPosY: Integer = -1; // сохр. позиция скролла по Х GSavedZoomScale: Integer = 100; // сохр. масштаб КАДа GSaveUndoCount: Integer = 1; // кол-во действий после которого следует делать слепок для Ctrl+Z GDefaultGap: Double = 4; // расстояние между линиями у мультилайна по дефолту GDraggedFigureZOrder: Double = -1; // высота создаваемого объекта из НБ в режиме DragOver GCurrShadowTraceX: Double = -1; // текущее положение по X линии в режиме ShadowTrace GCurrShadowTraceY: Double = -1; // текущее положение по Y линии в режиме ShadowTrace GRoomHeight: Double = 2.5; // высота комнаты по дефолту GFalseFloorHeight: Double = 0.15; // высота фальш-потолка по дефолту GConnHeight: Double = 0.3; // высота РТ по дефолту GLineHeight: Double = 2.35; // высота трасс по дефолту GAddDeltaX: Double = 0; // расстояние по X на которое был сдвинут курсор при клике на РТ (отнимаеться от deltax на Move) GAddDeltaY: Double = 0; // расстояние по Y на которое был сдвинут курсор при клике на РТ (отнимаеться от deltay на Move) GLastSurfaceMoveX: Double = 0; // последнее положение КАДа по Х при панорамировании GLastSurfaceMoveY: Double = 0; // последнее положение КАДа по Y при панорамировании // положение трассируемой линии ActualPoints[1] & ActualPoints[2] GLastTracedLinePoints1: TDoublePoint; GLastTracedLinePoints2: TDoublePoint; // начальное положение объекта перед трассированием GBeforeDragConnectorPoints: TDoublePoint; // ap для коннектора GBeforeDragOrthoLinesPoints1: TDoublePoint; // ap1 для трассы GBeforeDragOrthoLinesPoints2: TDoublePoint; // ap2 для трассы GOrthoLinePoints1: TDoublePoint; // сохр. точек ортолинии в Stream - ap1 GOrthoLinePoints2: TDoublePoint; // сохр. точек ортолинии в Stream - ap2 GConnectorPoints: TDoublePoint; // сохр. точки РТ в Stream GCurrMousePos: TDoublePoint; // текущее положение мыши на КАДе GMouseDownPos: TDoublePoint; // положение мыши на КАДе в момент клика GTempActualPoints: array of TDoublePoint; // сохр. массив точек для создания трассы GTempDrawFigureAP: array of TDoublePoint; // сохр. массив точек для DrawFigure объекта GGlobalShiftState: TShiftState; // состояние клавиш Shift, Ctrl, Alt на КАДе GCurrentConnectorType: TConnectorType; // текущий тип создаваемого коннектора SCSEngine: TSCSEngine = nil; // класс, для получения УГО из НБ для РТ и трасс GtmpObjectFromRaisedLine: TConnectorObject = nil; // сохр. Объект на основании от с-п GDeletedFromPMFigure: TFigure = nil; // удаленный из ПМ объект GPopupFigure: TFigure = nil; // текущая Popup фигура GPopupPoint: TPoint; // Tolik 25/03/2021 -- GFigureSnap: TFigure = nil; // текущий объект для привязывания GPrevFigureSnap: TFigure = nil; // предыдущий объект для привязывания GFigureTraceTo: TFigure = nil; // текущий объект для привязывания в режиме трейса CheckFigure: TFigure = nil; // фигура, найденная при клике или при дропе GPrevFigureTraceTo: TFigure = nil; // предыдущий объект для привязывания в режиме трейса GPropertiesObject: TFigure = nil; // текущая фигура для вызова свойств GShadowObject: TFigureGrpNotMod = nil; // Shadow для оотображения в режиме GLastConnector: TConnectorObject = nil; // последний модифицированный коннектор GEndPoint: TFigure = nil; // текущая конечная точка GRefreshCad: TPowerCad = nil; // КАД для вызова Refresh GCadForm: TF_CAD = nil; // указатель на текущий КАД GLastCadForm: TF_CAD = nil; // указатель на последний КАД GListWithEndPoint: TF_CAD = nil; // указатель на КАД на котором обозначена конечная точка //GSaveNavigatorFigures: TList = nil; // лист с сохр. фигур Навигатора GSaveNavigatorFigures: TMyObjectList = nil; // лист с сохр. фигур Навигатора GTempJoinedOrtholinesList: TList = nil; // лист с сохр. привязанными орлиниями (для режима трейса) GTempJoinedConnectorsList: TList = nil; // лист с сохр. привязанными коннекторами (для режима трейса) GTempJoinedLinesConnectors: TList = nil; // лист с сохр. привязанными коннекторами через привязанную линию (для режима трейса) GSnapFiguresList: TList = nil; // сохр. список привязанных объектов в режиме создания линии GUndoList: TList = nil; // Undo лист для проекта GRedoList: TList = nil; // Redo лист для проекта //Tolik 12/01/2021 -- направляющие при проектировании объектов архитектуры GArchLineH: TLine = nil; GArchLineV: TLine = nil; GCallEndPoint: Boolean = True; // GAutoTraceCount: integer; GMyLog: TStringList; Gt_matrix: boolean = false; GAutoAddCableAfterDragDrop: Boolean = false; GCableStartDrag: Boolean = False; GCurrentRoom3DView: TSCSComponent = nil; GSaved3DModelExist: Boolean = True; GConnecntOnlyOneLineCompon: Boolean = False; GConnectEndPoints: Boolean = False; // соединять только крайние объекты при отрисовке кабелем GDropPcadTool: Boolean = False; // Сбросить тулзу када GSelNodeColor: TColor = -1; // Цвет нода дерева для отрисовки // *************************************************************************** GLiteVersion: Boolean = True; GUseLiteFunctional: Boolean = True; GAllowConvertInterfToUniversal: Boolean = False; GIfMasterUsed: Boolean = False; GSCStream: TMemoryStream; GCanDrawPoints: Boolean = True; // Tolik 17/01/2021 -- GDrawCounter: integer = 0; GDefineCounter: integer = 0; // 2011-05-10 G3DModelForProject: Boolean = False; //Tolik 29/08/2025 -- GIs3D: Boolean = False; {$IF Defined(ES_GRAPH_SC)} GUseArhOnlyMode: Boolean = True; {$ELSE} GUseArhOnlyMode: Boolean = False; {$IFEND} // *************************************************************************** GAllowExternalListCoordZ: Boolean = true; //22.08.2012 false - позволять использовать разные высоты объектов на распределительном листе GRaizeDownKoeff: Double = 4; GFtpConnectStr: string = ''; // Tolik 23/12/2024 - строка подключения к FTP серверу для резервного копирования GFtpFromDisk: Boolean = True; // Tolik 23/12/2024 GFtpToDisk: Boolean = True; // Tolik 23/12/2024 GisChangeFrom3D: Boolean = false; // Tolik 11/07/2025 -- (если были изменения на каде через 3Д) G3dUndoList: TList = nil; G3dUndoActList: TList = nil; //************* Hot Keys ********************* hkCtrlN, hkCtrlL, hkCtrlO, hkCtrlF4, hkCtrlS, hkCtrlP, hkCtrlE, hkF1, hkCtrlM, hkCtrlB, hkCtrlG, hkADD, hkSUBTRACT, hkCtrlF1, hkCtrlD, hkCtrlDIVIDE, hkCtrlSUBTRACT, hkCtrlDECIMAL, hkCtrl4, hkCtrlShiftO, hkCtrlShiftS, hkCtrlShiftN: word; // Зарегистрировать с целью блокировки ! (на КАДе) hkCtrlZ, hkCtrlY, hkCtrlX, hkCtrlC, hkCtrlV: word; //******************************************** GTestCopyMode: TCopyMode = cmSrcCopy; // Tolik GlobalDisableSaveForUndo: Boolean = False; GCanExecuteTimer_DefineObjectsParamsInCAD: Boolean = True; //29/10/2016-- GCanRefreshCad: Boolean; //07/11/2016-- GPrevSnapFigureID: Integer; // нужен при автоматическом создании трасс для // правильной обработки нескольких кликов подряд на одном и том же точечном объекте GProjectHasBrokenFigures: Boolean = False; ProjectNeedResave: Boolean = False; GLoadImageAsIs: Boolean = False; // Tolik 24/02/2021 -- //Tolik -- 12/01/2017 -- isWin10: Boolean = False; isWinLowThenWin7: Boolean = False; GWin10GDIMessage: Boolean = False; GUserObjectsQuota: Integer = 10000; // граничение на количество объектов USER в WINDOWS GUserOBjectsQuotaLimit_Message_Counter: Integer = 0; // Tolik 21/02/2017 GGuiEventCallCounter: Integer = 0; // -- счетчик вызова GuiEvent -- GIsProjectOpening: Boolean = False; // -- признак того, что сейчас как раз идет открытие проекта GCanAddObjToProject: Boolean = True; // -- можно ли еще добавить объект в проект // // Tolik -- 21/04/2017 -*- GWasShiftOnTraceCreate: Boolean = False; // признак того, что при использовании тулзы создания трасс пользователь // зажимал клавишу "Shift" -- тогда концы созданных трасс будут "притягиваться" к объектам // иначе объекты, по которым кликали, будут подтягиваться к коннекторам созданных трасс GCanRefreshTree: Boolean = True; // можно ли обновлять дерево менеджера проектов GisGroupUpdate: Boolean = False; // -- признак выполнения операций над группой фигур GClearFigures: Boolean = False; GProjectClose: Boolean = False; GComponCounter: Integer = 0; GImageScale: double = 0; // GComponsParentListForPortsReindex: TList = nil; // Tolik 09/04/2020 -- список родительских компонент для возможной(на усмотрение пользователя) // переиндексации портов, если те вдруг не совпадут при выполнении действия // "Заменить компонент на....", т.к. если компонента будет иметь парента, то у парента поломается // номерация портов GisOpenProjectDelFromPM: boolean = false; // флаг удаления открытого проекта из ПМ, чтобы не переопределять. например, связи кабеля после удаления его куска, // а просто сбросить все компоненты удаляемого проекта GSavedSnapGridStatus: Integer = -1; GAutoCreatedGuide: Boolean = False; GisListCopy: Boolean = False; // Tolik 16/06/2021 -- выставить, если копируется лист, чтобы не вызывать загрузку подложки GisUserDimLine: Boolean = False; // Tolik 10/08/2021 -- признак установки масштаба (после загрузки подложки) -- GUserScaleVal: Double = 0; // Tolik 10/08/2021 -- значение масштаба, введенное пользователем (после загрузки подложки) -- GRackToRack: Boolean = False; // Tolik 17/08/2021 -- соединение двух шкафов кабелем между собой... GAfterAutoCr: Boolean = False; GisOrthoLineHadow: Boolean = False; GNewVesrChecked: Boolean = False; GEndPointSelected: Boolean = False; GAutoTraceCreationOrder: integer = -1; // Tolik -- если вызывался мастер автосоздания трасс, то в случае создания отдельной трассы вытсавитьв 2, чтобы // если потом дальше автоматом будет вызываться мастер автотрассировки электрики (только дропа кабеля касается) // выставить в мастере трассировки электрики подключение каждого элемента своим кабелем GNoTraceCable: Boolean = False; GShadowMagnetPoint: TDoublePoint; GWallPathPointX: PDoublePoint = nil; GWallPathPointY: PDoublePoint = nil; GisCadRefresh: Boolean = False; GPointNear: double = 2; // расстояние, на котором, типа, точка пути близко к курсору по координате GTraceToPoint: Boolean = True; GisDrop: Boolean = False; // Tolik 18/02/2022 -- флаг, чтобы понимать в разных местах, что в данные процедуры мы пришли с дропа GisAutoRotingCable: Boolean = False; // Tolik 30/05/2022 -- флажок трассировки кабеля, чтобы сбрасывать лишние UNDO при установке недостающих компонент в шкаф GPlugSwitch: TFigure = nil; // Tolik 21/06/2022 -- выключатель, над которым нужно поставить клеммную коробку GGlobalRichText: TRichText = nil; implementation uses USCS_Main, Menus, U_main, U_MasterNewList, U_MasterNewListLite, U_AutoTraceType, U_Layers, FPlan, U_SCSObjectsProp, cxMemo, U_ChooseComponTypes, U_EndPoints, U_TrunkSCS, U_Constants, U_ChooseDesignBoxParams, U_AutoTraceConnectOrder, U_Protection, cxCheckBox, U_PrintLists, U_ArchCommon, U_ImportDXF, U_ProtectionCommon, U_InputRadio, U_BaseConstants, cxSpinEdit, Printers, PCPanel, U_InputMark, U_PEAutotraceDialog{Tolik}, U_SCSClasses, U_MakeEditCrossConnection, U_DimLineDialog, U_ResourceReport; //Tolik 29/08/2025 -- function GetAllProjNormLists: TList; // Tolik 29/08/2025 -- var i: integer; Cad: TF_CAD; begin Result := TList.Create; for i := 0 to F_ProjMan.GSCSBase.CurrProject.ProjectLists.Count - 1 do begin if F_ProjMan.GSCSBase.CurrProject.ProjectLists[i].Setting.ListType = lt_Normal then begin Cad := GetListByID(F_ProjMan.GSCSBase.CurrProject.ProjectLists[i].SCSID); if Cad <> nil then Result.Add(Cad); end; end; end; procedure SaveUndoProjBefore3D; var prLists: TList; begin prLists := GetAllProjNormLists; SaveForProjectUndo(prLists, true, false, true); prLists.Free; end; // //Tolik 24/08/2025 -- Procedure CreateBFMagistralTR(aFull: Boolean = true; aDown: Boolean = False; aUp: Boolean = False; aCompon: TSCSComponent = nil); var i, ListIndex: integer; x,y: Double; FCad, SavedGcadForm: TF_Cad; CadList: TList; CreatedLine: TOrthoLine; p1, p2: TDoublePoint; SavedMoveWithRaise, SSGrid, SSN, SSG: Boolean; SCSList: TSCSList; begin CadList := TList.Create; //Full if aFull then begin for i := 0 to F_ProjMan.GSCSBase.CurrProject.ProjectLists.Count - 1 do begin if F_ProjMan.GSCSBase.CurrProject.ProjectLists[i].Setting.ListType = lt_Normal then begin FCad := GetListByID(F_ProjMan.GSCSBase.CurrProject.ProjectLists[i].SCSID); if FCad <> nil then CadList.Add(FCad); end; end; end else begin SCSList := F_ProjMan.GSCSBase.CurrProject.GetListBySCSID(GCadForm.FCADListID); if SCSList <> nil then begin ListIndex := F_ProjMan.GSCSBase.CurrProject.ProjectLists.IndexOf(SCSList); //UP if aUP then begin for i := ListIndex to F_ProjMan.GSCSBase.CurrProject.ProjectLists.Count - 1 do begin if F_ProjMan.GSCSBase.CurrProject.ProjectLists[i].Setting.ListType = lt_Normal then begin FCad := GetListByID(F_ProjMan.GSCSBase.CurrProject.ProjectLists[i].SCSID); if FCad <> nil then CadList.Add(FCad); end; end; end else //Down if aDown then begin for i := ListIndex Downto 0 do begin if F_ProjMan.GSCSBase.CurrProject.ProjectLists[i].Setting.ListType = lt_Normal then begin FCad := GetListByID(F_ProjMan.GSCSBase.CurrProject.ProjectLists[i].SCSID); if FCad <> nil then CadList.Add(FCad); end; end; end; end; end; if CadList.Count > 1 then begin SavedGCadForm := GCadForm; SavedMoveWithRaise := GMoveWithRaise; GMoveWithRaise := False; p1.x := GMouseDownPos.x; p1.y := GMouseDOwnPos.y; p1.z := 0; p2.x := GMouseDownPos.x + 1; p2.y := GMouseDOwnPos.y + 1; p2.z := 0; for i := 0 to CadList.Count - 1 do begin GCadForm := TF_Cad(CadList[i]); SSGrid := GCadForm.PCad.SnapToGrids; SSN := GCadForm.PCad.SnapToNearPoint; SSG := GCadForm.PCad.SnapToGuides; GCadForm.PCad.SnapToGrids := False; GCadForm.PCad.SnapToNearPoint := False; GCadForm.PCad.SnapToGuides := False; CreatedLine := CreateTraceByPoints(GCadForm.PCad, p1, p2); CreatedLine.ActualZOrder[1] := 0; TConnectorObject(CreatedLine.JoinConnector1).actualzOrder[1] := 0; TConnectorObject(CreatedLine.JoinConnector2).MoveP(p1.x - p2.x, p1.y - p2.y, False, False); CreatedLine.ActualZOrder[2] := GCadForm.FRoomHeight; TConnectorObject(CreatedLine.JoinConnector2).actualzOrder[1] := GCadForm.FRoomHeight; CreatedLine.LengthCalc; CreatedLine.LineLength := CreatedLine.LengthCalc; GCadForm.PCad.SnapToGrids := SSGrid; GCadForm.PCad.SnapToNearPoint := SSN; GCadForm.PCad.SnapToGuides := SSG; if SavedGcadForm.cbManualCableTracingMode.Down then begin if F_NormBase.GSCSBase.SCSComponent <> nil then begin if F_NormBase.GSCSBase.SCSComponent.IsLine = biTrue then begin CopyComponentToSCSObject(CreatedLine.ID, F_NormBase.GSCSBase.SCSComponent.ID); end; end; end; end; GCadForm := SavedGCadForm; GMoveWithRaise := SavedMoveWithRaise; CadList.Free; end; CadList.Free; end; //Tolik 16/02/2022 -- Procedure ShowInvoice; var RepParams: TReportItemParams; CurrRep: TF_ResourceReport; OldReportUseKind: tReportUseKinds; AReportItemParamValues: TReportItemParams; WorkFlag, ResFlag, NetTypesFlag: Boolean; begin if F_ProjMan.GSCSBase.CurrProject <> nil then begin CheckCloseReportForm; if F_ProjMan.GSCSBase.CurrProject.Active then begin //17/02/2022 -- показываем счет-фактуру (раньше надо было ведомость работ) RepParams := TReportItemParams.Create(fmCommerceInvoice, rtCommerceInvoice, rkProject); RepParams.CanHaveActiveComponents := biTrue; RepParams.CanShowResources := biTrue; RepParams.CanShowWorks := biTrue; RepParams.CanPricePrecision := biTrue; RepParams.CanKolvoPrecision := biTrue; RepParams.CanHaveSupplyValue := biTrue; RepParams.CanRoundValue := biTrue; RepParams.CanHaveDismountAccount := biTrue; RepParams.CanHaveTemplate := biTrue; RepParams.CanAsPlacingInProj := biTrue; F_ProjMan.Tree_Catalog.Select(F_ProjMan.GSCSBase.CurrProject.TreeViewNode,[]); CurrRep := F_ProjMan.CreateFResourceReport; NetTypesFlag := CurrRep.AllNetTypes; WorkFlag := CurrRep.cbCanShowWorks.Checked; ResFlag := CurrRep.cbCanShowResources.Checked; CurrRep.cbCanShowWorks.Checked := True; CurrRep.cbCanShowResources.Checked := True; if currRep.FcbCanHaveActiveComponentsCurr = nil then currRep.FcbCanHaveActiveComponentsCurr := TRzCheckBox(CurrRep.TsProjRepParams.Controls[8]); if currRep.FcbCanHaveDismountAccountCurr = nil then currRep.FcbCanHaveDismountAccountCurr := TRzCheckBox(CurrRep.TsProjRepParams.Controls[10]); OldReportUseKind := currRep.ReportUseKind; currRep.ReportUseKind := [rkProject]; currRep.AllNetTypes := True; //CurrRep.ShowReportByParams(TSCSCatalog(F_ProjMan.GSCSBase.CurrProject), RepParams); currRep.ShowCommerceInvoice(TSCSCatalog(F_ProjMan.GSCSBase.CurrProject), RepParams, RepParams); currRep.ReportUseKind := OldReportUseKind; CurrRep.cbCanShowWorks.Checked := WorkFlag; CurrRep.cbCanShowResources.Checked := ResFlag; CurrRep.AllNetTypes := NetTypesFlag; { RepParams := TReportItemParams.Create(fmRNorms, rtNorms, rkProject); RepParams.CanHaveTemplate := biTrue; RepParams.CanAsPlacingInProj := biTrue; F_ProjMan.Tree_Catalog.Select(F_ProjMan.GSCSBase.CurrProject.TreeViewNode,[]); CurrRep := F_ProjMan.CreateFResourceReport; if currRep.FcbCanHaveActiveComponentsCurr = nil then currRep.FcbCanHaveActiveComponentsCurr := TRzCheckBox(CurrRep.TsProjRepParams.Controls[8]); if currRep.FcbCanHaveDismountAccountCurr = nil then currRep.FcbCanHaveDismountAccountCurr := TRzCheckBox(CurrRep.TsProjRepParams.Controls[10]); OldReportUseKind := currRep.ReportUseKind; currRep.ReportUseKind := [rkProject]; currRep.AllNetTypes := True; //CurrRep.ShowReportByParams(TSCSCatalog(F_ProjMan.GSCSBase.CurrProject), RepParams); currRep.ShowFolderNormReport(TSCSCatalog(F_ProjMan.GSCSBase.CurrProject), RepParams, true); currRep.ReportUseKind := OldReportUseKind; } end; end; end; // function GetNormalSTRUom: string; // Tolik 04/02/2022 -- begin if GCurrProjUnitOfMeasure = umSM then Result := fMetric_sm else if GCurrProjUnitOfMeasure = umM then Result := fMetric_m else if GCurrProjUnitOfMeasure = umIn then Result := fWhitworth_in else if GCurrProjUnitOfMeasure = umFt then Result := fWhitworth_ft; end; //Tolik 24/01/2022 -- из-за настроек региональных стандартов function StrToFloat_My(const S: string): Extended; begin Result := StrToFloat_My(S, FormatSettings); end; function StrToFloat_My(const S: string; const AFormatSettings: TFormatSettings): Extended; var ss: string; begin ss := s; if formatSettings.DecimalSeparator = ',' then ss := StringReplace(ss, '.', formatSettings.DecimalSeparator, [rfReplaceAll]) //ReplaceTextInStr(ss, '.', formatSettings.DecimalSeparator) else if formatSettings.DecimalSeparator = '.' then //ReplaceTextInStr(ss, ',', formatSettings.DecimalSeparator) ss := StringReplace(ss, ',', formatSettings.DecimalSeparator, [rfReplaceAll]); Result := StrToFloat(ss, AFormatSettings); end; function StrToFloatDef_My(const S: string; const Default: Extended): Extended; begin Result := StrToFloatDef_My(S, Default, FormatSettings); end; function StrToFloatDef_My(const S: string; const Default: Extended; const AFormatSettings: TFormatSettings): Extended; overload; var ss: string; begin ss := s; if formatSettings.DecimalSeparator = ',' then ss := StringReplace(ss, '.', formatSettings.DecimalSeparator, [rfReplaceAll]) //ReplaceTextInStr(ss, '.', formatSettings.DecimalSeparator) else if formatSettings.DecimalSeparator = '.' then //ReplaceTextInStr(ss, ',', formatSettings.DecimalSeparator) ss := StringReplace(ss, ',', formatSettings.DecimalSeparator, [rfReplaceAll]); Result := StrToFloatDef(ss, Default, AFormatSettings); end; // //Procedure DefineShadowCrossPoints(var x,y: Double); // Tolik 17/01/2022 Procedure DefineShadowCrossPoints(x,y: Double); // Tolik 17/01/2022 var i, xarrlen, yarrlen: integer; xPointList, yPointList: TDoublePointArr; DistToNearPointx, DistToNearPointy, currDist, Mindist: Double; Np: TDoublePoint; ax, ay: Double; xCrossPoint, yCrossPoint: PDoublePoint; Circle: TCircle; rgn: HRGN; OldMode: TPenMode; refreshFlag: boolean; Pt: Tpoint; ptIndex: integer; CanAddPointY: Boolean; distToSnapX, distToSnapY: Double; function CanDrawYPoint: Boolean; begin Result := True; if GWallPathPointX <> nil then begin Result := (CompareValue(GWallPathPointX.y, GWallPathPointY.y, 10) <> 0); end; end; // begin if GCanDrawPoints then begin { if GWallPathPointX <> nil then begin Dispose(GWallPathPointX); GWallPathPointX := nil; end; if GWallPathPointY <> nil then begin Dispose(GWallPathPointY); GWallPathPointY := nil; end; } if GCadForm.GWallTracePointList.count > 0 then DrawShadowCrossPoints; if GCadForm.cbMagnetWalls.Down then begin if GCadForm.FActiveNet <> nil then begin try GCanDrawPoints := false; refreshFlag := GCanRefreshCad; GCanRefreshCad := False; DrawShadowCrossPoints; xCrossPoint := nil; yCrossPoint := nil; Mindist := 100000000; xarrlen := 0; yarrlen := 0; DistToNearPointx := 1000000000; DistToNearPointy := 1000000000; for i := 0 to GCadForm.FActiveNet.Points.Count - 1 do begin CanAddPointY := True; if (CompareValue(GCurrMousePos.x, PDoublePoint(GCadForm.FActiveNet.Points[i])^.x, GPointNear) = 0) then begin inc(xarrlen); SetLength(xPointList, xarrLen); xPointList[xarrLen - 1].x := PDoublePoint(GCadForm.FActiveNet.Points[i])^.x; xPointList[xarrLen - 1].y := PDoublePoint(GCadForm.FActiveNet.Points[i])^.y; end else if (CompareValue(GCurrMousePos.y, PDoublePoint(GCadForm.FActiveNet.Points[i])^.y, GPointNear) = 0) then begin inc(yarrlen); SetLength(yPointList, yarrLen); yPointList[yarrLen - 1].x := PDoublePoint(GCadForm.FActiveNet.Points[i])^.x; yPointList[yarrLen - 1].y := PDoublePoint(GCadForm.FActiveNet.Points[i])^.y; end end; if Assigned(GCadForm.PCad.TraceFigure) then begin if GCadForm.PCad.TraceFigure is TWallPath then begin if TWallPath(GCadForm.PCad.TraceFigure).PointCount > 2 then begin for i := 1 to TWallPath(GCadForm.PCad.TraceFigure).PointCount - 2 do begin if (CompareValue(GCurrMousePos.x, TWallPath(GCadForm.PCad.TraceFigure).ActualPoints[i].x, GPointNear) = 0) then begin inc(xarrlen); SetLength(xPointList, xarrLen); xPointList[xarrLen - 1].x := TWallPath(GCadForm.PCad.TraceFigure).ActualPoints[i].x; xPointList[xarrLen - 1].y := TWallPath(GCadForm.PCad.TraceFigure).ActualPoints[i].y; end else if (CompareValue(GCurrMousePos.y, TWallPath(GCadForm.PCad.TraceFigure).ActualPoints[i].y, GPointNear) = 0) then begin inc(yarrlen); SetLength(yPointList, yarrLen); yPointList[yarrLen - 1].x := TWallPath(GCadForm.PCad.TraceFigure).ActualPoints[i].x; yPointList[yarrLen - 1].y := TWallPath(GCadForm.PCad.TraceFigure).ActualPoints[i].y; end; end; end; end; end; np.x := -1; np.y := -1; if ((xarrLen > 0) or (yarrlen > 0)) then begin ptIndex := -1; if xarrLen > 0 then begin New(GWallPathPointX); for i := 0 to xarrLen - 1 do begin currDist := Sqrt(sqr(xPointList[i].x - x) + sqr(xPointList[i].y - y)); if CompareValue(DistToNearPointx, currDist) = 1 then begin DistToNearPointx := currDist; np.x := xPointList[i].x; np.y := xPointList[i].y; GWallPathPointX.x := xPointList[i].x; GWallPathPointX.y := xPointList[i].y; end; OldMode := GCadForm.PCad.DEngine.Canvas.Pen.Mode; GCadForm.PCad.DEngine.Canvas.Pen.Mode := pmXor; rgn := 1; Circle := TCircle.Create(xPointList[i].x, xPointList[i].y, 1, 1, ord(psSolid), clLime, ord(bsClear), clBlack, GCadForm.PCad.GetLayerHandle(0), mydsNormal, nil); Circle.Id := 0; GCadForm.PCad.DEngine.DrawCircle(xPointList[i].x, xPointList[i].y, 1, clLime, 1, ord(psSolid), 0, ord(bsClear), rgn, false); //GCadForm.PCad.DEngine.DrawCircle(xPointList[i].x, xPointList[i].y, 1, clLime, 1, ord(psSolid), 0, ord(bsSolid), Circle.RegHandle, false, true); GCadForm.GWallTracePointList.Add(Circle); GCadForm.PCad.DEngine.Canvas.Pen.Mode := oldMode; end; if GCadForm.FActiveNet.WorldDim then DistToNearPointx := RoundN(DistToNearPointx / 1000 * GCadForm.FActiveNet.MapScale, 2) else DistToNearPointx := RoundN(DistToNearPointx / 10, 2); SetLength(xPointList, 0); end; if yarrLen > 0 then begin New(GWallPathPointY); for i := 0 to yarrLen - 1 do begin currDist := Sqrt(sqr(yPointList[i].x - x) + sqr(yPointList[i].y - y)); if CompareValue(DistToNearPointy, currDist) = 1 then begin DistToNearPointy := currDist; np.x := yPointList[i].x; np.y := yPointList[i].y; GWallPathPointY.x := yPointList[i].x; GWallPathPointY.y := yPointList[i].y; end; OldMode := GCadForm.PCad.DEngine.Canvas.Pen.Mode; GCadForm.PCad.DEngine.Canvas.Pen.Mode := pmXor; rgn := 1; Circle := TCircle.Create(yPointList[i].x, yPointList[i].y, 1, 1, ord(psSolid), clLime, ord(bsClear), clBlack, GCadForm.PCad.GetLayerHandle(0), mydsNormal, nil); Circle.Id := 0; GCadForm.PCad.DEngine.DrawCircle(yPointList[i].x, yPointList[i].y, 1, clLime, 1, ord(psSolid), 0, ord(bsSolid), rgn, false); GCadForm.GWallTracePointList.Add(Circle); GCadForm.PCad.DEngine.Canvas.Pen.Mode := oldMode; end; if GCadForm.FActiveNet.WorldDim then DistToNearPointy := RoundN(DistToNearPointy / 1000 * GCadForm.FActiveNet.MapScale, 2) else DistToNearPointy := RoundN(DistToNearPointy / 10, 2); SetLength(yPointList, 0); end; if GWallPathPointX <> nil then begin { OldMode := GCadForm.PCad.DEngine.Canvas.Pen.Mode; GCadForm.PCad.DEngine.Canvas.Pen.Mode := pmXor; rgn := 1; Circle := TCircle.Create(GWallPathPointX.x, GWallPathPointX.y, 1, 1, ord(psSolid), clLime, ord(bsClear), clBlack, GCadForm.PCad.GetLayerHandle(0), mydsNormal, nil); Circle.Id := 0; GCadForm.PCad.DEngine.DrawCircle(GWallPathPointX.x, GWallPathPointX.y, 1, clLime, 1, ord(psSolid), 0, ord(bsSolid), rgn, false); GCadForm.GWallTracePointList.Add(Circle); GCadForm.PCad.DEngine.Canvas.Pen.Mode := oldMode; } end; if GWallPathPointY <> nil then begin { if CanDrawYPoint then begin OldMode := GCadForm.PCad.DEngine.Canvas.Pen.Mode; GCadForm.PCad.DEngine.Canvas.Pen.Mode := pmXor; rgn := 1; Circle := TCircle.Create(GWallPathPointY.x, GWallPathPointY.y, 1, 1, ord(psSolid), clLime, ord(bsClear), clBlack, GCadForm.PCad.GetLayerHandle(0), mydsNormal, nil); Circle.Id := 0; GCadForm.PCad.Dengine.DrawCircle(GWallPathPointY.x, GWallPathPointY.y, 1, clLime, 1, ord(psSolid), 0, ord(bsSolid), rgn, false); GCadForm.GWallTracePointList.Add(Circle); GCadForm.PCad.DEngine.Canvas.Pen.Mode := oldMode; end; } end; { //if DistToNearPoint <= 0.5 then begin //if PointCount > 1 then if (Assigned(GCadForm.PCad.TraceFigure) and (GCadForm.PCad.TraceFigure is TWallPath)) then begin if ssShift in GGlobalShiftState then begin if DistToNearPointx <= 0.2 then begin x := np.x; //y := np.y; end; if DistToNearPointy <= 0.2 then begin //x := np.x; y := np.y; end; end else begin if CompareValue(TWallPath(GCadForm.PCad.TraceFigure).actualpoints[TWallPath(GCadForm.PCad.TraceFigure).PointCount].y, TWallPath(GCadForm.PCad.TraceFigure).actualpoints[TWallPath(GCadForm.PCad.TraceFigure).PointCount - 1].y) = 0 then begin if CompareValue(x, np.x, 2) = 0 then x := np.x; end else begin if CompareValue(y, np.y, 2) = 0 then y := np.y; end; end; end else begin if DistToNearPointx <= 0.2 then begin x := np.x; y := np.y; end; end; end } end; finally GCanDrawPoints := true; if GCadForm.GWallTracePointList.Count > 0 then INC(GDefineCounter); end; GCanRefreshCad := refreshFlag; end; end; end; end; Procedure DrawShadowCrossPoints; // Tolik 14/01/2021 -- var i: integer; OldMode: TPenMode; Circle: TCircle; rgn: HRGN; refreshFlag: boolean; begin refreshFlag := GCanRefreshCad; GCanRefreshCad := False; try if GCanDrawPoints then begin GCanDrawPoints := False; if Assigned(GCadForm.GWallTracePointList) then begin if GCadForm.GWallTracePointList.Count > 0 then begin rgn := 0; OldMode := GCadForm.PCad.DEngine.Canvas.Pen.Mode; GCadForm.PCad.DEngine.Canvas.Pen.Mode := pmXor; for i := 0 to GCadForm.GWallTracePointList.Count - 1 do begin Circle := TCircle(GCadForm.GWallTracePointList[i]); GCadForm.PCad.DEngine.DrawCircle(Circle.ap1.x, Circle.ap1.y, Circle.Radius,clLime, 1, ord(psSolid), 0, ord(bsClear), rgn, false); { GCadForm.PCad.DEngine.DrawCircle(Circle.ap1.x, Circle.ap1.y, Circle.Radius,clLime, 1, ord(psSolid), 0, ord(bsSolid), Circle.reghandle, false, true); } Inc(Circle.Id); //Circle.Free; end; GCadForm.PCad.DEngine.Canvas.Pen.Mode := OldMode; for i := GCadForm.GWallTracePointList.Count - 1 downto 0 do begin Circle := TCircle(GCadForm.GWallTracePointList[i]); if Circle.Id = 1 then begin GCadForm.GWallTracePointList.delete(i); Circle.free; end; //Circle.Free; end; //GCadForm.GWallTracePointList.Clear; //GCanRefreshCad := refreshflag; INC(GDrawCounter); end; if GCadForm.GWallTracePointList.Count = 0 then begin if GWallPathPointX <> nil then begin Dispose(GWallPathPointX); GWallPathPointX := nil; end; if GWallPathPointY <> nil then begin Dispose(GWallPathPointY); GWallPathPointY := nil; end; end; end; end; finally GCanDrawPoints := true; GCanRefreshCad := refreshflag; end; end; //Tolik 12/01/2021 -- Procedure CreateArchGuidesLines; begin if GArchLineH = nil then begin GArchLineH := TLine.Create(0, GCadForm.PCad.WorkHeight/2, GCadForm.PCad.WorkWidth, GCadForm.PCad.WorkHeight/2 ,1,1,clRed,ord(rsNone),0, dsTrace, GCadForm.PCad); GArchLineV := TLine.Create(GCadForm.PCad.WorkWidth/2, 0, GCadForm.PCad.WorkWidth/2 ,GCadForm.PCad.WorkHeight ,1,1,clRed,ord(rsNone),0, dsTrace, GCadForm.PCad); GCadForm.PCad.AddCustomFigure(GLN(GCadForm.PCad.GetLayerHandle(0)), GArchLineH, False); GCadForm.PCad.AddCustomFigure(GLN(GCadForm.PCad.GetLayerHandle(0)), GArchLineV, False); GArchLineH.Visible := False; GArchLineV.Visible := False; end; end; Procedure DestroyArchGuidesLines; var refreshFlag: boolean; begin if GArchLineH <> nil then begin //refreshFlag := GCanRefreshCad; //GCanRefreshCad := False; //BeginProgress; GCadForm.PCad.Figures.Remove(GArchLineH); GCadForm.PCad.Figures.Remove(GArchLineV); FreeAndNil(GArchLineH); FreeAndNil(GArchLineV); //GCanRefreshCad := refreshFlag; //EndProgress; end; end; // //Tolik 28/12/2021 - - Function CheckClockWise(arr: array of TDoublePoint): Double; var i, j: integer; begin Result := 0; { for I := 0 to Length(arr) - 2 do begin j := i + 1; Result := Result + (arr[i].x * arr[j].y); Result := Result - (arr[i].y * arr[j].x); end; } //S(xi*yj - xj*yi) + xN*y1 - x1*yN for I := 0 to Length(arr) - 2 do begin j := i + 1; Result := Result + ((arr[i].x * arr[j].y) - (arr[j].x * arr[i].y)); end; end; function CheckCanDoPerpendLine(ap1, ap2, ap3: TDoublePoint): Boolean; begin {Result := (Cos(GetRadOf2Lines(ap1, ap2, ap3)) > 0) and (Cos(GetRadOf2Lines(ap3, ap1, ap2)) > 0) and (Cos(GetRadOf2Lines(ap2, ap3, ap1)) > 0);} Result := (Cos(GetRadOf2Lines(ap1, ap2, ap3)) > 0) and (Cos(GetRadOf2Lines(ap2, ap1, ap3)) > 0); end; function isPointClose(ap1, ap2: TDoublePoint; adelta: Double): Boolean;//Tolik 10/01/2021 - - begin Result := ((CompareValue(ap1.x, ap2.x, adelta) = 0) and (CompareValue(ap1.y, ap2.y, adelta) = 0)); end; function GetNearestPoint(aPath: TNetPath; aPoint: TDoublePoint; var aNearestPoint: TDoublePoint): double; var i: integer; currDist, rDist, lDist: Double; isR, isClockWise: Boolean; ang1, ang2, tempang1, TempAng2: integer; a1, a2: double; PointArr: array of TDoublePoint; rp, lp, prevrp, prevlp : TDoublePoint; CloskWise: Double; gradus: integer; begin { SetLength(PointArr, 4); PointArr[0].x := aPath.ArcCenter.x; PointArr[0].y := aPath.ArcCenter.y; PointArr[1].x := aPath.r1.x; PointArr[1].y := aPath.r1.y; PointArr[2].x := aPath.r2.x; PointArr[2].y := aPath.r2.y; PointArr[3].x := aPath.ArcCenter.x; PointArr[3].y := aPath.ArcCenter.y; CloskWise := CheckClockWise(PointArr); } Result := -1; if aPath.Inverted then begin ang1 := Round(RadToDeg(GetRadOfLine(aPath.ArcCenter,aPath.r1))); ang2 := Round(RadToDeg(GetRadOfLine(aPath.ArcCenter,aPath.r2))); end else begin ang1 := Round(RadToDeg(GetRadOfLine(aPath.ArcCenter,aPath.r2))); ang2 := Round(RadToDeg(GetRadOfLine(aPath.ArcCenter,aPath.r1))); end; { if ang2 = 0 then ang2 := 2 * pi; } if ang2 = 0 then ang2 := 360; { ang1 := Round(RadToDeg(GetRadOfLine(aPath.ArcCenter, aPath.r1))); ang2 := Round(RadToDeg(GetRadOfLine(aPath.ArcCenter, aPath.r2))); } {if ang1 > ang2 then gradus := 1 else gradus := -1; } gradus := 1; //if ang1 > ang2 then if aPath.Inverted then begin rp.x := aPath.r1.x; rp.y := aPath.r1.y; lp.x := aPath.l1.x; lp.y := aPath.l1.y; end else begin rp.x := aPath.r2.x; rp.y := aPath.r2.y; lp.x := aPath.l2.x; lp.y := aPath.l2.y; end; TempAng1 := Abs(ang1 - ang2); if TempAng1 > 180 then TempAng1 := 360 - TempAng1; //rDist := -1; rDist := 10000000; lDist := 10000000; //for i := 0 to TempAng1 - 1 do i := ang1; repeat rp := RotatePoint(aPath.ArcCenter, rp, DegToRad(gradus)); currDist := Sqrt(sqr(rp.x - aPoint.x) + sqr(rp.y - aPoint.y)); if CompareValue(rDist, currDist) = 1 then begin rDist := currDist; prevrp.x := rp.x; prevrp.y := rp.y; end; { else begin //if i = 0 then if i = ang1 then begin rDist := currDist; prevrp.x := rp.x; prevrp.y := rp.y; end else break; end; } inc(i); if i = 360 then i := 0; until i = ang2; i := ang1; //for i := 0 to TempAng1 - 1 do repeat lp := RotatePoint(aPath.ArcCenter, lp, DegToRad(gradus)); currDist := Sqrt(sqr(lp.x - aPoint.x) + sqr(lp.y - aPoint.y)); if CompareValue(lDist, currDist) = 1 then begin lDist := currDist; prevlp.x := lp.x; prevlp.y := lp.y; end; { else begin //if i = 0 then if i = ang1 then begin lDist := currDist; prevlp.x := lp.x; prevlp.y := lp.y; end else break; end; } inc(i); if i = 360 then i := 0; until i = ang2; if comparevalue(rDist, ldist) = 1 then begin Result := lDist; aNearestPoint.x := prevlp.x; aNearestPoint.y := prevlp.y; end else begin Result := rDist; aNearestPoint.x := prevrp.x; aNearestPoint.y := prevrp.y; end; end; Procedure MagnetConnectorToNearestWall(aPoint: TConnectorObject); // Tolik 24/12/2021 -- var i: integer; x, y, currx, currY, currDist, Dist, DistToZero1, DistToZero2, distToLine: Double; LineAngle: Double; Bnd: TDoubleRect; CurrCaptionAngle : Double; CanMovePoint, ReverseLine, RotateCaption: Boolean; LinePoint1, LinePoint2, cp: TDoublePoint; DistFromPoint, DistFromDrawFigure: Double; SToGrid, SToGuid, SToNear, isArcPoint: Boolean; pArr: array of TDoublePoint; DistToArc: Double; ArcPoint: TDoublePoint; PathMoveTo: TNetPath; ArcAngle: Double; PointAngle: integer; p1, p2: TDoublePoint; isClockWise: Boolean; Points: TDoublePointArr; begin if GCadForm.FActiveNet <> nil then begin if GCadForm.FActiveNet.Paths.Count > 0 then begin try SToGrid := GCadForm.PCad.SnapToGrids; SToGuid := GCadForm.PCad.SnapToGuides; SToNear := GCadForm.PCad.SnapToNearPoint; GCadForm.PCad.SnapToGrids := False; GCadForm.PCad.SnapToGuides := False; GCadForm.PCad.SnapToNearPoint := False; CanMovePoint := False; Dist := 100000000; currx := 0; currY := 0; for i := 0 to GCadForm.FActiveNet.Paths.Count - 1 do begin x := aPoint.Ap1.x; y := APoint.Ap1.y; if (CheckCanDoPerpendLine(TNetPath(GCadForm.FActiveNet.Paths[i]).r1, TNetPath(GCadForm.FActiveNet.Paths[i]).r2, aPoint.Ap1) or TNetPath(GCadForm.FActiveNet.Paths[i]).isArc) then begin DistToZero1 := Sqrt(sqr(TNetPath(GCadForm.FActiveNet.Paths[i]).r1.x) + sqr(TNetPath(GCadForm.FActiveNet.Paths[i]).r1.y)); DistToZero2 := Sqrt(sqr(TNetPath(GCadForm.FActiveNet.Paths[i]).r2.x) + sqr(TNetPath(GCadForm.FActiveNet.Paths[i]).r2.y)); ReverseLine := CompareValue(DistTozero1, DistToZero2) <> -1; if TNetPath(GCadForm.FActiveNet.Paths[i]).isArc then distToLine := GetNearestPoint(TNetPath(GCadForm.FActiveNet.Paths[i]), aPoint.ap1, ArcPoint) else distToLine := (Sin(GetRadOf2Lines(TNetPath(GCadForm.FActiveNet.Paths[i]).r1, TNetPath(GCadForm.FActiveNet.Paths[i]).r2, aPoint.Ap1)) * Sqrt(sqr(TNetPath(GCadForm.FActiveNet.Paths[i]).r2.x - aPoint.Ap1.x) + sqr(TNetPath(GCadForm.FActiveNet.Paths[i]).r2.y - aPoint.Ap1.y))); if ReverseLine then PointToLine(TNetPath(GCadForm.FActiveNet.Paths[i]).r2, TNetPath(GCadForm.FActiveNet.Paths[i]).r1, x, y) else PointToLine(TNetPath(GCadForm.FActiveNet.Paths[i]).r1, TNetPath(GCadForm.FActiveNet.Paths[i]).r2, x, y); currDist := Sqrt(sqr(aPoint.Ap1.x - x) + sqr(aPoint.ap1.y - y)); //if compareValue(Dist, currDist) = 1 then if compareValue(ABS(Dist), ABS(distToLine)) = 1 then begin CanMovePoint := True; PathMoveTo := TNetPath(GCadForm.FActiveNet.Paths[i]); //Dist := currDist; Dist := distToLine; LinePoint1 := TNetPath(GCadForm.FActiveNet.Paths[i]).r1; LinePoint2 := TNetPath(GCadForm.FActiveNet.Paths[i]).r2; if TNetPath(GCadForm.FActiveNet.Paths[i]).isArc then begin LineAngle := GetRadOfLine(TNetPath(GCadForm.FActiveNet.Paths[i]).ArcCenter, ArcPoint); currx := ArcPoint.x; curry := ArcPoint.y; isArcPoint := True; end else begin currx := x; curry := y; isArcPoint := False; {if ReverseLine then LineAngle := GetRadOfLine(TNetPath(GCadForm.FActiveNet.Paths[i]).r2, TNetPath(GCadForm.FActiveNet.Paths[i]).r1) else } LineAngle := GetRadOfLine(TNetPath(GCadForm.FActiveNet.Paths[i]).r1, TNetPath(GCadForm.FActiveNet.Paths[i]).r2); end; end; end; if (CheckCanDoPerpendLine(TNetPath(GCadForm.FActiveNet.Paths[i]).l1, TNetPath(GCadForm.FActiveNet.Paths[i]).l2, aPoint.Ap1) or TNetPath(GCadForm.FActiveNet.Paths[i]).isArc) then begin x := aPoint.Ap1.x; y := APoint.Ap1.y; //PointToLine(TNetPath(GCadForm.FActiveNet.Paths[i]).l1, TNetPath(GCadForm.FActiveNet.Paths[i]).l2, x, y); DistToZero1 := Sqrt(sqr(TNetPath(GCadForm.FActiveNet.Paths[i]).l1.x) + sqr(TNetPath(GCadForm.FActiveNet.Paths[i]).l1.y)); DistToZero2 := Sqrt(sqr(TNetPath(GCadForm.FActiveNet.Paths[i]).l2.x) + sqr(TNetPath(GCadForm.FActiveNet.Paths[i]).l2.y)); ReverseLine := CompareValue(DistTozero1, DistToZero2) <> -1; if TNetPath(GCadForm.FActiveNet.Paths[i]).isArc then distToLine := GetNearestPoint(TNetPath(GCadForm.FActiveNet.Paths[i]), aPoint.ap1, ArcPoint) else distToLine := (Sin(GetRadOf2Lines(TNetPath(GCadForm.FActiveNet.Paths[i]).l1, TNetPath(GCadForm.FActiveNet.Paths[i]).l2, aPoint.Ap1)) * Sqrt(sqr(TNetPath(GCadForm.FActiveNet.Paths[i]).l2.x - aPoint.Ap1.x) + sqr(TNetPath(GCadForm.FActiveNet.Paths[i]).l2.y - aPoint.Ap1.y))); { if CompareValue(DistTozero1, DistToZero2) = -1 then PointToLine(TNetPath(GCadForm.FActiveNet.Paths[i]).l1, TNetPath(GCadForm.FActiveNet.Paths[i]).l2, x, y) else PointToLine(TNetPath(GCadForm.FActiveNet.Paths[i]).l2, TNetPath(GCadForm.FActiveNet.Paths[i]).l1, x, y); } if ReverseLine then PointToLine(TNetPath(GCadForm.FActiveNet.Paths[i]).l2, TNetPath(GCadForm.FActiveNet.Paths[i]).l1, x, y) else PointToLine(TNetPath(GCadForm.FActiveNet.Paths[i]).l1, TNetPath(GCadForm.FActiveNet.Paths[i]).l2, x, y); currDist := Sqrt(sqr(aPoint.Ap1.x - x) + sqr(aPoint.ap1.y - y)); //if compareValue(Dist, currDist) = 1 then if compareValue(ABS(Dist), ABS(distToLine)) = 1 then begin CanMovePoint := True; PathMoveTo := TNetPath(GCadForm.FActiveNet.Paths[i]); //Dist := currDist; Dist := distToLine; LinePoint1 := TNetPath(GCadForm.FActiveNet.Paths[i]).l1; LinePoint2 := TNetPath(GCadForm.FActiveNet.Paths[i]).l2; if TNetPath(GCadForm.FActiveNet.Paths[i]).isArc then begin isArcPoint := true; LineAngle := GetRadOfLine(TNetPath(GCadForm.FActiveNet.Paths[i]).ArcCenter, ArcPoint); currx := ArcPoint.x; curry := ArcPoint.y; end else begin isArcPoint := False; { if ReverseLine then LineAngle := GetRadOfLine(TNetPath(GCadForm.FActiveNet.Paths[i]).l2, TNetPath(GCadForm.FActiveNet.Paths[i]).l1) else } LineAngle := GetRadOfLine(TNetPath(GCadForm.FActiveNet.Paths[i]).l1, TNetPath(GCadForm.FActiveNet.Paths[i]).l2); currx := x; curry := y; end; end; end; end; if CanMovePoint then begin if Assigned(APoint.DrawFigure) then begin if PathMoveTo.isArc then begin end else begin { SetLength(pArr, 4); pArr[0].x := aPoint.ap1.x; pArr[0].y := aPoint.ap1.y; pArr[1].x := LinePoint1.x; pArr[1].y := LinePoint1.y; pArr[2].x := LinePoint2.x; pArr[2].y := LinePoint2.y; pArr[3].x := aPoint.ap1.x; pArr[3].y := aPoint.ap1.y; isClockWise := CheckClockWise(pArr) > 0; SetLength(pArr, 0); RotateCaption := True; LineAngle := RoundN(LineAngle - PI/2, 7); if LineAngle <> 0 then begin APoint.Rotate(LineAngle, APoint.ActualPoints[1]); //aPoint.DrawFigure.Rotate(LineAngle, aPoint.CenterPoint); aPoint.DrawFigure.Rotate(LineAngle, APoint.ActualPoints[1]); aPoint.FDrawFigureAngle := aPoint.FDrawFigureAngle + LineAngle; if aPoint.FDrawFigureAngle >= 2 * pi then aPoint.FDrawFigureAngle := aPoint.FDrawFigureAngle - 2 * pi; end; } //PointAngle := Round(RadToDeg(GetRadOfLine(aPoint.Ap1, GShadowMagnetPoint))); end; end; LinePoint1.x := aPoint.ap1.x; LinePoint1.y := aPoint.ap1.y; if isClockWise then begin LinePoint1.x := LinePoint1.x - ABS(Dist); //LinePoint1 := RotatePoint(aPoint.ap1, LinePoint1, LineAngle) end else begin LinePoint1.x := LinePoint1.x + ABS(Dist); //LinePoint1 := RotatePoint(aPoint.ap1, LinePoint1, -LineAngle); end; if isArcPoint then begin {LinePoint1 := RotatePoint(aPoint.ap1, LinePoint1, LineAngle); //aPoint.Move(currx - aPoint.ap1.x, curry - aPoint.ap1.y ); aPoint.Move(LinePoint1.x - aPoint.ap1.x, LinePoint1.y - aPoint.ap1.y );} //aPoint.Move(currx - aPoint.Ap1.x, curry - aPoint.Ap1.y); if GShadowMagnetPoint.x <> -100 then aPoint.Move(GShadowMagnetPoint.x - aPoint.Ap1.x, GShadowMagnetPoint.y - aPoint.Ap1.y) else aPoint.Move(currx - aPoint.Ap1.x, curry - aPoint.Ap1.y); if Assigned(aPoint.DrawFigure) then begin ArcAngle := GetRadOfLine(PathMoveTo.ArcCenter, aPoint.Ap1); currDist := Sqrt(sqr(PathMoveTo.ArcCenter.x - aPoint.Ap1.x) + sqr(PathMoveTo.ArcCenter.y - aPoint.Ap1.y)); DistToZero1 := Sqrt(sqr(PathMoveTo.ArcCenter.x - PathMoveTo.r1.x) + sqr(PathMoveTo.ArcCenter.y - PathMoveTo.r1.y)); DistToZero2 := Sqrt(sqr(PathMoveTo.ArcCenter.x - PathMoveTo.l1.x) + sqr(PathMoveTo.ArcCenter.y - PathMoveTo.l1.y)); DistToZero1 := Max(DistToZero1, DistToZero2); if CompareValue(DistToZero1, currDist, 0.1) = 1 then ArcAngle := ArcAngle + PI; aPoint.DrawFigure.Rotate(ArcAngle, aPoint.AP1); //aPoint.CaptionsGroup.Rotate(ArcAngle, aPoint.AP1); CurrCaptionAngle := 0; if aPoint.FCaptionsViewType = cv_Right then CurrCaptionAngle := 0; if aPoint.FCaptionsViewType = cv_Down then CurrCaptionAngle := 90; if aPoint.FCaptionsViewType = cv_Left then CurrCaptionAngle := 180; if aPoint.FCaptionsViewType = cv_Up then CurrCaptionAngle := 270; CurrCaptionAngle := CurrCaptionAngle + ArcAngle*180/PI; CurrCaptionAngle := round(CurrCaptionAngle) mod 360; if (CurrCaptionAngle >= 0) and (CurrCaptionAngle <= 45) then aPoint.FCaptionsViewType := cv_Right else if (CurrCaptionAngle > 45) and (CurrCaptionAngle < 135) then aPoint.FCaptionsViewType := cv_Down else if (CurrCaptionAngle >= 135) and (CurrCaptionAngle <= 225) then aPoint.FCaptionsViewType := cv_Left else if (CurrCaptionAngle > 225) and (CurrCaptionAngle < 315) then aPoint.FCaptionsViewType := cv_Up else if (CurrCaptionAngle >= 315) and (CurrCaptionAngle <= 360) then aPoint.FCaptionsViewType := cv_Right; aPoint.DefRaizeDrawFigurePos; // RefreshCAD(GCadForm.PCad); aPoint.ReCreateCaptionsGroup(false, false); //aPoint.CaptionsGroup.Rotate(ArcAngle, aPoint.Ap1); end; end else begin p1.x := Apoint.ap1.x; p1.y := aPoint.ap1.y; LinePoint1 := RotatePoint(aPoint.ap1, LinePoint1, LineAngle); if GShadowMagnetPoint.x <> -100 then begin if isPointClose(aPoint.ap1, GShadowMagnetPoint, 0.2) then begin SetLength(Points, 4); Points[0].x := PathMoveTo.r1.x; Points[0].y := PathMoveTo.r1.y; Points[1].x := PathMoveTo.r2.x; Points[1].y := PathMoveTo.r2.y; Points[2].x := PathMoveTo.l2.x; Points[2].y := PathMoveTo.l2.y; Points[3].x := PathMoveTo.l1.x; Points[3].y := PathMoveTo.l1.y; p2.x := aPoint.ap1.x + 0.2; p2.y := aPoint.ap1.y + 0.2; if PtInPolygon(Points, p2) then begin p2.x := aPoint.ap1.x - 0.2; p2.y := aPoint.ap1.y - 0.2; end; SetLength(Points, 0); aPoint.Move(p2.x - aPoint.ap1.x, p2.y - aPoint.ap1.y); end; CalcShadowPoint(aPoint.ap1.x, aPoint.ap1.y); if GShadowMagnetPoint.x <> -100 then begin LineAngle := GetRadOfLine(aPoint.Ap1, GShadowMagnetPoint) + PI; aPoint.Move(GShadowMagnetPoint.x - aPoint.Ap1.x, GShadowMagnetPoint.y - aPoint.Ap1.y); end; end else begin LineAngle := GetRadOfLine(aPoint.Ap1, LinePoint1) + PI; aPoint.Move(LinePoint1.x - aPoint.ap1.x, LinePoint1.y - aPoint.ap1.y ); end; if Assigned(aPoint.DrawFigure) then begin if CompareValue(LineAngle, PI*2, 0.02) <> -1 then LineAngle := RoundN(LineAngle - PI*2, 6); Bnd := aPoint.DrawFigure.GetBoundRect; cp.x := (Bnd.Left + Bnd.Right)/2; cp.y := (Bnd.Top + Bnd.Bottom)/2; currDist := Sqrt(sqr(cp.x - aPoint.Ap1.x) + Sqr(cp.y - aPoint.Ap1.y)); DistFromPoint := Sqrt(sqr(aPoint.Ap1.x - P1.x) + Sqr(aPoint.Ap1.y - P1.y)); DistFromDrawFigure := Sqrt(sqr(cp.x - P1.x) + Sqr(cp.y - P1.y)); Bnd := aPoint.DrawFigure.GetBoundRect; //if CompareValue(DistFromPoint, DistFromDrawFigure) = -1 then begin { APoint.Rotate(PI, APoint.ActualPoints[1]); aPoint.DrawFigure.Rotate(PI, APoint.ActualPoints[1]); aPoint.FDrawFigureAngle := aPoint.FDrawFigureAngle + PI; } if LineAngle <> 0 then begin APoint.Rotate(LineAngle, APoint.ActualPoints[1]); aPoint.DrawFigure.Rotate(LineAngle, APoint.ActualPoints[1]); aPoint.FDrawFigureAngle := aPoint.FDrawFigureAngle + LineAngle; // 15/02/2022 -- //aPoint.FDrawFigureAngle := aPoint.FDrawFigureAngle + PI; if CompareValue(aPoint.FDrawFigureAngle, 2 * pi) <> -1 then begin aPoint.FDrawFigureAngle := aPoint.FDrawFigureAngle - 2 * pi; if CompareValue(aPoint.FDrawFigureAngle, 0, 0.000001) = 0 then aPoint.FDrawFigureAngle := 0; RotateCaption := True; end; end else RotateCaption := False; end; { APoint.Rotate(LineAngle, APoint.DrawFigure.CenterPoint); aPoint.DrawFigure.Rotate(LineAngle, APoint.DrawFigure.CenterPoint); } Bnd := aPoint.DrawFigure.GetBoundRect; aPoint.GrpSizeX := Bnd.Right - Bnd.Left; aPoint.GrpSizeY := Bnd.Bottom - Bnd.Top; // if RotateCaption then begin CurrCaptionAngle := 0; if aPoint.FCaptionsViewType = cv_Right then CurrCaptionAngle := 0; if aPoint.FCaptionsViewType = cv_Down then CurrCaptionAngle := 90; if aPoint.FCaptionsViewType = cv_Left then CurrCaptionAngle := 180; if aPoint.FCaptionsViewType = cv_Up then CurrCaptionAngle := 270; CurrCaptionAngle := CurrCaptionAngle + LineAngle*180/PI; if CompareValue(DistFromPoint, DistFromDrawFigure) = 1 then CurrCaptionAngle := CurrCaptionAngle + 180; CurrCaptionAngle := round(CurrCaptionAngle) mod 360; if (CurrCaptionAngle >= 0) and (CurrCaptionAngle <= 45) then aPoint.FCaptionsViewType := cv_Right else if (CurrCaptionAngle > 45) and (CurrCaptionAngle < 135) then aPoint.FCaptionsViewType := cv_Down else if (CurrCaptionAngle >= 135) and (CurrCaptionAngle <= 225) then aPoint.FCaptionsViewType := cv_Left else if (CurrCaptionAngle > 225) and (CurrCaptionAngle < 315) then aPoint.FCaptionsViewType := cv_Up else if (CurrCaptionAngle >= 315) and (CurrCaptionAngle <= 360) then aPoint.FCaptionsViewType := cv_Right; aPoint.DefRaizeDrawFigurePos; // RefreshCAD(GCadForm.PCad); aPoint.ReCreateCaptionsGroup(false, false); end; end; end; end; Except on e: Exception do; end; GCadForm.PCad.SnapToGrids := SToGrid; GCadForm.PCad.SnapToGuides := SToGuid; GCadForm.PCad.SnapToNearPoint := SToNear; //aPoint.Rotate(LineAngle); end; GCadForm.PCad.Refresh; end; end; // Procedure CalcShadowPoint(ax,ay: Double); // Tolik 04/01/2021 -- var i: integer; x, y, currx, currY, currDist, Dist, DistToZero1, DistToZero2, distToLine: Double; CanMovePoint, ReverseLine: Boolean; DistToArc: Double; ArcPoint: TDoublePoint; p: TDoublePoint; begin if GCadForm.FActiveNet <> nil then begin GShadowMagnetPoint.x := -100; GShadowMagnetPoint.y := -100; if GCadForm.FActiveNet.Paths.Count > 0 then begin try p.x := ax; p.y := ay; Dist := 100000000; for i := 0 to GCadForm.FActiveNet.Paths.Count - 1 do begin x := ax; y := ay; if (CheckCanDoPerpendLine(TNetPath(GCadForm.FActiveNet.Paths[i]).r1, TNetPath(GCadForm.FActiveNet.Paths[i]).r2, p) or TNetPath(GCadForm.FActiveNet.Paths[i]).isArc) then begin DistToZero1 := Sqrt(sqr(TNetPath(GCadForm.FActiveNet.Paths[i]).r1.x) + sqr(TNetPath(GCadForm.FActiveNet.Paths[i]).r1.y)); DistToZero2 := Sqrt(sqr(TNetPath(GCadForm.FActiveNet.Paths[i]).r2.x) + sqr(TNetPath(GCadForm.FActiveNet.Paths[i]).r2.y)); ReverseLine := CompareValue(DistTozero1, DistToZero2) <> -1; if TNetPath(GCadForm.FActiveNet.Paths[i]).isArc then distToLine := GetNearestPoint(TNetPath(GCadForm.FActiveNet.Paths[i]), p, ArcPoint) else distToLine := (Sin(GetRadOf2Lines(TNetPath(GCadForm.FActiveNet.Paths[i]).r1, TNetPath(GCadForm.FActiveNet.Paths[i]).r2, P)) * Sqrt(sqr(TNetPath(GCadForm.FActiveNet.Paths[i]).r2.x - P.x) + sqr(TNetPath(GCadForm.FActiveNet.Paths[i]).r2.y - P.y))); if ReverseLine then PointToLine(TNetPath(GCadForm.FActiveNet.Paths[i]).r2, TNetPath(GCadForm.FActiveNet.Paths[i]).r1, x, y) else PointToLine(TNetPath(GCadForm.FActiveNet.Paths[i]).r1, TNetPath(GCadForm.FActiveNet.Paths[i]).r2, x, y); if compareValue(ABS(Dist), ABS(distToLine)) = 1 then begin CanMovePoint := True; Dist := distToLine; if TNetPath(GCadForm.FActiveNet.Paths[i]).isArc then begin currx := ArcPoint.x; curry := ArcPoint.y; end else begin currx := x; curry := y; end; end; end; if (CheckCanDoPerpendLine(TNetPath(GCadForm.FActiveNet.Paths[i]).l1, TNetPath(GCadForm.FActiveNet.Paths[i]).l2, P) or TNetPath(GCadForm.FActiveNet.Paths[i]).isArc) then begin x := ax; y := ay; //PointToLine(TNetPath(GCadForm.FActiveNet.Paths[i]).l1, TNetPath(GCadForm.FActiveNet.Paths[i]).l2, x, y); DistToZero1 := Sqrt(sqr(TNetPath(GCadForm.FActiveNet.Paths[i]).l1.x) + sqr(TNetPath(GCadForm.FActiveNet.Paths[i]).l1.y)); DistToZero2 := Sqrt(sqr(TNetPath(GCadForm.FActiveNet.Paths[i]).l2.x) + sqr(TNetPath(GCadForm.FActiveNet.Paths[i]).l2.y)); ReverseLine := CompareValue(DistTozero1, DistToZero2) <> -1; if TNetPath(GCadForm.FActiveNet.Paths[i]).isArc then distToLine := GetNearestPoint(TNetPath(GCadForm.FActiveNet.Paths[i]), p, ArcPoint) else distToLine := (Sin(GetRadOf2Lines(TNetPath(GCadForm.FActiveNet.Paths[i]).l1, TNetPath(GCadForm.FActiveNet.Paths[i]).l2, p)) * Sqrt(sqr(TNetPath(GCadForm.FActiveNet.Paths[i]).l2.x - p.x) + sqr(TNetPath(GCadForm.FActiveNet.Paths[i]).l2.y - p.y))); if ReverseLine then PointToLine(TNetPath(GCadForm.FActiveNet.Paths[i]).l2, TNetPath(GCadForm.FActiveNet.Paths[i]).l1, x, y) else PointToLine(TNetPath(GCadForm.FActiveNet.Paths[i]).l1, TNetPath(GCadForm.FActiveNet.Paths[i]).l2, x, y); if compareValue(ABS(Dist), ABS(distToLine)) = 1 then begin CanMovePoint := True; Dist := distToLine; if TNetPath(GCadForm.FActiveNet.Paths[i]).isArc then begin currx := ArcPoint.x; curry := ArcPoint.y; end else begin currx := x; curry := y; end; end; end; end; if CanMovePoint then begin GShadowMagnetPoint.x := currx; GShadowMagnetPoint.y := curry; end; Except on e: Exception do; end; end; end; end; Procedure ClearTreeSelection; // Tolik 25/11/2021 -- begin if Assigned(F_ProjMan.GSCSBase.CurrProject) then begin F_ProjMan.Tree_Catalog.ClearSelection(false); end; end; //Tolik 24/09/2021 -- procedure RemoveByNetType(var aList: TList); var i, j: integer; CanDelFromList: Boolean; SCSCatalog: TSCSCatalog; List: TSCSList; Figure: TFigure; begin for i := aList.Count - 1 downto 0 do begin Figure := TFigure(aList[i]); List := F_ProjMan.GSCSBase.CurrProject.GetListBySCSID(TF_CAD(Figure.Owner.Owner).FCADListID); if List <> nil then begin SCSCatalog := List.GetCatalogFromReferencesBySCSID(Figure.ID); if SCSCatalog <> nil then begin CanDelFromList := True; for j := 0 to SCSCatalog.ComponentReferences.Count - 1 do begin if SCSCatalog.ComponentReferences[j].IDNetType = GDropComponent.IDNetType then begin CanDelFromList := False; break; end; end; if CanDelFromList then aList.Delete(i); end; end; end; end; // function CheckNormBaseSCSCableSelected: Boolean; ////Tolik 30/08/2021 -- begin Result := False; 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 = 1 then if F_NormBase.GSCSBase.SCSComponent.ComponentType.SysName = ctsnOFCable then Result := True; end; //Tolik 16/08/2021 - - function CheckSCSRack(aFigure: TFigure): Boolean; var SCSCatalog: TSCSCatalog; SCSComponent: TSCSComponent; begin Result := False; if CheckFigureByClassName(aFigure, cTConnectorObject) then begin if (TConnectorObject(aFigure).isSnap or (GCadForm.PCad.TraceFigure <> nil)) then exit; //Tolik 30/08/2021 -- Это чтобы при снапе не вызвалось меню как на клике SCSCatalog := F_ProjMan.GSCSBase.CurrProject.CurrList.GetCatalogFromReferencesBySCSID(aFigure.ID); if SCSCatalog <> nil then begin SCSComponent := SCSCatalog.GetFirstComponent; if SCSComponent <> nil then begin if SCSComponent.IDNetType = 1 then begin if SCSComponent.ComponentType.SysName = ctsnCupboard then Result := True; end; end; end; end; end; // function GetStrUnitsOfMeasure: String; begin Result := ''; // система измерений if GCurrProjUnitOfMeasure = umSM then Result := cMetric_sm else if GCurrProjUnitOfMeasure = umM then Result := cMetric_m else if GCurrProjUnitOfMeasure = umIn then Result := cWhitworth_in else if GCurrProjUnitOfMeasure = umFt then Result := cWhitworth_ft; end; Procedure SetUserLineHeightForAllProj; var TraceHeight: Double; s,suom, ms: string; PausedProgress: Boolean; i: integer; oldCadProc: TWndMethod; ProgressPaused: Boolean; begin ProgressPaused := False; // 30/09/2021 - - GCadForm.PCad.OnSurfaceLeave := nil; try TraceHeight := -1; if GisProgress then if F_Progress.FPauseCount = 0 then begin ProgressPaused := True; PauseProgress(true); end; try { if GCurrProjUnitOfMeasure = umSM then suom := fMetric_sm; if GCurrProjUnitOfMeasure = umM then suom := fMetric_m; if GCurrProjUnitOfMeasure = umIn then suom := fWhitworth_in; if GCurrProjUnitOfMeasure = umFt then suom := fWhitworth_ft; } suom := GetNormalSTRUom; s := floattostr(MetreToUOM(GCadForm.FLineHeight)); ms := Trace_Mess + suom + ':' +#13#10+ Trace_Mess_1; InputQuery(Application.Name, ms, s); if s <> '' then TraceHeight := StrToFloat_My(s); except On E: Exception do s:= ''; end; if TraceHeight >= 0 then begin TraceHeight := UomToMetre(TraceHeight); //Lists for i := 0 to F_ProjMan.GSCSBase.CurrProject.ProjectLists.Count - 1 do begin if F_ProjMan.GSCSBase.CurrProject.ProjectLists[i].Setting.HeightRoom >= TraceHeight then F_ProjMan.GSCSBase.CurrProject.ProjectLists[i].Setting.HeightCorob := TraceHeight else F_ProjMan.GSCSBase.CurrProject.ProjectLists[i].Setting.HeightCorob := F_ProjMan.GSCSBase.CurrProject.ProjectLists[i].Setting.HeightRoom; end; //Cads for i := 0 to FSCS_Main.MDIChildCount - 1 do begin if FSCS_Main.MDIChildren[i] is TF_CAD then begin if TF_CAD(FSCS_Main.MDIChildren[i]).FRoomHeight >= TraceHeight then TF_CAD(FSCS_Main.MDIChildren[i]).FLineHeight := TraceHeight else TF_CAD(FSCS_Main.MDIChildren[i]).FLineHeight := TF_CAD(FSCS_Main.MDIChildren[i]).FRoomHeight; end; end; end; GCadForm.PCad.Refresh; if ProgressPaused then PauseProgress(false); F_ProjMan.GSCSBase.CurrProject.Setting.FirstTraceCreated := False; if F_ProjMan.GSCSBase.CurrProject.DefListSettings.HeightRoom >= TraceHeight then F_ProjMan.GSCSBase.CurrProject.DefListSettings.HeightCorob := TraceHeight else F_ProjMan.GSCSBase.CurrProject.DefListSettings.HeightCorob := F_ProjMan.GSCSBase.CurrProject.DefListSettings.HeightRoom; Finally GCadForm.PCad.OnSurfaceLeave := GCadForm.PCadSurfaceLeave; end; end; Procedure DropTool;//Tolik 16/08/2021 -- 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(GCadForm.PCad.DEngine, false); end; end; end; FSCS_Main.tbSelectExpert.Click; end; Procedure GetUserScaleVal; // Tolik 11/08/2021 -- var Val: Double; begin GUserScaleVal := 0; F_DimLineDialog.Caption := cCadClasses_Mes15; F_DimLineDialog.lbMessage.Caption := cCadClasses_Mes16; F_DimLineDialog.edDimValue.Properties.EditMask := '\d?\d?\d?\d?\d?\d?' + DecimalSeparator + '\d?\d?\d?'; F_DimLineDialog.edDimValue.Text := '10.0'; // if F_DimLineDialog.ShowModal = mrOk then begin Val := StrToFloat_My(F_DimLineDialog.edDimValue.Text); if CompareValue(Val, 0, 0.00001 ) <> 0 then GUserScaleVal := UOMToMetre(Val); end; end; Procedure SetHScale; // Tolik 12/08/2021 -- begin if GisUserDimLine then begin GetUserScaleVal; if CompareValue(GuserScaleVal, 0, 0.0001) > 0 then begin FSCS_Main.tbSCSHDimLineExpert.click; ShowHintRzR(cCadClasses_Mes36_, 5000); end else begin GisUserDimLine := False; GuserScaleVal := 0; end; end else begin GisUserDimLine := False; GuserScaleVal := 0; end; end; // вычисляет Z - координату "падения" точечного компонента на наклонную линию, // если координаты X, Y - известны Function GetCoordZ(ASnapFigure: TFigure; CoordX, CoordY: Double): Double; Var vx, vy, vz, xx1, xx2, yy1, yy2, zz1, zz2, TempZ : Double; Begin Result := 0; //первая точка прямой xx1 := RounDX(TOrthoLine(ASnapFigure).JoinConnector1.ActualPoints[1].x,2); yy1 := RounDX(TOrthoLine(ASnapFigure).JoinConnector1.ActualPoints[1].y,2); zz1 := RounDX(TConnectorObject(TOrthoLine(ASnapFigure).JoinConnector1).ActualZOrder[1],2); //вторая точка прямой xx2 := RounDX(TOrthoLine(ASnapFigure).JoinConnector2.ActualPoints[1].x,2); yy2 := RounDX(TOrthoLine(ASnapFigure).JoinConnector2.ActualPoints[1].y,2); zz2 := RounDX(TConnectorObject(TOrthoLine(ASnapFigure).JoinConnector2).ActualZOrder[1],2); // направляющий вектор для прямой (координаты) vx := xx2 - xx1; vy := yy2 - yy1; vz := zz2 - zz1; if (vx <> 0) then begin Result := Roundx(((CoordX - xx1)/vx)*vz + zz1, 2); end else begin if (vy <> 0) then Result := RoundX(((CoordY - yy1)/vy)*vz + zz1, 2); end; End; // // Tolik 08/06/2021 -- function CheckHasCadSelectedPoints: boolean; var i: integer; begin Result := False; if Assigned(GCadForm) then begin for i := 0 to GCadForm.FSCSFigures.Count - 1 do begin if CheckFigureByClassName(TFigure(GCadForm.FSCSFigures[i]), cTConnectorObject) then begin if TConnectorObject(GCadForm.FSCSFigures[i]).Selected then begin Result := True; break; end; end; end; end; end; // Procedure CheckCloseReportForm; // Toilk 30/04/2021 -- begin if Assigned(F_ProjMan) then if Assigned(F_ProjMan.F_ReportForm) then if (F_ProjMan.F_ReportForm.Visible or F_ProjMan.F_ReportForm.Showing) then F_ProjMan.F_ReportForm.Close; end; // Tolik 24/05/2021 -- Procedure DeleteConnectedToPointsCable; var i, j, k: integer; PointFigure: TFigure; PointCatalog, LineCatalog: TSCSCatalog; CatalogList: TList; PointCompon, JoinedCompon: TSCSComponent; CableIDList: TIntList; CableList: TSCSComponents; begin CatalogList := TList.Create; CableIdList := TIntList.Create; try for i := 0 to GCadForm.FSCSFigures.Count - 1 do begin if TFigure(GCadForm.FSCSFigures[i]).Selected then begin if CheckFigureByClassName(TFigure(GCadForm.FSCSFigures[i]), cTConnectorObject) then begin PointCatalog := F_ProjMan.GSCSBase.CurrProject.CurrList.GetCatalogFromReferencesBySCSID(TFigure(GCadForm.FSCSFigures[i]).ID); if PointCatalog <> nil then begin for j := 0 to PointCatalog.ComponentReferences.Count - 1 do begin PointCompon := PointCatalog.ComponentReferences[j]; for k := 0 to PointCompon.JoinedComponents.Count - 1 do begin JoinedCompon := PointCompon.JoinedComponents[k]; if isCableComponent(JoinedCompon) then begin if CableIDList.IndexOf(JoinedCompon.Whole_ID) = -1 then CableIdList.Add(JoinedCompon.Whole_ID); end; end; end; end; end; end; end; if CableIdList.Count > 0 then begin BeginProgress; for i := 0 to CableIdList.Count - 1 do begin CableList := F_ProjMan.GSCSBase.CurrProject.GetComponentsByWholeID(CableIdList[i]); //CableList := F_ProjMan.GSCSBase.CurrProject.CurrList.GetComponentsByWholeID(CableIdList[i]); if CableList.Count > 0 then F_ProjMan.DM.DelComponent(CableIDList[i], CableList[0], dmTrace, nil, CableList); end; end; finally EndProgress; end; CatalogList.Free; CableIdList.Free end; // Procedure DelCableByAllLengthFromSelected; // Tolik 25/05/2021 -- var i, j, k: integer; LineFigure: TFigure; LineCatalog: TSCSCatalog; CatalogList: TList; LineCompon: TSCSComponent; CableIDList: TIntList; CableList: TSCSComponents; WasProgress: Boolean; begin CatalogList := TList.Create; CableIdList := TIntList.Create; WasProgress := False; try for i := 0 to GCadForm.FSCSFigures.Count - 1 do begin if TFigure(GCadForm.FSCSFigures[i]).Selected then begin if CheckFigureByClassName(TFigure(GCadForm.FSCSFigures[i]), cTOrtholine) then begin LineCatalog := F_ProjMan.GSCSBase.CurrProject.CurrList.GetCatalogFromReferencesBySCSID(TFigure(GCadForm.FSCSFigures[i]).ID); if LineCatalog <> nil then begin for j := 0 to LineCatalog.ComponentReferences.Count - 1 do begin LineCompon := LineCatalog.ComponentReferences[j]; if isCableComponent(LineCompon) then begin if CableIDList.IndexOf(LineCompon.Whole_ID) = -1 then CableIdList.Add(LineCompon.Whole_ID); end; end; end; end; end; end; if CableIdList.Count > 0 then begin BeginProgress; WasProgress := True; for i := 0 to CableIdList.Count - 1 do begin CableList := F_ProjMan.GSCSBase.CurrProject.CurrList.GetComponentsByWholeID(CableIdList[i]); if CableList.Count > 0 then F_ProjMan.DM.DelComponent(CableIDList[i], CableList[0], dmTrace); end; end; finally if WasProgress then EndProgress; end; CatalogList.Free; CableIdList.Free end; //Tolik 26/05/2021 -- function GetListsByDeleteCable(aDelCableFromPoint: Boolean; aDelComponMode: TDelComponMode): TList; var i, j, k: integer; PointCatalog, LineCatalog: TSCSCatalog; PointCompon, JoinedCompon, Compon: TSCSComponent; CableIdList: TIntList; SCSList: TSCSList; NotPoint: Boolean; function AddComponList(aCompon: TSCSComponent; var aList: TList): Boolean; var ComponList: TSCSComponents; i: integer; Compon: TSCSComponent; SCSList: TSCSList; CadList: TF_CAD; begin Result := False; ComponList := F_ProjMan.GSCSBase.CurrProject.GetComponentsByWholeID(aCompon.Whole_ID); if ComponList <> nil then begin for i := 0 to ComponList.Count - 1 do begin Compon := ComponList[i]; SCSList := F_ProjMan.GSCSBase.CurrProject.GetListBySCSID(Compon.ListID); if SCSList <> nil then begin CadList := GetListById(SCSList.SCSID); if CadList <> nil then begin if aList.IndexOf(CadList) = -1 then begin aList.Add(CadList); if aList.Count = F_ProjMan.GSCSBase.CurrProject.ProjectLists.Count then begin result := True; ComponList.Free; exit; end; end; end; end; end; ComponList.Free; end; end; begin Result := TList.Create; Result.Add(GCadForm); if F_ProjMan.GSCSBase.CurrProject.ProjectLists.Count = 1 then exit; NotPoint := True; for i := 0 to GCadForm.FSCSFigures.Count - 1 do begin if TFigure(GCadForm.FSCSFigures[i]).Selected then begin if aDelCableFromPoint then begin if CheckFigureByClassName(TFigure(GCadForm.FSCSFigures[i]), cTConnectorObject) then begin NotPoint := False; PointCatalog := F_ProjMan.GSCSBase.CurrProject.CurrList.GetCatalogFromReferencesBySCSID(TFigure(GCadForm.FSCSFigures[i]).ID); if PointCatalog <> nil then begin for j := 0 to PointCatalog.ComponentReferences.Count - 1 do begin PointCompon := PointCatalog.ComponentReferences[j]; for k := 0 to PointCompon.JoinedComponents.Count - 1 do begin JoinedCompon := PointCompon.JoinedComponents[k]; if isCableComponent(JoinedCompon) then begin if AddComponList(JoinedCompon, Result) then exit; end; end; end; end; end else NotPoint := True; end; if aDelComponMode = DMTrace then begin if NotPoint then begin if CheckFigureByClassName(TFigure(GCadForm.FSCSFigures[i]), cTOrthoLine) then begin LineCatalog := F_ProjMan.GSCSBase.CurrProject.CurrList.GetCatalogFromReferencesBySCSID(TFigure(GCadForm.FSCSFigures[i]).ID); if LineCatalog <> nil then begin for j := 0 to LineCatalog.ComponentReferences.Count - 1 do begin Compon := LineCatalog.ComponentReferences[j]; if IsCableComponent(Compon) then begin if AddComponList(Compon, Result) then exit; end; end; end; end; end; end; end; end; end; // // Tolik 26/05/2021 -- function CheckAllCadFiguresSelected: Boolean; var i: integer; begin Result := True; for i := 0 to GCadForm.FSCSFigures.Count - 1 do begin if CheckFigureByClassName(TFigure(GCadForm.FSCSFigures[i]), cTConnectorObject) then begin if not TFigure(GCadForm.FSCSFigures[i]).selected then begin Result := False; exit; end; end else begin if CheckFigureByClassName(TFigure(GCadForm.FSCSFigures[i]), cTOrthoLine) then begin if not TOrthoLine(GCadForm.FSCSFigures[i]).Selected then begin if not TOrthoLine(GCadForm.FSCSFigures[i]).FisRaiseUpDown then begin Result := False; exit; end; end; end; end; end; end; function CheckNeedInputBox: boolean; var i: Integer; function DoesHaveFigureConnectedCable(aFigure: TFigure): Boolean; var i, j: Integer; FigCatalog: TSCSCatalog; ChildCompon: TSCSComponent; JoinedCompon: TSCSComponent; // Tolik 24/05/2021 -- begin Result := false; if CheckFigureByClassName(aFigure, cTOrthoLine) then begin FigCatalog := F_ProjMan.GSCSBase.CurrProject.CurrList.GetCatalogFromReferencesBySCSID(aFigure.ID); if FigCatalog <> nil then begin for i := 0 to FigCatalog.ComponentReferences.Count - 1 do begin ChildCompon := TSCSComponent(FigCatalog.ComponentReferences[i]); if IsCableComponent(ChildCompon) then begin childCompon.LoadWholeComponent(false); if ChildCompon.WholeComponent.Count > 1 then begin Result := True; break; end; end; end; end; end //Tolik 24/05/2021 -- else if CheckFigureByClassName(aFigure, cTConnectorObject) then begin FigCatalog := F_ProjMan.GSCSBase.CurrProject.CurrList.GetCatalogFromReferencesBySCSID(aFigure.ID); if FigCatalog <> nil then begin for i := 0 to FigCatalog.ComponentReferences.Count - 1 do begin ChildCompon := TSCSComponent(FigCatalog.ComponentReferences[i]); for j := 0 to ChildCompon.JoinedComponents.Count - 1 do begin JoinedCompon := ChildCompon.JoinedComponents[j]; if IsCableComponent(JoinedCompon) then begin Result := True; break; end; end; end; end; end // end; begin Result := False; if GCadForm <> nil then begin if GCadForm.PCad.Selection.Count > 0 then begin for i := 0 to GCadForm.PCad.Selection.Count - 1 do begin Result := DoesHaveFigureConnectedCable(TFigure(GCadForm.PCad.Selection[i])); if Result then break; end; end; end; end; // Tolik 20/05/2021 -- Procedure DeleteCableBySelFigures(aDelList: TList; aDelAllFromTrace, aDelFomPoint: Boolean); var i, j, k: integer; CableList: TSCSComponents; CatalogList: TList; SCSCompon: TSCSComponent; Figure: TFigure; SCSCatalog: TSCSCatalog; PointChildCompon: TSCSComponent; function CheckNoComponInList(aCompon:TSCSComponent): Boolean; var i: integer; begin Result := True; for i := 0 to CableList.Count - 1 do begin if CableList[i].Whole_ID = aCompon.Whole_ID then begin Result := False; break; end; end; end; begin if GCadForm <> nil then begin if aDelList.Count > 0 then begin CableList := TSCSComponents.Create(false); if aDelFomPoint then begin for i := 0 to aDelList.Count - 1 do begin Figure := TFigure(aDelList[i]); if CheckFigureByClassName(Figure, cTConnectorObject) then begin //PointCatalog SCSCatalog := F_ProjMan.GSCSBase.CurrProject.CurrList.GetCatalogFromReferencesBySCSID(Figure.ID); if SCSCatalog <> nil then begin for j := 0 to SCSCatalog.ComponentReferences.Count - 1 do begin // Joined Cables To Point Object PointChildCompon := SCSCatalog.ComponentReferences[j]; for k := 0 to PointChildCompon.JoinedComponents.Count - 1 do begin if isCableComponent(PointChildCompon.JoinedComponents[k]) then if CheckNoComponInList(PointChildCompon.JoinedComponents[k]) then CableList.Add(PointChildCompon.JoinedComponents[k]); end; end; end; end; end; end; end; end; end; // function CheckCanMovePointOnSnap(aObject, AConn: TConnectorObject): Boolean; var i: integer; PointHasLines: Boolean; begin {Result := false; if GCadForm.PCad.TraceFigure <> nil then if GCadForm.PCad.TraceFigure is TOrthoLine then exit;} if aObject.ConnectorType = ct_NB then begin if aConn.ConnectorType = ct_Clear then begin Result := True; //PointHasLines := False; if aObject.JoinedConnectorsList.Count > 0 then begin for i := 0 to aObject.JoinedConnectorsList.Count - 1 do begin if TConnectorObject(aObject.JoinedConnectorsList[i]).JoinedOrthoLinesList.Count > 0 then begin //PointHasLines := True; Result := False; exit; end; end; end; end; end; end; // Tolik 10/02/2021 -- Procedure DropDownNextToolbar; var i: integer; begin if FSCS_Main.tbCADToolsNoob2.Visible then begin for i := 0 to FSCS_Main.tbCADToolsNoob2.ButtonCount - 1 do TToolButton(FSCS_Main.tbCADToolsNoob2.Buttons[i]).Down := False; end; end; Procedure DropDownFirstToolbar; var i: integer; begin if FSCS_Main.tbCADToolsNoob.Visible then begin for i := 0 to FSCS_Main.tbCADToolsNoob.ButtonCount - 1 do TToolButton(FSCS_Main.tbCADToolsNoob.Buttons[i]).Down := False; end; end; // Tolik -- 13/09/2016 -- Constructor TCableWayCompon.Create; begin inherited; FirstCompon := nil; LastCompon := Nil; Npp := 0; Passed := False; CanSeekSide1 := True; CanSeekSide2 := True; CableInterfName := ''; CableInterface := nil; Side1ConnectedInterface := Nil; Side2ConnectedInterface := Nil; Side1InterfList := Nil; Side2InterfList := Nil; WayList := TList.Create; GroupedNpp := TIntList.Create; end; Destructor TCableWayCompon.Destroy; begin FirstCompon := nil; LastCompon := Nil; CableInterface := nil; Npp := 0; Passed := False; FreeAndNil(WayList); FreeAndNil(GroupedNpp); inherited; end; // Tolik -- 12/01/2017 -- function GetGdiMess(amess: string): string; begin Result := ''; if amess = 'GdiMess_1' then Result := GdiMess_1 else if amess = 'GdiMess_2' then Result := GdiMess_2; end; Function ListNotUnderFloor(aCad: TF_Cad): Boolean; var Catalog1, Catalog2: TSCSCatalog; begin Result := True; if GCadForm = nil then exit; Catalog1 := F_ProjMan.GSCSBase.CurrProject.GetCatalogFromReferencesBySCSID(GCadForm.FCADListID); Catalog2 := F_ProjMan.GSCSBase.CurrProject.GetCatalogFromReferencesBySCSID(aCad.FCADListID); if Catalog1 <> nil then if Catalog2 <> nil then begin //Tolik 26/09/2021 -- { if F_ProjMan.GSCSBase.CurrProject.Setting.ListsInReverseOrder then begin if Catalog2.SortId < Catalog1.SortId then Result := False; end else begin if Catalog2.SortId > Catalog1.SortId then Result := False; end; } if Catalog2.SortId < Catalog1.SortId then Result := False; // end; end; function Get3DFloorHeight(aCad: TF_CAD): Double; var currCad, NextCad, TempCad: TF_CAD; NextConn: TConnectorObject; i, CadIndex: Integer; updir: Boolean; ListParams: TListParams; begin Result := 0; currCad := aCad;//TF_CAD(TPowerCad(aConn.Owner).Owner); ListParams := GetListParams(currCad.FCADListID); //Tolik 29/09/2021 - - //Result := Result + MetreToUOM(ListParams.Settings.HeightRoom)*(1000 / currCad.PCad.MapScale); Result := Result + MetreToUom(ListParams.Settings.HeightRoom) * UOMToMetre(1000 / currCad.PCad.MapScale); // if HListOfCadsFor3DModel = nil then if LListOfCadsFor3DModel = nil then exit; if HListOfCadsFor3DModel <> nil then begin CadIndex := HListOfCadsFor3DModel.IndexOf(currCad); if CadIndex <> -1 then begin //if F_ProjMan.GSCSBase.CurrProject.Setting.ListsInReverseOrder then begin for i := 0 to HListOfCadsFor3DModel.Count - 1 do begin TempCad := TF_CAD(HListOfCadsFor3DModel[i]); if TempCad <> currCad then begin ListParams := GetListParams(TempCad.FCADListID); //Tolik 29/09/2021 -- //Result := Result + MetreToUOM(ListParams.Settings.HeightRoom)*(1000 / TempCad.PCad.MapScale); Result := Result + MetreToUom(ListParams.Settings.HeightRoom) * UOMToMetre(1000 / currCad.PCad.MapScale); // end else break; end; end; {else begin for i := HListOfCadsFor3DModel.Count - 1 downto 0 do begin TempCad := TF_CAD(HListOfCadsFor3DModel[i]); if TempCad <> currCad then begin ListParams := GetListParams(TempCad.FCADListID); Result := Result + MetreToUOM(ListParams.Settings.HeightRoom)*(1000 / TempCad.PCad.MapScale); end else break; end; end;} end; end; //end if CadIndex = -1 then begin Result := -Result; if LListOfCadsFor3DModel <> nil then begin if LListOfCadsFor3DModel.IndexOf(currCad) <> -1 then begin for i := 0 to LListOfCadsFor3DModel.Count - 1 do begin TempCad := TF_CAD(LListOfCadsFor3DModel[i]); if TempCad <> currCad then begin ListParams := GetListParams(TempCad.FCADListID); //Tolik 29/09/2021 - - //Result := Result + (MetreToUOM(ListParams.Settings.HeightRoom)*(1000 / TempCad.PCad.MapScale))*(-1); Result := Result + MetreToUom(ListParams.Settings.HeightRoom) * UOMToMetre(1000 / TempCad.PCad.MapScale) * (-1); // end else break; end; end; end; end; end; function GetTrunkZ(aConn: TConnectorObject; aZ: Double): Double; var currCad, NextCad, TempCad: TF_CAD; NextConn: TConnectorObject; i, CadIndex: Integer; updir: Boolean; ListParams: TListParams; begin Result := 0; NextConn := nil; NextCad := Nil; updir := False; NextCad := GetListByID(aConn.FID_ListToPassage); if NextCad <> nil then begin NextConn := TConnectorObject(GetFigureByID(NextCad, aConn.FID_ConnToPassage)); if NextConn <> nil then begin currCad := TF_CAD(TPowerCad(aConn.Owner).Owner); CadIndex := ListOfCadsFor3DModel.IndexOf(NextCad); for i := CadIndex downto 0 do begin TempCad := TF_CAD(ListOfCadsFor3DModel[i]); if TempCad <> currCad then begin ListParams := GetListParams(TempCad.FCADListID); Result := Result + MetreToUOM(ListParams.Settings.HeightRoom)*(1000 / currCad.PCad.MapScale); end else break; end; end; end; end; // function RoundN(Num: Extended; Dig: integer): Extended;//Extended; var Fakt: Extended; Vrem: Extended; pw: Extended; begin // SetPrecisionMode(pmExtended); // Set8087CW(Default8087CW); if false then begin if Dig < 5 then begin Num := Num * 1000000; Num := Trunc(Num)+0.0000000; // trunc returns Int64, so we must made extended Num := Num / 1000000; end; end; pw := Power(10, Dig); try // при ничтожно малых значениях типа 1Е+4000 возникает ошибка Fakt := Frac(Num); except Fakt := 0; end; Fakt := pw * Fakt; try // при ничтожно малых значениях типа 1Е+4000 возникает ошибка Vrem := Frac(Fakt); except Vrem := 0; end; Fakt := Int(Fakt); if (Vrem - 0.5) >= -epsilon then Fakt := Fakt + 1 else if (Vrem + 0.5) <= -epsilon then Fakt := Fakt - 1; try Result := Int(Num) + Fakt/pw; except Result := Int(Num); end; end; Function CheckAssignedPCAD(aPcad: TPCDrawing): Boolean; begin Result := false; if (aPcad.Owner <> nil) and (aPcad.Owner is TF_Cad) and( TF_Cad(aPcad.Owner).FCheckedFigures <> nil) then begin Result := True; end; end; // картинка на конектор function GetConnectorImg(aOT: TConnectorType): TFigureGrpMod; begin Result := nil; try Result := SCSEngine.GetConnectorImg(aOT); except on E: Exception do addExceptionToLogEx('U_Common.GetConnectorImg', E.Message); end; end; function GetOrthoLineImg(aOT: TOrthoLineType): TFigureGrpMod; begin Result := nil; try Result := SCSEngine.GetOrthoLineImg(aOT); except on E: Exception do addExceptionToLogEx('U_Common.GetOrthoLineImg', E.Message); end; end; // процедура для установки параметров нового CAD по умолчанию procedure SetDefaultPageParams; begin try //// задать параметры по умолчанию для CAD FSCS_Main.a100.Execute; // вид - 100% FSCS_Main.apsSolid.Execute; // Стиль линии - сплошная FSCS_Main.aPenw1.Execute; // Ширина линии - 1 FSCS_Main.arsNone.Execute; // Стиль стрелки - нет FSCS_Main.absClear.Execute; // Стиль заливки - очистка FSCS_Main.aDEFAULT_CHARSET.Execute; // Набор символов - DEFAULT FSCS_Main.aTextFont.Execute; // Шрифт - MS Sans Serif FSCS_Main.aTextSize.Execute; // Размер шрифта - 8 FSCS_Main.aLineGrid.Execute; // Тип сетки - линейная FSCS_Main.aAngularNone.Execute; // Направляющие под углом - нет // FSCS_Main.aMetric.Execute; // Система линейки - метровая FSCS_Main.aWorldMode.Execute; // Режим линейки - реальная FSCS_Main.aSetDefaultColors.Execute; // Установка цвета для: // Цвет линии - черный // Цвет заливки - черный // Цвет текста - черный // Цвет сетки - серый // Цвет направляющих - зеленый // Цвет фона - серый // Цвет листа - белый // Tolik 29/06/2017 -- FSCS_Main.SetSefaultAllowTransparensy.Execute; // по умолчанию прозрачность поддеоживается // except on E: Exception do addExceptionToLogEx('U_Common.SetDefaultPageParams', E.Message); end; end; Procedure ReturnListParams; var SavedProjectChanged: Boolean; begin SavedProjectChanged := GProjectChanged; try FSCS_Main.aA0.Checked := False; FSCS_Main.aA1.Checked := False; FSCS_Main.aA2.Checked := False; FSCS_Main.aA3.Checked := False; FSCS_Main.aA4.Checked := False; FSCS_Main.aA5.Checked := False; FSCS_Main.aA6.Checked := False; FSCS_Main.aB4.Checked := False; FSCS_Main.aB5.Checked := False; FSCS_Main.aTabloid.Checked := False; FSCS_Main.aLetter.Checked := False; FSCS_Main.aCustom.Checked := False; FSCS_Main.aPortrait.Checked := False; FSCS_Main.aLandscape.Checked := False; // Размер страницы if GCadForm.PCad.PageLayout = plA0 then FSCS_Main.aA0.Checked := True; if GCadForm.PCad.PageLayout = plA1 then FSCS_Main.aA1.Checked := True; if GCadForm.PCad.PageLayout = plA2 then FSCS_Main.aA2.Checked := True; if GCadForm.PCad.PageLayout = plA3 then FSCS_Main.aA3.Checked := True; if GCadForm.PCad.PageLayout = plA4 then FSCS_Main.aA4.Checked := True; if GCadForm.PCad.PageLayout = plA5 then FSCS_Main.aA5.Checked := True; if GCadForm.PCad.PageLayout = plA6 then FSCS_Main.aA6.Checked := True; if GCadForm.PCad.PageLayout = plB4 then FSCS_Main.aB4.Checked := True; if GCadForm.PCad.PageLayout = plB5 then FSCS_Main.aB5.Checked := True; if GCadForm.PCad.PageLayout = plTabloid then FSCS_Main.aTabloid.Checked := True; if GCadForm.PCad.PageLayout = plLetter then FSCS_Main.aLetter.Checked := True; if GCadForm.PCad.PageLayout = plCustom then FSCS_Main.aCustom.Checked := True; // Ориентация страницы if GCadForm.PCad.PageOrient = PCTypesUtils.poPortrait then FSCS_Main.aPortrait.Checked := True; if GCadForm.PCad.PageOrient = PCTypesUtils.poLandscape then FSCS_Main.aLandscape.Checked := True; if FSCS_Main.ActiveMDIChild <> nil then begin // Система линейки if GCadForm.PCad.RulerSystem = rsMetric then FSCS_Main.aMetric.Execute; if GCadForm.PCad.RulerSystem = rsWhitworth then FSCS_Main.aWitworth.Execute; // Режим линейки if GCadForm.PCad.RulerMode = rmPage then FSCS_Main.aPageMode.Execute; if GCadForm.PCad.RulerMode = rmWorld then FSCS_Main.aWorldMode.Execute; // Тип сетки if GCadForm.PCad.GridType = grtLine then FSCS_Main.aLineGrid.Execute; if GCadForm.PCad.GridType = grtCross then FSCS_Main.aCrossGrid.Execute; if GCadForm.PCad.GridType = grtPoint then FSCS_Main.aPointGrid.Execute; // Направляющие под углом if GCadForm.PCad.GuideTrace = gtNone then FSCS_Main.aAngularNone.Execute; if GCadForm.PCad.GuideTrace = gtThirty then FSCS_Main.aAngular30.Execute; if GCadForm.PCad.GuideTrace = gtFortyfive then FSCS_Main.aAngular45.Execute; if GCadForm.PCad.GuideTrace = gtSixty then FSCS_Main.aAngular60.Execute; if GCadForm.PCad.GuideTrace = gtNinty then FSCS_Main.aAngular90.Execute; end; // Переподнять флаги // показывать линейки FSCS_Main.aShowRuler.Checked := GCadForm.PCad.RulerVisible; GCadForm.tbShowRuler.Down := GCadForm.PCad.RulerVisible; // показывать сетку FSCS_Main.aShowGrid.Checked := GCadForm.PCad.Grids; GCadForm.tbShowGrid.Down := GCadForm.PCad.Grids; // показывать центр. направляющие FSCS_Main.aShowCenterGuides.Checked := GCadForm.PCad.CenterGuide; // показывать направляющие FSCS_Main.aShowGuideLines.Checked := GCadForm.PCad.GuidesVisible; GCadForm.tbShowGuides.Down := GCadForm.PCad.GuidesVisible; // привязка к сетке FSCS_Main.aSnaptoGrid.Checked := GCadForm.PCad.SnapToGrids; GCadForm.tbSnapGrid.Down := GCadForm.PCad.SnapToGrids; GCadForm.LastSnapGridStatus := GCadForm.PCad.SnapToGrids; // привязка к направляющим FSCS_Main.aSnaptoGuides.Checked := GCadForm.PCad.SnapToGuides; GCadForm.tbSnapGuides.Down := GCadForm.PCad.SnapToGuides; // привязка к ближ. объекту FSCS_Main.aSnaptoNearObject.Checked := GCadForm.PCad.SnapToNearPoint; GCadForm.tbSnapNearObject.Down := GCadForm.PCad.SnapToNearPoint; // Переподнять флаги !!! FSCS_Main.aAutoSelectTrace.Checked := GCadForm.FAutoSelectTrace; // GCadForm.tbAutoSelectTrace.Down := GCadForm.FAutoSelectTrace; FSCS_Main.aShowTracesLengthLimit.Checked := GCadForm.FShowTracesLengthLimit; GCadForm.tbShowTracesLengthLimit.Down := GCadForm.FShowTracesLengthLimit; FSCS_Main.aShowConnFullness.Checked := GCadForm.FShowConnFullness; GCadForm.tbShowConnFullness.Down := GCadForm.FShowConnFullness; FSCS_Main.aShowCableFullness.Checked := GCadForm.FShowCableFullness; GCadForm.tbShowCableFullness.Down := GCadForm.FShowCableFullness; FSCS_Main.aShowCableChannelFullness.Checked := GCadForm.FShowCableChannelFullness; GCadForm.tbShowCableChannelFullness.Down := GCadForm.FShowCableChannelFullness; FSCS_Main.aNoMoveConnectedObjects.Checked := GCadForm.FNoMoveConnectedObjects; GCadForm.tbNoMoveConnectedObjects.Down := GCadForm.FNoMoveConnectedObjects; except on E: Exception do addExceptionToLogEx('U_Common.ReturnListParams', E.Message); end; GProjectChanged := SavedProjectChanged; end; Function GetComponentFromNormBase(X, Y: Double; NB_Component: TSCSComponent; ASnapFigure: TFigure; CompStateType: TCompStateType): TFigure; var PointObject: TConnectorObject; ClearObject1: TConnectorObject; ClearObject2: TConnectorObject; LineObject: TOrthoLine; LineLength: Double; PropCount: integer; LHandle: integer; Prop: PProperty; GetCoords: TDoublePoint; Z: Double; //Tolik vx, vy, vz, xx1, xx2, yy1, yy2, zz1, zz2, TempZ : Double; SprComponentType: TNBComponentType; SCSCompon: TSCSComponent; //Prop: PProperty; GuidSTR: String; Compon_ID: integer; begin Result := nil; SCSCompon := nil; // Tolik 03/05/2022 -- try //29.06.2010 GCadForm.CurrentLayer := 2; GCadForm.CurrentLayer := GetCADLayerNumByComponIsLine(NB_Component.IsLine); LHandle := GCadForm.PCad.GetLayerHandle(GCadForm.PCad.ActiveLayer); Result := nil; if NB_Component <> Nil then begin //Tolik 03/05/2022 -- если прописана замена компонента на шаблоне if NB_Component.isTemplate = biTrue then begin SCSCompon := NB_Component; SCSCompon.LoadComponentByFi([fiIsLine, fiIDProducer, fiIDNetType, fiIDNormBase, fiObjectID]); GuidSTR := ''; SCSCompon.LoadProperties; Prop := SCSCompon.GetPropertyBySysName(pnGUID_NB_EXCHANGE); if Prop <> nil then begin if Prop.Value <> '' then GuidSTR := Prop.Value; end; if GuidSTR <> '' then begin Compon_ID := F_NormBase.DM.GetIntFromTable(tnComponent, fnID, fnGUID, GuidStr, qmPhisical); if Compon_ID <> -1 then begin SCSCompon.ID := Compon_ID; SCSCompon.LoadComponentByFi([fiIsLine, fiIDProducer, fiIDNetType, fiIDNormBase, fiObjectID]); end else SCSCompon := nil; end else SCSCompon := nil; if SCSCompon <> nil then begin NB_Component := SCSCompon; NB_Component.LoadProperties; end; Prop := nil; end; // // если точечный обьект (коннектор) if NB_Component.IsLine = 0 then begin if CheckFigureByClassName(ASnapFigure, cTConnectorObject) and (TConnectorObject(ASnapFigure).ConnectorType <> ct_Clear) then begin Result := nil; end else begin GCurrentConnectorType := ct_NB; if (ASnapFigure <> nil) and CheckFigureByClassName(ASnapFigure, cTConnectorObject) then begin X := TConnectorObject(ASnapFigure).ActualPoints[1].x; Y := TConnectorObject(ASnapFigure).ActualPoints[1].y; end else if ASnapFigure = Nil then begin //if GCadForm.PCad.SnapToGrids then // привязка к направляющим if (GCadForm.PCad.SnapToGuides)or(GCadForm.PCad.SnapToGrids) then begin GetCoords := GetCoordsWithSnapToGrid(X, Y); X := GetCoords.x; Y := GetCoords.y; end; end; //Tolik // if Z = 0 then // Z := GCadForm.FConnHeight; Z := 0; TempZ := 0; if NB_Component.GetPropertyBySysName(pnHeightOfPlacing) <> nil then Z := NB_Component.GetPropertyValueAsFloat(pnHeightOfPlacing); // высота размещения не задана if NB_Component.GetPropertyBySysName(pnHeightOfPlacing) = nil then begin // автоприменение высот включено if F_ProjMan.GSCSBase.CurrProject.CurrList.Setting.UseComponTypeHeights then begin SprComponentType := nil; SprComponentType := F_ProjMan.GSCSBase.CurrProject.CurrList.Spravochnik.GetComponentTypeByGUID(NB_Component.GUIDComponentType); if SprComponentType <> nil then begin // если задана высота размещения объектов данного типа, то берем высоту там if SprComponentType.ComponentType.CoordZ <> -1 then begin Z := SprComponentType.ComponentType.CoordZ; end else // если не задана высота размещения объектов данного типа, то размещаем на высоте точечных по листу begin Z := GCadForm.FConnHeight; end; end; TempZ := 0; end // автоприменение высот выключено else begin // на пустое место if ASnapFigure = nil then begin z:= 0; end else begin // на линию if ASnapFigure.ClassName = 'TOrthoLine' then begin // если линия не наклонная (высоты начала и конца сходятся) if TConnectorObject(TOrthoLine(ASnapFigure).JoinConnector1).ActualzOrder[1] = TConnectorObject(TOrthoLine(ASnapFigure).JoinConnector2).ActualzOrder[1] then begin Z := Tortholine(ASnapFigure).ActualZOrder[1]; end else // линия наклонная, вычисляем высоту begin Z := GetCoordZ(ASnapFigure, X, Y); end; end; // на коннектор if ASnapFigure.ClassName = 'TConnectorObject' then begin Z := TConnectorObject(ASnapFigure).ActualZOrder[1]; end; TempZ := 999; end; end; end; // высота размещения задана if NB_Component.GetPropertyBySysName(pnHeightOfPlacing) <> nil then begin if z = 999 then begin // на пустое место if ASnapFigure = nil then begin // на высоту линейных по листу Z := GCadForm.FLineHeight; end else begin // на линию if ASnapFigure.ClassName = 'TOrthoLine' then begin // если линия не наклонная (высоты начала и конца сходятся) if TConnectorObject(TOrthoLine(ASnapFigure).JoinConnector1).ActualzOrder[1] = TConnectorObject(TOrthoLine(ASnapFigure).JoinConnector2).ActualzOrder[1] then begin Z := Tortholine(ASnapFigure).ActualZOrder[1]; end else // линия наклонная, вычисляем высоту begin Z := GetCoordZ(ASnapFigure, X, Y); end; end; // на коннектор if ASnapFigure.ClassName = 'TConnectorObject' then begin Z := TConnectorObject(ASnapFigure).ActualZOrder[1]; end; end; TempZ := 999; end else TempZ := 0; end; PointObject := TConnectorObject.Create(X, Y, Z, LHandle, mydsNormal, GCadForm.PCad); //Tolik // если Z = 999 или не задана высота размещения - нужно будет посадить объект на трассу, // не создавая спуска-подъема, потому заюзаем свойство радиуса, для передачи параметра чтобы дяльше его "увидеть" if TempZ = 999 then PointObject.Radius := 999 + 11000000; if ASnapFigure <> nil then begin if ASnapFigure.ClassName = 'TOrthoLine' then begin if TOrthoLine(ASnapFigure).ActualZOrder[1] <> TOrthoLine(ASnapFigure).ActualZOrder[2] then { PointObject.Urc := -1;} end; end; PointObject.ConnectorType := GCurrentConnectorType; GCadForm.PCad.AddCustomFigure (GLN(LHandle), PointObject, False); Result := TFigure(PointObject); end; end else // если линейный обьект (ортолиния) if NB_Component.IsLine = 1 then //29.06.2010 if NB_Component.IsLine <> 0 then begin // НЕ создавать линию так как она вливаеться в трассу!!! end; end; except on E: Exception do addExceptionToLogEx('U_Common.GetComponentFromNormBase', E.Message); end; end; Function FindAutoSnapObject(X, Y: Double; NB_Component: TSCSComponent): TFigure; var FindFigure: TFigure; RaiseConn: TConnectorObject; begin Result := Nil; try //07.06.2010 GCadForm.CurrentLayer := 2; if GCadForm.CurrentLayer <> 2 then // Tolik 20/09/2021 -- GCadForm.CurrentLayer := GetCADLayerNumByComponIsLine(NB_Component.IsLine); //Result := Nil; // тянеться конектор if NB_Component.IsLine = 0 then begin try FindFigure := CheckBySCSObjects(X, Y); except FindFigure := nil; end; if FindFigure <> Nil then begin if CheckFigureByClassName(FindFigure, cTConnectorObject) then begin // Check FindFigure On Connector if (TConnectorObject(FindFigure).ConnectorType = ct_Clear) and (TConnectorObject(FindFigure).JoinedConnectorsList.Count > 0) then Result := nil else Result := FindFigure; if (TConnectorObject(FindFigure).FConnRaiseType = crt_BetweenFloorUp) or (TConnectorObject(FindFigure).FConnRaiseType = crt_BetweenFloorDown) or (TConnectorObject(FindFigure).FConnRaiseType = crt_TrunkUp) or (TConnectorObject(FindFigure).FConnRaiseType = crt_TrunkDown) then Result := Nil; if not GCadForm.FShowRaise then if TConnectorObject(FindFigure).FConnRaiseType = crt_OnFloor then Result := Nil; end else if CheckFigureByClassName(FindFigure, cTOrthoLine) then begin if not TOrthoLine(FindFigure).FIsRaiseUpDown then begin if not TOrthoLine(FindFigure).FConnectingLine then Result := FindFigure else Result := Nil; end else Result := Nil; end; end; end; // тянеться ортолиния if NB_Component.IsLine = 1 then begin try FindFigure := CheckBySCSObjects(X, Y); except FindFigure := nil; end; if FindFigure <> Nil then begin if CheckFigureByClassName(FindFigure, cTOrthoLine) then begin if GCadForm.FPutCableOnTrace then Result := FindFigure else Result := nil; end else if CheckFigureByClassName(FindFigure, cTConnectorObject) then begin if (TConnectorObject(FindFigure).ConnectorType = ct_Clear) and (TConnectorObject(FindFigure).JoinedConnectorsList.Count > 0) then Result := nil else Result := FindFigure; end; end; end; except on E: Exception do addExceptionToLogEx('U_Common.FindAutoSnapObject', E.Message); end; end; // УСТАНОВКА НОВОГО ИМЕНИ ОБЬЕКТА В CAD-e Procedure SetNewObjectNameInCad(AID_List, AID_Figure: Integer; AOldObjName, ANewObjName: String); var i: integer; vList: TF_CAD; CadFigure: TFigure; SavedCadForm: TF_CAD; begin try vList := GetListByID(AID_List); if vList <> nil then begin CadFigure := GetFigureByID(vList, AID_Figure); if CadFigure <> nil then begin CadFigure.Name := ANewObjName; if CheckFigureByClassName(CadFigure, cTConnectorObject) then begin if not TConnectorObject(CadFigure).FIsNameChanged then begin SavedCadForm := GCadForm; GCadForm := vList; SetConnNameInCaptionOnCAD(TConnectorObject(CadFigure)); GCadForm := SavedCadForm; end; RefreshCAD(vList.PCad); end; end; end; except on E: Exception do addExceptionToLogEx('U_Common.SetNewObjectNameInCad', E.Message); end; end; // УДАЛИТЬ ОБЬЕКТ ИЗ CAD (ПРИ УДАЛЕНИИ ЕГО ИЗ МП) // Tolik -- 22/11/2016 -- старая закомменчена -- ниже (пиздец) Procedure DeleteObjectFromCad(AID_List, AID_Figure: Integer; AObjName: String); var FList: TF_CAD; i: integer; DelFigure: TFigure; SCSFigureGrp: TSCSFigureGrp; SavedCadList: TF_CAD; begin try FList := GetListByID(AID_List); if FList <> nil then begin DelFigure := GetFigureByID(FList, AID_Figure); // на КАДе if DelFigure <> nil then begin SavedCadList := GCadForm; GCadForm := FList; GDeletedFromPMFigure := DelFigure; if CheckFigureByClassName(DelFigure, cTConnectorObject) then begin if TConnectorObject(DelFigure).FGroupObject = nil then TConnectorObject(DelFigure).Delete(True) else begin SCSFigureGrp := TConnectorObject(DelFigure).FGroupObject; DeleteObjectFromSCSFigureGrp(SCSFigureGrp, DelFigure); end; end else if CheckFigureByClassName(DelFigure, cTOrthoLine) then begin if TOrthoLine(delFigure).FGroupObject = nil then TOrthoLine(DelFigure).Delete else begin SCSFigureGrp := TOrthoLine(DelFigure).FGroupObject; DeleteObjectFromSCSFigureGrp(SCSFigureGrp, DelFigure); end; end else if CheckFigureByClassName(DelFigure, cTHouse) then begin THouse(DelFigure).Delete end else if CheckFigureByClassName(DelFigure, cTCabinet) then begin TCabinet(DelFigure).Delete end else if CheckFigureByClassName(DelFigure, cTCabinetExt) then TCabinetExt(DelFigure).Delete; GDeletedFromPMFigure := Nil; RefreshCAD(FList.PCad); GCadForm := SavedCadList; end; end; except on E: Exception do addExceptionToLogEx('U_Common.DeleteObjectFromCad', E.Message); end; end; { Procedure DeleteObjectFromCad(AID_List, AID_Figure: Integer; AObjName: String); var FList: TF_CAD; i: integer; DelFigure: TFigure; SCSFigureGrp: TSCSFigureGrp; SavedCadList: TF_CAD; begin try FList := GetListByID(AID_List); if FList <> nil then begin DelFigure := GetFigureByID(FList, AID_Figure); // на КАДе if DelFigure <> nil then begin SavedCadList := GCadForm; GCadForm := FList; GDeletedFromPMFigure := DelFigure; if CheckFigureByClassName(DelFigure, cTConnectorObject) then TConnectorObject(DelFigure).Delete(True) else if CheckFigureByClassName(DelFigure, cTOrthoLine) then TOrthoLine(DelFigure).Delete else if CheckFigureByClassName(DelFigure, cTHouse) then THouse(DelFigure).Delete else if CheckFigureByClassName(DelFigure, cTCabinet) then TCabinet(DelFigure).Delete else if CheckFigureByClassName(DelFigure, cTCabinetExt) then TCabinetExt(DelFigure).Delete; GDeletedFromPMFigure := Nil; RefreshCAD(FList.PCad); GCadForm := SavedCadList; end else // в группе begin SCSFigureGrp := GetSCSFigureGrp(FList, AID_Figure); if SCSFigureGrp <> nil then begin DelFigure := GetFigureByIDInSCSFigureGrp(SCSFigureGrp, AID_Figure); if DelFigure <> nil then begin SavedCadList := GCadForm; GCadForm := FList; GDeletedFromPMFigure := DelFigure; DeleteObjectFromSCSFigureGrp(SCSFigureGrp, DelFigure); GCadForm := SavedCadList; end end; end; end; except on E: Exception do addExceptionToLogEx('U_Common.DeleteObjectFromCad', E.Message); end; end; } // Tolik -- 30/11/2016-- немножко переписано, на всякий, чтоб не ебнулось, а // старая закомменчена - смотри ниже Procedure DeleteObjectFromSCSFigureGrp(ASCSFigureGrp: TSCSFigureGrp; AObjects: TFigure); var i: integer; GrpList: TList; begin try // разгруппировать, чтобы удалить GrpList := TList.Create; for i := 0 to ASCSFigureGrp.InFigures.Count - 1 do GrpList.Add(TFigure(ASCSFigureGrp.InFigures[i])); ASCSFigureGrp.UnGroup; GCadForm.PCad.Figures.Remove(ASCSFigureGrp); // Tolik -- а то непонятно совсем, куда она делась ...вроде как претензия на утечку памяти ASCSFigureGrp.InFigures.Clear; ASCSFigureGrp.Free; // RefreshCAD(GCadForm.PCad); // // а тут выкинем сразу из списка записанных фигур ту, которую удалим, чтобы не получить АВ // на формировании новой группы, т.к. обновление Када удаленные фигуры чпокнет, а далее -- как повезет... if CheckFigureByClassName(AObjects, cTConnectorObject) then begin GrpList.Remove(aObjects); TConnectorObject(AObjects).Delete(True) end else if CheckFigureByClassName(AObjects, cTOrthoLine) then begin GrpList.Remove(aObjects); TOrthoLine(AObjects).Delete; end; // GDeletedFromPMFigure := Nil; RefreshCAD(GCadForm.PCad); // сгруппировать назад SCSGroupObjects(GrpList); FreeAndNil(GrpList); except on E: Exception do addExceptionToLogEx('U_Common.DeleteObjectFromSCSFigureGrp', E.Message); end; end; { Procedure DeleteObjectFromSCSFigureGrp(ASCSFigureGrp: TSCSFigureGrp; AObjects: TFigure); var i: integer; GrpList: TList; begin try // разгруппировать, чтобы удалить GrpList := TList.Create; for i := 0 to ASCSFigureGrp.InFigures.Count - 1 do GrpList.Add(TFigure(ASCSFigureGrp.InFigures[i])); ASCSFigureGrp.UnGroup; GCadForm.PCad.Figures.Remove(ASCSFigureGrp); RefreshCAD(GCadForm.PCad); // if CheckFigureByClassName(AObjects, cTConnectorObject) then TConnectorObject(AObjects).Delete(True) else if CheckFigureByClassName(AObjects, cTOrthoLine) then TOrthoLine(AObjects).Delete; GDeletedFromPMFigure := Nil; RefreshCAD(GCadForm.PCad); // сгруппировать назад SCSGroupObjects(GrpList); FreeAndNil(GrpList); except on E: Exception do addExceptionToLogEx('U_Common.DeleteObjectFromSCSFigureGrp', E.Message); end; end; } // ОТКРЫТЫЙ ОБЬЕКТ В МП ВЫДЕЛИТЬ НА CAD-е Procedure SelectObjectInCAD(AID_List, AID_Figure: Integer; AObjName: String); var i: integer; LHandle: Integer; ActLayer: Integer; vList: TF_CAD; CADFigure: TFigure; begin try vList := GetListByID(AID_List); if vList <> nil then begin vList.PCad.DeselectAll(0); CADFigure := GetFigureByID(vList, AID_Figure); if CADFigure <> nil then begin if (not CADFigure.LockSelect) and (vList.PCad.ActiveLayer = 2) then begin GCanRefreshProperties := True; if vList.CurrentLayer <> 2 then vList.CurrentLayer := 2; CADFigure.Select; RefreshCAD(vList.PCad); vList.SetZoomScale(vList.PCad.ZoomScale + 0); RefreshCAD(vList.PCad); //GetSCSComponByCADObj(CADFigure); end; end; end; except on E: Exception do addExceptionToLogEx('U_Common.SelectObjectInCAD', E.Message); end; end; procedure FigureBringToFront(AFigure: TFigure); var CurrIndex: integer; begin if (AFigure.Owner <> nil) and (AFigure.Owner is TPCDrawing) then begin CurrIndex := TPCDrawing(AFigure.Owner).Figures.IndexOf(AFigure); if CurrIndex <> -1 then TPCDrawing(AFigure.Owner).Figures.Move(CurrIndex, TPCDrawing(AFigure.Owner).Figures.Count-1); end; end; procedure FigureSendToBack(AFigure: TFigure); var CurrIndex: integer; begin if (AFigure.Owner <> nil) and (AFigure.Owner is TPCDrawing) then begin CurrIndex := TPCDrawing(AFigure.Owner).Figures.IndexOf(AFigure); if CurrIndex <> -1 then TPCDrawing(AFigure.Owner).Figures.Move(CurrIndex, 0); end; end; procedure SetConnObjectSelectHightPriority(AFigure: TConnectorObject); begin if AFigure.FBlockGUID = '' then FigureBringToFront(AFigure); end; Procedure SelectHouseInCAD(AID_List, AID_Figure: Integer); var i: integer; LHandle: Integer; ActLayer: Integer; vList: TF_CAD; House: TFigure; begin try vList := GetListByID(AID_List); if vList <> nil then begin vList.PCad.DeselectAll(0); House := GetHouseByID(vList, AID_Figure); if House <> nil then begin if (not House.LockSelect) and (vList.PCad.ActiveLayer = 2) then begin GCanRefreshProperties := True; if vList.CurrentLayer <> 2 then vList.CurrentLayer := 2; House.Select; RefreshCAD(vList.PCad); vList.SetZoomScale(vList.PCad.ZoomScale + 0); RefreshCAD(vList.PCad); end; end; end; except on E: Exception do AddExceptionToLogEx('U_Common.SelectHouseInCAD', E.Message); end; end; Procedure SelectApproachInCAD(aListID, aHouseID, AComponID: Integer); var i: integer; LHandle: Integer; ActLayer: Integer; vList: TF_CAD; House: THouse; Approach: TConnectorObject; begin try vList := GetListByID(aListID); if vList <> nil then begin vList.PCad.DeselectAll(0); Approach := GetApproachByComponID(vList, AComponID); if Approach <> nil then begin if (not Approach.LockSelect) and (vList.PCad.ActiveLayer = 2) then begin GCanRefreshProperties := True; if vList.CurrentLayer <> 2 then vList.CurrentLayer := 2; Approach.Select; RefreshCAD(vList.PCad); vList.SetZoomScale(vList.PCad.ZoomScale + 0); RefreshCAD(vList.PCad); end; end; end; except on E: Exception do AddExceptionToLogEx('U_Common.SelectApproachInCAD', E.Message); end; end; // ПРИ ПЕРЕКЛЮЧЕНИИ ЛИСТА В МП ПЕРЕКЛЮЧИТЬ ЕГО НА CAD-е Procedure SwitchListInCAD(AID_List: Integer; const ListName: String); var i: integer; OldList: TF_CAD; OldListAutoRefresh: Boolean; vList: TF_CAD; vListAutoRefresh: Boolean; begin try vList := GetListByID(AID_List); if vList <> nil then begin OldList := nil; if GCadForm <> vList then OldList := GCadForm; //vList.DisableAlign; //vList.PCad.DisableAlign; vListAutoRefresh := vList.PCad.AutoRefresh; vList.PCad.AutoRefresh := false; vList.PCad.Locked := true; vList.PCad.BeginUpdate; if OldList <> nil then begin OldList.PCad.BeginUpdate; OldListAutoRefresh := OldList.PCad.AutoRefresh; OldList.PCad.AutoRefresh := false; OldList.PCad.Locked := true; end; try vList.BringToFront; finally //vList.PCad.EnableAlign; vList.PCad.Locked := false; vList.PCad.AutoRefresh := vListAutoRefresh; //vList.EnableAlign; vList.PCad.EndUpdate; if OldList <> nil then begin OldList.PCad.Locked := false; OldList.PCad.EndUpdate(false); OldList.PCad.AutoRefresh := OldListAutoRefresh; end; if ((GCadForm = nil) or ((OldList <> nil) and (VList <> OldList))) then // Tolik 02/02/2022 -- vList.OnResize(vList); end; if vList.WindowState <> wsMaximized then vList.WindowState := wsMaximized; //vList.PCad.ResetRegions; end; except on E: Exception do addExceptionToLogEx('U_Common.SwitchListInCAD', E.Message); end; end; // ПРИ ПЕРЕИМЕНОВАНИИ ЛИСТА В МП ПЕРЕИМЕНОВАТЬ ЕГО НА CAD-е Procedure RenameListInCAD(AID_List: Integer; const OldListName, NewListName: String; AOldListParams: PListParams; ARenameOnFrame: Boolean=true); var i, j: integer; GetTag: integer; vList: TF_CAD; // 2011-05-10 fullname: string; begin try vList := GetListByID(AID_List); if vList <> nil then begin // изменить название самого листа // 2011-05-10 fullname := NewListName; //02.04.2013 AOldListParams^.Name + ' ' + IntToStr(AOldListParams^.MarkID); vList.FCADListName := NewListName; //02.04.2013 AOldListParams^.Name;//NewListName; vList.Caption := fullname; GetTag := vList.Tag; // изменить название в переключателе листов for j := 0 to FSCS_Main.pageCADList.PageCount - 1 do begin if FSCS_Main.pageCADList.Pages[j].Tag = GetTag then begin // 2011-05-10 FSCS_Main.pageCADList.Pages[j].Caption := fullname; break; end; end; // изменить название в меню листов for j := 0 to FSCS_Main.mainWindow.Count - 1 do begin if FSCS_Main.mainWindow.Items[j].Tag = GetTag then begin // 2011-05-10 FSCS_Main.mainWindow.Items[j].Caption := fullname; break; end; end; // RenameListOnFrame(vList); // 2011-05-10 if ARenameOnFrame and Assigned(AOldListParams) then RenameListOnFrame(vList, GetCurrProjectParams(false), AOldListParams^); end; except on E: Exception do addExceptionToLogEx('U_Common.RenameListInCAD', E.Message); end; end; // ПРИ УДАЛЕНИИ ЛИСТА В МП УДАЛИТЬ ЕГО НА CAD-е Procedure DeleteListInCAD(AID_List: Integer; ListName: String); var i: integer; BoxID: Integer; BoxListID: Integer; BoxObject: TConnectorObject; BoxListObject: TF_CAD; vList: TF_CAD; begin try vList := GetListByID(AID_List); if vList <> nil then begin if vList.FListType = lt_DesignBox then begin BoxID := vList.FJoinedBoxIDForDesignList; BoxListID := vList.FJoinedListIDForDesignList; BoxListObject := GetListByID(BoxListID); BoxObject := TConnectorObject(GetFigureByID(BoxListObject, BoxID)); if BoxObject <> nil then BoxObject.FJoinedListIDForBox := -1; end; GCurrentCADListID := AID_List; vList.FNeedDelete := True; GNotNeedCheckRaisesBeforeClose := True; vList.Close; GNotNeedCheckRaisesBeforeClose := False; vList.FNeedDelete := False; GCurrentCADListID := 0; end; except on E: Exception do addExceptionToLogEx('U_Common.DeleteListInCAD', E.Message); end; end; Procedure FindConnectionsInterfaces(AConnector1, AConnector2: TConnectorObject); var i: integer; isConnected: Boolean; ptrInterfRecord1, ptrInterfRecord2: PConnectObjectParam; ParamsList1, ParamsList2: TList; JoinedConn: TConnectorObject; JoinedLine: TOrthoLine; begin try ParamsList1 := TList.create; ParamsList2 := TList.create; // 1 соединитель for i := 0 to AConnector1.JoinedOrtholinesList.Count - 1 do begin JoinedLine := TOrthoLine(AConnector1.JoinedOrtholinesList[i]); New(ptrInterfRecord1); ptrInterfRecord1.IDObject := JoinedLine.ID; if AConnector1 = JoinedLine.JoinConnector1 then ptrInterfRecord1.Side := 1; if AConnector1 = JoinedLine.JoinConnector2 then ptrInterfRecord1.Side := 2; ParamsList1.Add(ptrInterfRecord1); end; // два соединителя - соединения их кабелей if (AConnector1.ConnectorType = ct_Clear) and (AConnector2.ConnectorType = ct_Clear) then begin for i := 0 to AConnector2.JoinedOrtholinesList.Count - 1 do begin JoinedLine := TOrthoLine(AConnector2.JoinedOrtholinesList[i]); New(ptrInterfRecord2); ptrInterfRecord2.IDObject := JoinedLine.ID; if AConnector2 = JoinedLine.JoinConnector1 then ptrInterfRecord2.Side := 1; if AConnector2 = JoinedLine.JoinConnector2 then ptrInterfRecord2.Side := 2; ParamsList2.Add(ptrInterfRecord2); end; end; // соединитель с обьектом - соединение кабелей с обьектом if (AConnector1.ConnectorType = Ct_Clear) and (AConnector2.ConnectorType <> Ct_Clear) then begin New(ptrInterfRecord2); ptrInterfRecord2.IDObject := AConnector2.ID; ptrInterfRecord2.Side := -1; ParamsList2.Add(ptrInterfRecord2); end; // Соединить isConnected := ConnectObjectsInPM(ParamsList1, ParamsList2); // Tolik 09/02/2017 -- for i := 0 to ParamsList1.Count - 1 do begin Dispose(PConnectObjectParam(ParamsList1[i])); end; FreeAndNil(ParamsList1); for i := 0 to ParamsList2.Count - 1 do begin Dispose(PConnectObjectParam(ParamsList2[i])); end; FreeAndNil(ParamsList2); // except on E: Exception do addExceptionToLogEx('U_Common.FindConnectionsInterfaces', E.Message); end; end; {******************************************************************************} procedure AutoConnectOnAppendCable(AID_List, AID_Line: Integer; aLineList: TList = nil); var i, j, k: integer; JoinedConn1, JoinedConn2: TConnectorObject; JoinedObject: TConnectorObject; JoinedLine: TOrthoLine; isConnected: Boolean; ptrInterfRecord1, ptrInterfRecord2: PConnectObjectParam; ParamsList1, ParamsList2: TList; ACable: TOrthoLine; vList: TF_CAD; begin try vList := GetListByID(AID_List); if vList <> nil then begin ACable := TOrthoLine(GetFigureByID(vList, AID_Line)); if ACable = Nil then Exit; if not CheckFigureByClassName(ACable, cTOrthoLine) then Exit; ParamsList1 := TList.Create; ParamsList2 := TList.Create; // интерфейсы кабеля New(ptrInterfRecord1); ptrInterfRecord1.IDObject := ACable.ID; ptrInterfRecord1.Side := 1; ParamsList1.Add(ptrInterfRecord1); {***** 1 конектор! *****} JoinedConn1 := TConnectorObject(ACable.JoinConnector1); // ===== проверить все подсоединенные ортолинии ===== for i := 0 to JoinedConn1.JoinedOrtholinesList.Count - 1 do begin JoinedLine := TOrthoLine(JoinedConn1.JoinedOrtholinesList[i]); if JoinedLine <> ACable then begin // Tolik -- 15/03/2018 -- если идет прокладка по выделенным трассам -- чтобы не соскочило на те, по которым // в данный момент кабель не прокладываем if aLineList <> nil then begin if aLineList.IndexOf(JoinedLine) <> -1 then begin New(ptrInterfRecord2); ptrInterfRecord2.IDObject := JoinedLine.ID; if JoinedConn1 = JoinedLine.JoinConnector1 then ptrInterfRecord2.Side := 1; if JoinedConn1 = JoinedLine.JoinConnector2 then ptrInterfRecord2.Side := 2; ParamsList2.Add(ptrInterfRecord2); end; end else // begin New(ptrInterfRecord2); ptrInterfRecord2.IDObject := JoinedLine.ID; if JoinedConn1 = JoinedLine.JoinConnector1 then ptrInterfRecord2.Side := 1; if JoinedConn1 = JoinedLine.JoinConnector2 then ptrInterfRecord2.Side := 2; ParamsList2.Add(ptrInterfRecord2); end; end; end; // ===== проверить все подсоединенные обьекты ===== for i := 0 to JoinedConn1.JoinedConnectorsList.Count - 1 do begin JoinedObject := JoinedConn1.JoinedConnectorsList[i]; New(ptrInterfRecord2); ptrInterfRecord2.IDObject := JoinedObject.ID; ptrInterfRecord2.Side := -1; ParamsList2.Add(ptrInterfRecord2); end; isConnected := ConnectObjectsInPM(ParamsList1, ParamsList2); // Tolik -- 18/03/2018 -- тут пришлось дописать немножко, т.к. в случае, если пользователь установил, например, // элементы кабельных каналов, то возникает такая ситуация, что напрямую с кабелем на следжующей трассе кабель // подключиться не может, к точечному - тоже, потому что это просто элемент кабельного канала, вот и получается, // что кабель остается разорванным //ParamsList1 := TList.Create; // -- это вообще утечка памяти //ParamsList2 := TList.Create; for i := 0 to ParamsList2.Count - 1 do begin Dispose(PConnectObjectParam(ParamsList2[i])); ParamsList2[i] := nil; end; ParamsList2.Pack; if not isConnected then begin JoinedObject := nil; for i := 0 to JoinedConn1.JoinedConnectorsList.Count - 1 do begin JoinedObject := TconnectorObject(JoinedConn1.JoinedConnectorsList[i]); if JoinedObject.ConnectorType = ct_NB then break else JoinedObject := Nil; end; if JoinedObject <> nil then begin for i := 0 to JoinedObject.JoinedConnectorsList.Count - 1 do begin JoinedConn2 := TConnectorObject(JoinedObject.JoinedConnectorsList[i]); if JoinedConn2.ID <> JoinedConn1.ID then begin for j := 0 to JoinedConn2.JoinedOrtholinesList.Count - 1 do begin JoinedLine := TOrthoLine(JoinedConn2.JoinedOrtholinesList[j]); if aLineList <> nil then begin if aLineList.IndexOf(JoinedLine) <> -1 then begin New(ptrInterfRecord2); ptrInterfRecord2.IDObject := JoinedLine.ID; if JoinedConn2 = JoinedLine.JoinConnector1 then ptrInterfRecord2.Side := 1 else if JoinedConn2 = JoinedLine.JoinConnector2 then ptrInterfRecord2.Side := 2; ParamsList2.Add(ptrInterfRecord2); end; end else begin New(ptrInterfRecord2); ptrInterfRecord2.IDObject := JoinedLine.ID; if JoinedConn2 = JoinedLine.JoinConnector1 then ptrInterfRecord2.Side := 1 else if JoinedConn2 = JoinedLine.JoinConnector2 then ptrInterfRecord2.Side := 2; ParamsList2.Add(ptrInterfRecord2); end; isConnected := ConnectObjectsInPM(ParamsList1, ParamsList2); for k := 0 to ParamsList2.Count - 1 do begin Dispose(PConnectObjectParam(ParamsList2[k])); ParamsList2[k] := nil; end; ParamsList2.Pack; if isConnected then break; end; end; if isConnected then break; end; end; end; // освободить память for i := 0 to ParamsList1.Count - 1 do begin Dispose(PConnectObjectParam(ParamsList1[i])); ParamsList1[i] := nil; end; for i := 0 to ParamsList2.Count - 1 do begin Dispose(PConnectObjectParam(ParamsList2[i])); ParamsList2[i] := nil; end; ParamsList1.Pack; ParamsList2.Pack; // // интерфейсы кабеля New(ptrInterfRecord1); ptrInterfRecord1.IDObject := ACable.ID; ptrInterfRecord1.Side := 2; ParamsList1.Add(ptrInterfRecord1); {***** 2 конектор! *****} JoinedConn2 := TConnectorObject(ACable.JoinConnector2); // ===== проверить все подсоединенные ортолинии ===== for i := 0 to JoinedConn2.JoinedOrtholinesList.Count - 1 do begin JoinedLine := TOrthoLine(JoinedConn2.JoinedOrtholinesList[i]); if JoinedLine <> ACable then begin // Tolik --15/03/2018 -- -- если идет прокладка по выделенным трассам -- чтобы не соскочило на те, по которым // в данный момент кабель не прокладываем if aLineList <> nil then begin if aLineList.IndexOf(JoinedLine) <> -1 then begin New(ptrInterfRecord2); ptrInterfRecord2.IDObject := JoinedLine.ID; if JoinedConn2 = JoinedLine.JoinConnector1 then ptrInterfRecord2.Side := 1; if JoinedConn2 = JoinedLine.JoinConnector2 then ptrInterfRecord2.Side := 2; ParamsList2.Add(ptrInterfRecord2); end; end else begin New(ptrInterfRecord2); ptrInterfRecord2.IDObject := JoinedLine.ID; if JoinedConn2 = JoinedLine.JoinConnector1 then ptrInterfRecord2.Side := 1; if JoinedConn2 = JoinedLine.JoinConnector2 then ptrInterfRecord2.Side := 2; ParamsList2.Add(ptrInterfRecord2); end; end; end; // ===== проверить все подсоединенные обьекты ===== for i := 0 to JoinedConn2.JoinedConnectorsList.Count - 1 do begin JoinedObject := JoinedConn2.JoinedConnectorsList[i]; New(ptrInterfRecord2); ptrInterfRecord2.IDObject := JoinedObject.ID; ptrInterfRecord2.Side := -1; ParamsList2.Add(ptrInterfRecord2); end; isConnected := ConnectObjectsInPM(ParamsList1, ParamsList2); // Tolik 15/03/2018 -- коммент смотри выше if not isConnected then begin JoinedObject := nil; for i := 0 to JoinedConn2.JoinedConnectorsList.Count - 1 do begin JoinedObject := TConnectorObject(JoinedConn2.JoinedConnectorsList[i]); if JoinedObject.ConnectorType = ct_NB then break else JoinedObject := Nil; end; if JoinedObject <> nil then begin for i := 0 to JoinedObject.JoinedConnectorsList.Count - 1 do begin JoinedConn1 := TConnectorObject(JoinedObject.JoinedConnectorsList[i]); if JoinedConn1.ID <> JoinedConn2.ID then begin for j := 0 to JoinedConn1.JoinedOrtholinesList.Count - 1 do begin JoinedLine := TOrthoLine(JoinedConn1.JoinedOrtholinesList[j]); if aLineList <> nil then begin if aLineList.IndexOf(JoinedLine) <> -1 then begin New(ptrInterfRecord2); ptrInterfRecord2.IDObject := JoinedLine.ID; if JoinedConn1 = JoinedLine.JoinConnector1 then ptrInterfRecord2.Side := 1 else if JoinedConn1 = JoinedLine.JoinConnector2 then ptrInterfRecord2.Side := 2; ParamsList2.Add(ptrInterfRecord2); end; end else begin New(ptrInterfRecord2); ptrInterfRecord2.IDObject := JoinedLine.ID; if JoinedConn1 = JoinedLine.JoinConnector1 then ptrInterfRecord2.Side := 1 else if JoinedConn1 = JoinedLine.JoinConnector2 then ptrInterfRecord2.Side := 2; ParamsList2.Add(ptrInterfRecord2); end; isConnected := ConnectObjectsInPM(ParamsList1, ParamsList2); for k := 0 to ParamsList2.Count - 1 do begin Dispose(PConnectObjectParam(ParamsList2[k])); ParamsList2[k] := nil; end; ParamsList2.Pack; if isConnected then break; end; end; if isConnected then break; end; end; end; // Tolik 09/02/2017 -- for i := 0 to ParamsList1.Count - 1 do begin Dispose(PConnectObjectParam(ParamsList1[i])); end; FreeAndNil(ParamsList1); for i := 0 to ParamsList2.Count - 1 do begin Dispose(PConnectObjectParam(ParamsList2[i])); end; FreeAndNil(ParamsList2); // end; except on E: Exception do addExceptionToLogEx('U_Common.AutoConnectOnAppendCable', E.Message); end; end; procedure AutoConnectObjectInTrace(APointObject: TConnectorObject; ATrace1, ATrace2: TOrthoLine); var i: integer; isConnected: Boolean; ptrInterfRecord1, ptrInterfRecord2: PConnectObjectParam; ParamsList1, ParamsList2: TList; begin try ParamsList1 := TList.create; ParamsList2 := TList.create; FreeLineFigureInterfaces(ATrace1.ID, 2); New(ptrInterfRecord1); ptrInterfRecord1.IDObject := APointObject.ID; ptrInterfRecord1.Side := -1; ParamsList1.Add(ptrInterfRecord1); New(ptrInterfRecord2); ptrInterfRecord2.IDObject := ATrace1.ID; ptrInterfRecord2.Side := 2; ParamsList2.Add(ptrInterfRecord2); isConnected := ConnectObjectsInPM(ParamsList1, ParamsList2); // Tolik 09/02/2017 -- for i := 0 to ParamsList1.Count - 1 do begin Dispose(PConnectObjectParam(ParamsList1[i])); end; FreeAndNil(ParamsList1); for i := 0 to ParamsList2.Count - 1 do begin Dispose(PConnectObjectParam(ParamsList2[i])); end; FreeAndNil(ParamsList2); // except on E: Exception do addExceptionToLogEx('U_Common.AutoConnectObjectInTrace', E.Message); end; end; procedure AutoConnectObjectToConnectors(APointObject, AConnectedConn: TConnectorObject; AConnectorsList: TList); var i, j: integer; ConnectorsCount: integer; isConnected: Boolean; CurrentConn: TConnectorObject; Joinedline: TOrthoLine; ptrInterfRecord1, ptrInterfRecord2: PConnectObjectParam; ParamsList1, ParamsList2: TList; begin BaseBeginUpdate; try // очистить интерфейсы кабелей // Tolik -- 21/04/2016 -- // закомментил, потому что процедура FreeLineFigureInterfaces не делает совершенно ничего ... {for i := 0 to AConnectorsList.Count - 1 do begin CurrentConn := TConnectorObject(AConnectorsList[i]); for j := 0 to CurrentConn.JoinedOrtholinesList.Count - 1 do begin Joinedline := TOrthoLine(CurrentConn.JoinedOrtholinesList[j]); if Joinedline.JoinConnector1 = CurrentConn then FreeLineFigureInterfaces(Joinedline.ID, 1); if Joinedline.JoinConnector2 = CurrentConn then FreeLineFigureInterfaces(Joinedline.ID, 2); end; end; CurrentConn := AConnectedConn; {for j := 0 to CurrentConn.JoinedOrtholinesList.Count - 1 do // begin // Joinedline := TOrthoLine(CurrentConn.JoinedOrtholinesList[j]); // if Joinedline.JoinConnector1 = CurrentConn then //Нахер этот кусок кода тут не нужен. FreeLineFigureInterfaces(Joinedline.ID, 1); // if Joinedline.JoinConnector2 = CurrentConn then // FreeLineFigureInterfaces(Joinedline.ID, 2); // end; } // CurrentConn := AConnectedConn; // ParamsList1 := TList.create; ParamsList2 := TList.create; // первый параметр - присоединяемый коннектор New(ptrInterfRecord1); for i := 0 to AConnectedConn.JoinedOrtholinesList.Count - 1 do begin JoinedLine := TOrthoLine(AConnectedConn.JoinedOrtholinesList[i]); ptrInterfRecord1.IDObject := Joinedline.ID; if Joinedline.JoinConnector1 = CurrentConn then ptrInterfRecord1.Side := 1; if Joinedline.JoinConnector2 = CurrentConn then ptrInterfRecord1.Side := 2; ParamsList1.Add(ptrInterfRecord1); end; New(ptrInterfRecord2); ptrInterfRecord2.IDObject := APointObject.ID; ptrInterfRecord2.Side := -1; ParamsList2.Add(ptrInterfRecord2); for ConnectorsCount := 0 to AConnectorsList.Count - 1 do begin CurrentConn := TConnectorObject(AConnectorsList[ConnectorsCount]); for i := 0 to CurrentConn.JoinedOrtholinesList.Count - 1 do begin Joinedline := TOrthoLine(CurrentConn.JoinedOrtholinesList[i]); New(ptrInterfRecord2); ptrInterfRecord2.IDObject := Joinedline.ID; if Joinedline.JoinConnector1 = CurrentConn then ptrInterfRecord2.Side := 1; if Joinedline.JoinConnector2 = CurrentConn then ptrInterfRecord2.Side := 2; ParamsList2.Add(ptrInterfRecord2); end; end; isConnected := ConnectObjectsInPM(ParamsList1, ParamsList2); // Tolik 09/02/2017 -- for i := 0 to ParamsList1.Count - 1 do begin Dispose(PConnectObjectParam(ParamsList1[i])); end; FreeAndNil(ParamsList1); for i := 0 to ParamsList2.Count - 1 do begin Dispose(PConnectObjectParam(ParamsList2[i])); end; FreeAndNil(ParamsList2); // except on E: Exception do addExceptionToLogEx('U_Common.AutoConnectObjectToConnectors', E.Message); end; BaseEndUpdate; end; Procedure AppendLineInterfacesToCAD(AID_List, AID_Figure: Integer; AObjName: string; aDivValue: Double); var vList: TF_CAD; vLine: TOrthoLine; SavedSnapFigure: TFigure; begin try vList := getListByID(AID_List); if vList <> nil then begin if vList.FAllowSuppliesKind then begin if vList.FSCSType = st_Internal then begin vLine := TOrthoLine(GetFigureByID(vList, AID_Figure)); if (vLine <> nil) and (not vLine.FIsRaiseUpDown) then begin if aDivValue > 0 then begin SavedSnapFigure := GFigureSnap; vList.AutoDivideTraceOnAppendCable(vLine, aDivValue); GFigureSnap := SavedSnapFigure; end; end; end; end; end; except on E: Exception do addExceptionToLogEx('U_Common.AppendLineInterfacesToCAD', E.Message); end; end; Procedure RemoveLineInterfacesFromCAD(AID_List, AID_Figure: Integer; AObjName: string); begin end; // ВБРОС НЕЛИНЕЙНОГО КОМПОНЕНТА В ПМ Procedure AppendNoLineInterfacesToCAD(AID_List, AID_Figure: Integer; AObjName: string); var i: integer; CADFigure: TConnectorObject; isEmpty: Boolean; NewConn: TConnectorObject; LHandle: integer; GetConn: TConnectorObject; // RaiseConn: TConnectorObject; RaiseLine: TOrthoLine; ObjFromRaise: TConnectorObject; ObjParams: TObjectParams; vList: TF_CAD; SavedCadForm: TF_CAD; begin try vList := GetListByID(AID_List); if vList <> nil then begin SavedCadForm := GCadForm; GCadForm := vList; LHandle := vList.PCad.GetLayerHandle(2); // Find Figure In CAD CADFigure := TConnectorObject(GetFigureByID(vList, AID_Figure)); if CADFigure = nil then Exit; isEmpty := IsEmptyFigure(CADFigure.ID); //Tolik if (CADFigure.ConnectorType = ct_Clear) and (isEmpty = False) and GDragOnCAD then begin NewConn := TConnectorObject.Create(CADFigure.ActualPoints[1].x, CADFigure.ActualPoints[1].y, vList.FConnHeight, LHandle, mydsNormal, vList.PCad); NewConn.ConnectorType := ct_Clear; NewConn.ActualZOrder[1] := CADFigure.ActualZOrder[1]; vList.PCad.AddCustomFigure (GLN(LHandle), NewConn, False); for i := 0 to CADFigure.JoinedOrtholinesList.Count - 1 do begin GetConn := TConnectorObject(TOrthoLine(CADFigure.JoinedOrtholinesList[i]).JoinConnector1); if GetConn = CADFigure then TOrthoLine(CADFigure.JoinedOrtholinesList[i]).SetJConnector1(NewConn); GetConn := TConnectorObject(TOrthoLine(CADFigure.JoinedOrtholinesList[i]).JoinConnector2); if GetConn = CADFigure then TOrthoLine(CADFigure.JoinedOrtholinesList[i]).SetJConnector2(NewConn); end; NewConn.FConnRaiseType := CADFigure.FConnRaiseType; NewConn.FObjectFromRaise := CADFigure.FObjectFromRaise; NewConn.FID_ListToPassage := CADFigure.FID_ListToPassage; NewConn.FID_ConnToPassage := CADFigure.FID_ConnToPassage; CADFigure.FConnRaiseType := crt_None; CADFigure.FObjectFromRaise := nil; CADFigure.JoinedOrtholinesList.Clear; CADFigure.ConnectorType := ct_NB; ObjParams := GetFigureParams(CADFigure.ID); CADFigure.Name := ObjParams.Name; CADFigure.FIndex := ObjParams.MarkID; if not HaveObjectCorkComponent(AID_Figure) then CADFigure.ActualZOrder[1] := vList.FConnHeight; CheckingSnapPointObjectToConnector(CADFigure, NewConn); SetConnObjectSelectHightPriority(CADFigure); //#From Oleg# //29.09.2010 end; RefreshCAD(vList.PCad); GCadForm := SavedCadForm; end; except on E: Exception do addExceptionToLogEx('U_Common.AppendNoLineInterfacesToCAD', E.Message); end; end; // УДАЛИТЬ НЕЛИНЕЙНОГО КОМПОНЕНТА ИЗ ПМ Procedure RemoveNoLineInterfacesFromCAD(AID_List, AID_Figure: Integer; AObjName: string); var i, j: integer; CADFigure: TConnectorObject; isEmpty: Boolean; NewConn: TConnectorObject; GetConn: TConnectorObject; GetLine: TOrthoLine; LHandle: integer; ObjParams: TObjectParams; vList: TF_CAD; SavedCadForm: TF_CAD; //Tolik CADFigureParentCatalog: TSCSCatalog; connectorDeleted: Boolean; joinConnCount, JoinLineCount: Integer; createdList: Boolean; // begin //Tolik CADFigureParentCatalog := nil; connectorDeleted := False; joinLineCount := 0; joinConnCount := 0; createdList := False; // try vList := GetListByID(AID_List); if vList <> nil then begin SavedCadForm := GCadForm; GCadForm := vList; LHandle := vList.PCad.GetLayerHandle(2); CADFigure := TConnectorObject(GetFigureByID(vList, AID_Figure)); if CADFigure = nil then Exit; isEmpty := IsEmptyFigure(CADFigure.ID); //Tolik CADFigureParentCatalog := F_ProjMan.GSCSBase.CurrProject.GetCatalogFromReferencesBySCSID(CadFigure.ID); joinConnCount := CADFigure.JoinedConnectorsList.Count; joinLineCount := CADFigure.JoinedOrtholinesList.Count; // if (CADFigure.ConnectorType <> ct_Clear) and (isEmpty = True) then begin if GTempJoinedLinesConnectors <> nil then GTempJoinedLinesConnectors.Clear // Tolik -- 25/03/2016 -- else begin GTempJoinedLinesConnectors := TList.Create; createdList := True; end; // for i := 0 to CADFigure.JoinedConnectorsList.Count - 1 do begin GetConn := TConnectorObject(CADFigure.JoinedConnectorsList[i]); GTempJoinedLinesConnectors.Add(GetConn); for j := 0 to GetConn.JoinedOrtholinesList.Count - 1 do begin GetLine := TOrthoLine(GetConn.JoinedOrtholinesList[j]); begin if GetLine.JoinConnector1 = GetConn then begin GetLine.SetJConnector1(CADFigure); GetLine.ActualPoints[1] := CADFigure.ActualPoints[1]; end; if GetLine.JoinConnector2 = GetConn then begin GetLine.SetJConnector2(CADFigure); GetLine.ActualPoints[2] := CADFigure.ActualPoints[1]; end; end; end; GetConn.JoinedOrtholinesList.Clear; GetConn.JoinedConnectorsList.Clear; end; CADFigure.JoinedConnectorsList.Clear; CADFigure.ConnectorType := ct_Clear; if CADFigure.FConnRaiseType = crt_None then CADFigure.Name := cCadClasses_Mes12 else CADFigure.Name := cCadClasses_Mes24; SetNewObjectNameInPM(CADFigure.ID, CADFigure.Name); ObjParams := GetFigureParams(CADFigure.ID); CADFigure.Name := ObjParams.Name; CADFigure.FIndex := ObjParams.MarkID; for i := 0 to GTempJoinedLinesConnectors.Count - 1 do TConnectorObject(GTempJoinedLinesConnectors[i]).Delete(False); // Tolik -- 25/03/2016 -- GTempJoinedLinesConnectors.Clear; if createdList then FreeAndNil(GTempJoinedLinesConnectors); // end; //Tolik - удаление о д и н о ч н о г о, п у с т о г о, НИ К ЧЕМУ НЕ ПРИСОЕДИНЕННОГО (В-А-Ж-Н-О!!!) коннектора // проверять joinLineCount - ОБЯЗАТЕЛЬНО! дабы не шлепнуть нечаянно пустой концевик какой-нибудь трассы if (checkfigureByClassName(CadFigure, cTConnectorObject) and (TConnectorObject(CadFigure).ConnectorType = ct_clear)) then if (JoinConnCount = 0) and (joinLineCount = 0) then CADFigureParentCatalog.Delete; CheckDeleteAllRaises(vList.PCad); // Tolik 08/01/2020 -- иначе останется "висячий" райз, если он был на объекте // и потом сыграет хрен знает как ... RefreshCAD(vList.PCad); GCadForm := SavedCadForm; end; except on E: Exception do addExceptionToLogEx('U_Common.RemoveNoLineInterfacesFromCAD', E.Message); end; end; // ВЫДЕЛИТЬ ТРАССУ НА CAD-е function SelectTraceInCAD(LinesList: TList): Double; var i, j: integer; IDInterf: ^Integer; ID: Integer; vFigure: TFigure; vList: TF_CAD; CadsToRefresh: TList; //17.01.2011 //Figures: TList; //15.02.2011 // Tolik 28/08/2019 -- //CurrTick, OldTick: Cardinal; CurrTick, OldTick: DWord; // begin Result := 0; try CadsToRefresh := nil; DeselectTraceInCAD; //15.02.2011 OldTick := GetTickCount; for i := 0 to LinesList.Count - 1 do begin IDInterf := LinesList[i]; ID := IDInterf^; for j := 0 to FSCS_Main.MDIChildCount - 1 do begin vList := TF_CAD(FSCS_Main.MDIChildren[j]); if (vList <> nil) and (vList.PCad <> nil) and (vList.FAutoSelectTrace) and (vList.FListType = lt_Normal) then begin vFigure := TFigure(vList.FSCSFigures.GetObject(ID)); //17.01.2013 vFigure := GetFigureByID(vList, ID); if (vFigure <> nil) and CheckFigureByClassName(vFigure, cTOrthoLine) then begin TOrthoLine(vFigure).isTraceShow := True; Result := Result + TOrthoLine(vFigure).LineLength; //17.01.2011 - Список листов для перерисовки if CadsToRefresh = nil then CadsToRefresh := TList.Create; if CadsToRefresh.IndexOf(vList) = -1 then CadsToRefresh.Add(vList); end; end; end; end; CurrTick := GetTickCount - OldTick; CurrTick := GetTickCount - OldTick; if CadsToRefresh <> nil then begin RefreshCADs(CadsToRefresh); CadsToRefresh.Free; end; except on E: Exception do addExceptionToLogEx('U_Common.SelectTraceInCAD', E.Message); end; end; // УБРАТЬ ВЫДЕЛЕНИЕ ТРАССЫ НА CAD-е function DeselectTraceInCAD: Boolean; var i, j: integer; IDInterf: ^Integer; ID: Integer; vFigure: TFigure; vList: TF_CAD; begin Result := false; try for i := 0 to FSCS_Main.MDIChildCount - 1 do begin vList := TF_CAD(FSCS_Main.MDIChildren[i]); if (vList <> nil) and (vList.PCad <> nil) and (vList.FAutoSelectTrace) and (vList.FListType = lt_Normal) then begin if vList.FNeedUpdateCheckedFigures then vList.UpdateCheckedFigures; for j := 0 to vList.FCheckedFigures.Count - 1 do //for j := 0 to vList.PCad.FigureCount - 1 do begin //vFigure := TFigure(vList.PCad.Figures[j]); vFigure := TFigure(vList.FCheckedFigures[j]); if CheckFigureByClassName(vFigure, cTOrthoLine) then if TOrthoLine(vFigure).isTraceShow then begin TOrthoLine(vFigure).isTraceShow := False; Result := true; end; end; end; end; except on E: Exception do addExceptionToLogEx('U_Common.DeselectTraceInCAD', E.Message); end; end; function GetLineAngle(AP1, AP2: TDoublePoint): Double; var Len_X, Len_Y: Double; AngleRad: Double; AddAngle: Double; begin Result := 0; try Len_X := Abs(AP1.x - AP2.x); Len_Y := Abs(AP1.y - AP2.y); // проверки и вычиление угла в градусах AddAngle := 0; AngleRad := 0; // для неортогональных линий if (AP1.x < AP2.x) and (AP1.y < AP2.y) then // 1 begin AngleRad := ArcTan2(Len_Y, Len_X); // угол в радианах AddAngle := 0; end; if (AP1.x > Ap2.x) and (AP1.y < AP2.y) then //2 begin AngleRad := ArcTan2(Len_X, Len_Y); // угол в радианах AddAngle := 90; end; if (AP1.x > AP2.x) and (AP1.y > AP2.y) then //3 begin AngleRad := ArcTan2(Len_Y, Len_X); // угол в радианах AddAngle := 180; end; if (AP1.x < AP2.x) and (AP1.y > AP2.y) then //4 begin AngleRad := ArcTan2(Len_X, Len_Y); // угол в радианах AddAngle := 270; end; Result := Round(AngleRad * 180 / pi) + AddAngle; // для ортогональных линий if (AP1.y = AP2.y) and (AP1.x < AP2.x) then Result := 0; if (AP1.y = AP2.y) and (AP1.x > AP2.x) then Result := 180; if (AP1.x = AP2.x) and (AP1.y < AP2.y) then Result := 90; if (AP1.x = AP2.x) and (AP1.y > AP2.y) then Result := 270; except on E: Exception do addExceptionToLogEx('U_Common.TF_OrthoLineProperties.GetAngle', E.Message); end; end; // ВЫРОВНЯТЬ ЛИНИЮ Procedure ReAlignLine(aAlignedLine: TOrthoLine); var AcceptDelta: Double; JoinedConn1, JoinedConn2: TConnectorObject; Points1, Points2: TDoublePoint; SnapPoint1, SnapPoint2: Double; delta1, delta2: Double; ReAlignX, ReAlignY: Boolean; begin try JoinedConn1 := TConnectorObject(aAlignedLine.JoinConnector1); JoinedConn2 := TConnectorObject(aAlignedLine.JoinConnector2); Points1 := JoinedConn1.ActualPoints[1]; Points2 := JoinedConn2.ActualPoints[2]; AcceptDelta := GCadForm.PCad.GridStep; ReAlignX := False; ReAlignY := False; if abs(Points1.x - Points2.x) < AcceptDelta then ReAlignX := True; if abs(Points1.y - Points2.y) < AcceptDelta then ReAlignY := True; if (ReAlignX = True) and (ReAlignY = True) then ReAlignY := False; if (ReAlignX = False) and (ReAlignY = False) then begin exit; end; // выравнивание по горизонтали if ReAlignX then begin SnapPoint1 := GetCoordsWithSnapToGrid(Points1.x, Points1.y).x; SnapPoint2 := GetCoordsWithSnapToGrid(Points2.x, Points2.y).x; if SnapPoint1 = SnapPoint2 then begin JoinedConn1.MoveConnector(SnapPoint1 - Points1.x, 0, False); JoinedConn2.MoveConnector(SnapPoint2 - Points2.x, 0, False); end else begin delta1 := abs(SnapPoint1 - Points1.x); delta2 := abs(SnapPoint2 - Points2.x); if delta1 >= delta2 then begin JoinedConn1.MoveConnector(SnapPoint1 - Points1.x, 0, False); JoinedConn2.MoveConnector(SnapPoint1 - Points2.x, 0, False); end else begin JoinedConn1.MoveConnector(SnapPoint2 - Points1.x, 0, False); JoinedConn2.MoveConnector(SnapPoint2 - Points2.x, 0, False); end; end; end; // выравнивание по вертикали if ReAlignY then begin SnapPoint1 := GetCoordsWithSnapToGrid(Points1.x, Points1.y).y; SnapPoint2 := GetCoordsWithSnapToGrid(Points2.x, Points2.y).y; if SnapPoint1 = SnapPoint2 then begin JoinedConn1.MoveConnector(0, SnapPoint1 - Points1.y, False); JoinedConn2.MoveConnector(0, SnapPoint2 - Points2.y, False); end else begin delta1 := abs(SnapPoint1 - Points1.y); delta2 := abs(SnapPoint2 - Points2.y); if delta1 >= delta2 then begin JoinedConn1.MoveConnector(0, SnapPoint1 - Points1.y, False); JoinedConn2.MoveConnector(0, SnapPoint1 - Points2.y, False); end else begin JoinedConn1.MoveConnector(0, SnapPoint2 - Points1.y, False); JoinedConn2.MoveConnector(0, SnapPoint2 - Points2.y, False); end; end; end; except on E: Exception do addExceptionToLogEx('U_Common.ReAlignLine', E.Message); end; end; Procedure ReAlignObject(aAlignedObject: TConnectorObject); var i: integer; x, y: Double; Coords: TDoublePoint; pt: TDoublePoint; begin try x := aAlignedObject.ActualPoints[1].x; y := aAlignedObject.ActualPoints[1].y; Coords := GetCoordsWithSnapToGrid(x, y); if aAlignedObject.FIsHouseJoined then begin for i := 0 to aAlignedObject.FHouse.PointCount - 1 do begin pt := aAlignedObject.FHouse.ActualPoints[i]; if aAlignedObject.IsPointIn(pt.x, pt.y) then begin aAlignedObject.FHouse.ActualPoints[i] := DoublePoint(Coords.x, Coords.y); break; end; end; end; aAlignedObject.MoveConnector(Coords.x - x, Coords.y - y, False); except on E: Exception do addExceptionToLogEx('U_Common.ReAlignObject', E.Message); end; end; // ПОЛУЧИТЬ ВСЮ ТРАССУ function GetAllTraceInCAD(AFigureServer, AFigureWS: TFigure): TList; var StartTick, CurrTick: Cardinal; CurrLength: Double; LastLength: Double; IDAutoTracingPropertyStr: String; CurrFigure: TFigure; JoinedConn: TConnectorObject; JoinedLine: TOrthoLine; IDCompon: ^Integer; Res: Boolean; ptrIDCompon: ^Integer; i: Integer; CurrIDPathList: TList; LastIDPathList: TList; ResultList: TList; loopCounter: integer; // Tolik 22/07/2024 AllCadTraceCount: integer; // Tolik 05/11/2024 ////////////////////////////////////////////////////////////////////////////// Procedure GetStepInCAD(ASourceWS: TFigure; AInOrder: TList; ATraveledIndex: Integer); var i, j: Integer; //IDConn: ^Integer; ComponLength: Double; ConnectedIDList: TList; InOrder: TList; //New begin if GDropTracing then exit; CurrTick := GetTickCount; if ((CurrTick - StartTick) > 5000) then begin GDropTracing := true; //showmessage('Tracing dropped'); end; if GDropTracing then // Tolik 11/11/2024 сброс по таймеру (3 сек) exit; loopCounter := loopCounter + 1; ComponLength := 0; if CheckFigureByClassName(ASourceWS, cTConnectorObject) then begin if TConnectorObject(ASourceWS).FDisableTracing then Exit; end else if CheckFigureByClassName(ASourceWS, cTOrthoLine) then begin if TOrthoLine(ASourceWS).FDisableTracing then Exit; ComponLength := TOrthoLine(ASourceWS).LineLength; if (CurrLength + ComponLength >= LastLength) and (LastLength > 0) then Exit; end; CurrLength := CurrLength + ComponLength; CurrIDPathList.Add(ASourceWS); if (ASourceWS = AFigureWS) and ((CurrLength <= LastLength) or (LastLength = 0)) then begin //*** Переприсвоить кратчайшый путь LastIDPathList.Clear; for i := 0 to CurrIDPathList.Count - 1 do begin CurrFigure := TFigure(CurrIDPathList[i]); LastIDPathList.Add(CurrFigure); end; //*** Переприсвоить кратчайшую длину LastLength := CurrLength; end else {************************************************************************} begin ConnectedIDList := TList.Create; if CheckFigureByClassName(ASourceWS, cTConnectorObject) then begin // OBJECT if TConnectorObject(ASourceWS).ConnectorType <> ct_Clear then begin for i := 0 to TConnectorObject(ASourceWS).JoinedConnectorsList.Count - 1 do begin JoinedConn := TConnectorObject(TConnectorObject(ASourceWS).JoinedConnectorsList[i]); for j := 0 to JoinedConn.JoinedOrtholinesList.Count - 1 do begin JoinedLine := TOrthoLine(JoinedConn.JoinedOrtholinesList[j]); ConnectedIDList.Add(JoinedLine); end; end; end // Connector else if TConnectorObject(ASourceWS).ConnectorType = ct_Clear then begin for j := 0 to TConnectorObject(ASourceWS).JoinedConnectorsList.Count - 1 do begin JoinedConn := TConnectorObject(TConnectorObject(ASourceWS).JoinedConnectorsList[j]); ConnectedIDList.Add(JoinedConn); end; for j := 0 to TConnectorObject(ASourceWS).JoinedOrtholinesList.Count - 1 do begin JoinedLine := TOrthoLine(TConnectorObject(ASourceWS).JoinedOrtholinesList[j]); ConnectedIDList.Add(JoinedLine); end; end; end else if CheckFigureByClassName(ASourceWS, cTOrthoLine) then begin JoinedConn := TConnectorObject(TOrthoLine(ASourceWS).JoinConnector1); ConnectedIDList.Add(JoinedConn); JoinedConn := TConnectorObject(TOrthoLine(ASourceWS).JoinConnector2); ConnectedIDList.Add(JoinedConn); end; InOrder := TList.Create; if AInOrder <> nil then InOrder.Assign(AInOrder); InOrder.Assign(ConnectedIDList, laOr); for i := 0 to ConnectedIDList.Count - 1 do begin CurrFigure := TFigure(ConnectedIDList[i]); if CheckNoFigureinList(CurrFigure, AInOrder) and CheckNoFigureinList(CurrFigure, CurrIDPathList) then //GetStepInCAD(CurrFigure, ConnectedIDList, ATraveledIndex + 1); //Old if ((AInOrder = nil) or ((AInOrder <> nil) and (AInOrder.IndexOf(CurrFigure) = -1))) and (CurrIDPathList.IndexOf(CurrFigure) = -1) then GetStepInCAD(CurrFigure, InOrder, ATraveledIndex + 1); end; FreeAndNil(InOrder); if ConnectedIDList <> nil then FreeAndNil(ConnectedIDList); end; CurrLength := CurrLength - ComponLength; CurrIDPathList.Delete(ATraveledIndex); end; ////////////////////////////////////////////////////////////////////////////// //Tolik 04/11/2024 function CheckNoTraceConnected(aObject: TFigure): Boolean; var i, j: integer; begin Result := True; if aObject is TConnectorObject then begin if TConnectorObject(aObject).ConnectorType = ct_Clear then begin Result := (TConnectorObject(aObject).JoinedOrtholinesList.Count = 0); exit; end else begin for i := 0 to TConnectorObject(aObject).JoinedConnectorsList.Count - 1 do begin if TConnectorObject(TConnectorObject(aObject).JoinedConnectorsList[i]).JoinedOrtholinesList.Count > 0 then begin Result := False; exit; end; end; end; end else begin Result := false; end; end; function getCadTracesCount: integer; var i: integer; begin result := 0; if Assigned(GCadForm) then begin for i := 0 to GCadForm.FSCSFigures.Count - 1 do begin if TFigure(GCadForm.FSCSFigures[i]) is TOrthoLine then inc(Result); end; end; end; Procedure GetStepInCADShort(aConn: TConnectorObject; aList: TList); var i, j, k, listIndex: integer; PassedList, NextPathList, NextConnsList, LinesList : TList; PathLength: double; JoinedConn, NextConn: TConnectorObject; currLine: TOrthoLine; function NoCheckConnInPathList: boolean; var i: Integer; begin Result := True; for i := 0 to PassedList.Count - 1 do begin if TFigure(PassedList[i]).ID = NextConn.ID then begin Result := False; exit; end; end; end; function getNextListIndex: integer; var i: integer; dist, currDist: Double; conn: TConnectorObject; begin Result := 0; if NextConnsList.Count > 1 then begin Conn := TConnectorObject(NextConnsList[0]); if TOrthoLine(LinesList[0]).FIsVertical then currDist := sqrt(sqr(Conn.ap1.x - AFigureWS.ap1.x)+ sqr(Conn.ap1.y - AFigureWS.ap1.y)+sqr(Conn.ActualZOrder[1] - TConnectorObject(AFigureWS).ActualZOrder[1])) else currDist := sqrt(sqr(Conn.ap1.x - AFigureWS.ap1.x)+ sqr(Conn.ap1.y - AFigureWS.ap1.y)); for i := 1 to NextConnsList.Count - 1 do begin Conn := TConnectorObject(NextConnsList[i]); if TOrthoLine(LinesList[i]).FIsVertical then dist := sqrt(sqr(Conn.ap1.x - AFigureWS.ap1.x)+ sqr(Conn.ap1.y - AFigureWS.ap1.y)+sqr(Conn.ActualZOrder[1] - TConnectorObject(AFigureWS).ActualZOrder[1])) else dist := sqrt(sqr(Conn.ap1.x - AFigureWS.ap1.x)+ sqr(Conn.ap1.y - AFigureWS.ap1.y)); if comparevalue(dist, currdist) = -1 then begin currDist := dist; Result := i; end; end; end; end; begin loopCounter := loopCounter + 1; if loopCounter > 8000 then begin exit; end; PassedList := TList.Create; if aList <> nil then PassedList.Assign(aList, laCopy) //passed Way else PassedList.Add(aConn); // StartPoint NextConnsList := TList.Create; NextPathList := nil; PathLength := 0; LinesList := TList.Create; if aConn.ConnectorType = ct_Clear then // clear connector begin JoinedConn := aConn; for i := 0 to JoinedConn.JoinedOrthoLinesList.Count - 1 do begin if TOrthoLine(JoinedConn.JoinedOrthoLinesList[i]).JoinConnector1.ID = JoinedConn.Id then NextConn := TConnectorObject(TOrthoLine(JoinedConn.JoinedOrthoLinesList[i]).JoinConnector2) else NextConn := TConnectorObject(TOrthoLine(JoinedConn.JoinedOrthoLinesList[i]).JoinConnector1); if NextConn.JoinedConnectorsList.Count > 0 then NextConn := TConnectorObject(NextConn.JoinedConnectorsList[0]); if NoCheckConnInPathList then begin if NextConn.ID = AFigureWS.ID then // Founded path begin PassedList.Add(TOrthoLine(JoinedConn.JoinedOrthoLinesList[i])); // последняя трасса PassedList.Add(AFigureWS); for j := 0 to PassedList.Count - 1 do // calc Length begin if TFigure(PassedList[j]) is TOrthoLine then PathLength := PathLength + TOrthoLine(PassedList[j]).LineLength; end; if (PathLength < LastLength) or (LastLength = 0) then begin LastLength := PathLength; LastIDPathList.Clear; LastIDPathList.Assign(PassedList, laCopy); end; PassedList.Free; NextConnsList.Free; LinesList.Free; exit; // path is founded, exit end else begin NextConnsList.Add(NextConn); LinesList.Add(TOrthoLine(JoinedConn.JoinedOrthoLinesList[i])); end; end; end; end else //ct_NB begin for k := 0 to aConn.JoinedConnectorsList.Count - 1 do begin JoinedConn := TConnectorObject(aConn.JoinedConnectorsList[k]); for i := 0 to JoinedConn.JoinedOrthoLinesList.Count - 1 do begin if TOrthoLine(JoinedConn.JoinedOrthoLinesList[i]).JoinConnector1.ID = JoinedConn.Id then NextConn := TConnectorObject(TOrthoLine(JoinedConn.JoinedOrthoLinesList[i]).JoinConnector2) else NextConn := TConnectorObject(TOrthoLine(JoinedConn.JoinedOrthoLinesList[i]).JoinConnector1); if NextConn.JoinedConnectorsList.Count > 0 then NextConn := TConnectorObject(NextConn.JoinedConnectorsList[0]); if NoCheckConnInPathList then begin if NextConn.ID = AFigureWS.ID then // Founded path begin PassedList.Add(TOrthoLine(JoinedConn.JoinedOrthoLinesList[i])); // последняя трасса PassedList.Add(AFigureWS); for j := 0 to PassedList.Count - 1 do // calc Length begin if TFigure(PassedList[j]) is TOrthoLine then PathLength := PathLength + TOrthoLine(PassedList[j]).LineLength; end; if (PathLength < LastLength) or (LastLength = 0) then begin LastLength := PathLength; LastIDPathList.Clear; LastIDPathList.Assign(PassedList, laCopy); end; PassedList.Free; NextConnsList.free; LinesList.Free; exit; // path is founded, exit end else begin NextConnsList.Add(NextConn); LinesList.Add(TOrthoLine(JoinedConn.JoinedOrthoLinesList[i])); end; end; end; end; end; if NextConnsList.Count > 0 then begin NextPathList := TList.Create; While NextConnsList.Count > 0 do // next steps begin NextPathList.Clear; NextPathList.Assign(PassedList, laCopy); ListIndex := getNextListIndex; NextConn := TConnectorObject(NextConnsList[ListIndex]); NextPathList.Add(LinesList[ListIndex]); NextPathList.Add(NextConn); LinesList.Delete(ListIndex); NextConnsList.Delete(ListIndex); GetStepInCADShort(NextConn, NextPathList); if LastIDPathList.Count > 0 then begin NextPathList.Free; PassedList.Free; NextConnsList.Free; LinesList.Free; exit; end; end; NextPathList.Free; end; PassedList.Free; NextConnsList.Free; LinesList.Free; end; // begin Result := nil; loopCounter := 0; //Tolik 04/11/2024 if (AFigureServer = nil) or (AFigureWS = nil) then exit; if CheckNoTraceConnected(AFigureServer) then exit; if CheckNoTraceConnected(AFigureWS) then exit; // try CurrIDPathList := Tlist.Create; CurrLength := 0; LastIDPathList := Tlist.Create; LastLength := 0; //Tolik 05/11/2024 FSCS_Main.TimerTracingInterval.Enabled := true; // 11/11/2024 старт таймера для установки флажка сброса алгоритма поиска пути StartTick := GetTickCount; // 11/11/2024 -- GetStepInCAD(AFigureServer, nil, 0); if GDropTracing then begin //GDropTracing := false; GetStepInCADShort(TConnectorObject(AFigureServer), nil); end; //else // GetStepInCAD(AFigureServer, nil, 0); AllCadTraceCount := getCadTracesCount; //GetStepInCADShort(TConnectorObject(AFigureServer), nil); //GetStepInCADShort(TConnectorObject(AFigureWS), nil); // begin ResultList := TList.Create; for i := 0 to LastIDPathList.Count - 1 do begin CurrFigure := TFigure(LastIDPathList[i]); if CheckFigureByClassName(CurrFigure, cTOrthoLine) then begin if not CurrFigure.Deleted then ResultList.Add(CurrFigure); end else if CheckFigureByClassName(CurrFigure, cTConnectorObject) then begin if TConnectorObject(CurrFigure).ConnectorType <> ct_Clear then ResultList.Add(CurrFigure); /// **** NEW if (TConnectorObject(CurrFigure).ConnectorType = ct_Clear) and (TConnectorObject(CurrFigure).FIsHouseJoined) then ResultList.Add(TConnectorObject(CurrFigure).FHouse); /// **** NEW end; end; if ResultList.Count = 0 then FreeAndNil(ResultList) else Result := ResultList; end; if CurrIDPathList <> nil then FreeAndNil(CurrIDPathList); if LastIDPathList <> nil then FreeAndNil(LastIDPathList); except on E: Exception do addExceptionToLogEx('U_Common.GetAllTraceInCAD', E.Message); end; end; // Added by Tolik // Stolen from Igor but a little bit fully remaked yet Function GetAllTraceInCADByMarked_New1(aAFigureServer, aAFigureWS: TFigure): TList; Var i, j, k: Integer; CurrPath, PassedPath, LineList: TList; ServerAssigned: boolean; PathLength: double; currLine: TOrtholine; Conn, Conn1: TConnectorObject; Line: TOrthoLine; ServerLineConnections, WSLineConnections: Boolean; DistToServer: array of Double; LineMoved: Boolean; currLineLen: double; CurrTick, OldTick: TDateTime; Function GetPathLength(aCurrList: TList): Double; Var i: Integer; vFigure: TFigure; Begin Result := 0; for i := 0 to aCurrList.Count - 1 do begin vFigure := TFigure(aCurrList[i]); if CheckFigureByClassName(vFigure, cTOrthoLine) then Result := Result + TOrthoLine(vFigure).LineLength; end; End; Procedure FindPathToServer(Figure: TFigure; aCurrPath, aPassedPath: TList); Var i, j, k: Integer; TmpPath, TmpPassedPath: TList; TmpLength: double; TmpLineList: TList; DistToServer: array of Double; LineMoved: boolean; currLineLen: double; Conn, Conn1: TConnectorObject; Function CheckFigureInList(aFigure: TFigure; AList: TList): Boolean; Var i: Integer; Begin Result := false; for i := 0 to AList.Count - 1 do begin if aFigure.id = TFigure(AList[i]).id then begin result := true; break; end; end; End; Begin // Tolik --14/05/2018 -- на всякий TmpPath := nil; TmpLineList := nil; TmpPassedPath := nil; // try try { TODO: Доделать здесь проверку запрещенных для прокладки кабеля объектов по аналогии со старой функцией. Пока будет юзаться старая. Эта будет по Shift только пока TODO: Доделать возможность возвращать 1 самый короткий путь и парочку других путей. TODO: доделать счетчик вызова рекурсии для возможности ее прерывания подобие ATraveledIndex } CurrTick := Now - OldTick; if CurrTick > 0.00010 then begin if CurrPath.Count > 0 then begin //ATraveledIndex := ATraveledIndex; exit; end; end; if CurrTick > 0.00017 then begin //ATraveledIndex := ATraveledIndex; exit; end; //if ATraveledIndex > 60 then {40} // if CurrPath.Count > 0 then //begin //ATraveledIndex := ATraveledIndex; // exit; //end; if ((Figure <> nil) and Assigned(Figure)) then begin TmpPath := TList.Create; TmpLineList := TList.Create; TmpPassedPath := TList.Create; SetLength(DistToServer, 0); for i := 0 to aCurrPath.Count - 1 do TmpPath.Add(aCurrPath[i]); for i := 0 to aPassedPath.Count - 1 do TmpPassedPath.Add(aPassedPath[i]); if not CheckFigureInList(Figure, TmpPath) then begin TmpPath.Add(Figure); //Ortholines only TmpLength := GetPathLength(TmpPath); if ((PathLength <> 0) and (TmpLength > PathLength)) then begin FreeAndNil(TmpPath); FreeAndNil(TmpLineList); FreeAndNil(TmpPassedPath); SetLength(DistToServer, 0); Exit; end else begin if CheckFigureByClassName(Figure, cTOrthoLine) then begin Line := TOrthoLine(Figure); Conn := TConnectorObject(Line.JoinConnector1); if TmpPassedPath.IndexOf(Conn) <> - 1 then Conn := TConnectorObject(Line.JoinConnector2); TmpPassedPath.Add(Conn); for i := 0 to Conn.JoinedConnectorsList.Count - 1 do begin TmpPassedPath.Add(TConnectorObject(Conn.JoinedConnectorsList[i])); if TConnectorObject(Conn.JoinedConnectorsList[i]).ID = TConnectorObject(aAFigureServer).ID then begin ServerAssigned := true; if ((PathLength = 0) or (PathLength > TmpLength )) then begin PathLength := TmpLength; CurrPath.Clear; for j := 0 to TmpPath.Count - 1 do begin CurrPath.Add(TmpPath[j]); end; end; FreeAndNil(TmpPath); FreeAndNil(TmpLineList); FreeAndNil(TmpPassedPath); SetLength(DistToServer, 0); exit; end else begin if TConnectorObject(Conn.JoinedConnectorsList[i]).ConnectorType = ct_clear then begin for j := 0 to TConnectorObject(Conn.JoinedConnectorsList[i]).JoinedOrtholinesList.Count - 1 do begin if TmpPath.IndexOf(TOrthoLine(TConnectorObject(Conn.JoinedConnectorsList[i]).JoinedOrtholinesList[j])) = -1 then begin if TmpLineList.IndexOf(TOrthoLine(TConnectorObject(Conn.JoinedConnectorsList[i]).JoinedOrtholinesList[j])) = -1 then TmpLineList.Add(TorthoLine(TConnectorObject(Conn.JoinedConnectorsList[i]).JoinedOrtholinesList[j])); end; end; end else if TConnectorObject(Conn.JoinedConnectorsList[i]).ConnectorType = ct_NB then begin Conn1 := TConnectorObject(Conn.JoinedConnectorsList[i]); for j := 0 to TConnectorObject(Conn1).JoinedConnectorsList.Count - 1 do begin if TmpPassedPath.IndexOf(TConnectorObject(TConnectorObject(Conn1).JoinedConnectorsList[j])) = -1 then TmpPassedPath.Add(TConnectorObject(TConnectorObject(Conn1).JoinedConnectorsList[j])); if TConnectorObject(TConnectorObject(Conn1).JoinedConnectorsList[j]).ConnectorType = ct_clear then begin for k := 0 to TConnectorObject(TConnectorObject(Conn1).JoinedConnectorsList[j]).JoinedOrtholinesList.Count - 1 do begin Line := TConnectorObject(TConnectorObject(Conn1).JoinedConnectorsList[j]).JoinedOrtholinesList[k]; if TmpPath.IndexOf(Line) = -1 then begin if TmpLineList.IndexOf(Line) = -1 then TmpLineList.Add(Line); end; end; end; end; end; end; end; for i := 0 to Conn.JoinedOrtholinesList.Count - 1 do begin Line := TOrthoLine(Conn.JoinedOrtholinesList[i]); if TmpPath.IndexOf(Line) = -1 then begin if TmpLineList.IndexOf(Line) = -1 then TmpLineList.Add(Line); end; end; end; if TmpLineList.Count > 1 then begin for j := 0 to TmpLineList.Count - 1 do begin Line := TOrthoLine(TmpLineList[j]); conn := TConnectorObject(Line.JoinConnector1); if TmpPassedPath.IndexOf(Conn) <> -1 then conn := TConnectorObject(Line.JoinConnector2); SetLength(DistToServer, Length(DistToServer) + 1); // :( ?? не совпадают координаты коннектора линии(с/п) и сервера (как бы ни брал...) {currLineLen := Sqrt( Sqr(Conn.ActualZOrder[1] - TConnectorObject(aAFigureServer).ActualZOrder[1]) + Sqr(conn.ActualPoints[1].x - TConnectorObject(aAFigureServer).ap1.x) + Sqr(conn.ActualPoints[1].y - TConnectorObject(aAFigureServer).ap1.y) );} currLineLen := Sqrt( Sqr(Conn.ActualZOrder[1] - TConnectorObject(aAFigureServer).ActualZOrder[1]) + Sqr(conn.ap1.x - TConnectorObject(aAFigureServer).ap1.x) + Sqr(conn.ap1.y - TConnectorObject(aAFigureServer).ap1.y) ); DistToServer[Length(DistToServer) - 1] := currLineLen;//GetLineLength(aAFigureServer.ap1, conn.ap1, false); end; LineMoved := True; while LineMoved do begin LineMoved := false; for j := 0 to TmpLineList.Count - 2 do begin if DistToServer[j] > DistToServer[j + 1] then begin LineMoved := true; currLineLen := DistToServer[j]; DistToServer[j] := DistToServer[j + 1]; DistToServer[j + 1] := currLineLen; Line := TOrthoLine(TmpLineList[j]); TmpLineList[j] := TmpLineList[j + 1]; TmpLineList[j + 1] := Line; end; end; end; end; if TmpLineList.Count > 0 then begin for i := 0 to TmpLineList.Count - 1 do FindPathToServer(TmpLineList[i], TmpPath, TmpPassedPath); end; FreeAndNil(TmpPath); FreeAndNil(TmpLineList); FreeAndNil(TmpPassedPath); SetLength(DistToServer, 0); end; end; end; Except on E: Exception do addExceptionToLogEx('U_Common.GetAllTraceInCADByMarked_New1.FindPathToServer', E.Message); end; Finally if TmpPath <> nil then FreeAndNil(TmpPath); if TmpLineList <> nil then FreeAndNil(TmpLineList); if TmpPassedPath <> nil then FreeAndNil(TmpPassedPath); SetLength(DistToServer, 0); end; End; Begin OldTick := Now; // Tolik 14/05/2018 -- CurrPath := nil; PassedPath := nil; LineList := nil; // try try Result := TList.Create; // пустой список (для начала) // если все есть if ((aAFigureServer <> nil) and (aAFigureWS <> nil)) then begin // если сервер и станция точечные if (CheckFigureByClassName(aAFigureWS, cTConnectorObject) and CheckFigureByClassName(aAFigureServer, cTConnectorObject)) then begin // если сервер и станция - не одно и тоже if TConnectorObject(aaFigureWS) <> TConnectorObject(aAFigureServer) then begin // ищем линейные соединения у станции и сервера (если их не будет - нет смысла продолжать поиск) // сначала станция WSLineConnections := false; if TConnectorObject(aAFigureWS).JoinedOrtholinesList.Count > 0 then WSLineConnections := true; if not WSLineConnections then begin for i := 0 to TConnectorObject(aAfigureWS).JoinedConnectorsList.Count - 1 do begin Conn := TConnectorObject(TConnectorObject(aAFigureWS).JoinedConnectorsList[i]); if Conn.ConnectorType = ct_clear then begin if Conn.JoinedOrtholinesList.Count > 0 then begin WSLineConnections := true; break; end; end; end; end; ServerLineConnections := false; if TConnectorObject(aAFigureServer).JoinedOrtholinesList.Count > 0 then ServerLineConnections := true; if not ServerLineConnections then begin for i := 0 to TConnectorObject(aAFigureServer).JoinedConnectorsList.Count - 1 do begin Conn := TConnectorObject(aAFigureServer).JoinedConnectorsList[i]; if Conn.ConnectorType = ct_clear then begin if Conn.JoinedOrtholinesList.Count > 0 then begin ServerLineConnections := True; break; end; end; end; end; //ищем путь (Если объекты(оба) имеют линейные подключения) if (ServerLineConnections and WSLineConnections) then begin ServerAssigned := false; CurrPath := TList.Create; PassedPath := TList.Create; LineList := TList.Create; PathLength := 0; Conn := TConnectorObject(aAFigureWS); PassedPath.Add(Conn); // Check direct connected Lines for i := 0 to TConnectorObject(aAFigureWS).JoinedOrtholinesList.Count - 1 do begin Line := TOrthoLine(TConnectorObject(aAFigureWS).JoinedOrtholinesList[i]); LineList.Add(Line); Conn := TConnectorObject(Line.JoinConnector1); if PassedPath.IndexOf(conn) <> - 1 then Conn := TConnectorObject(Line.JoinConnector2); for j := 0 to Conn.JoinedConnectorsList.Count - 1 do begin if TConnectorObject(Conn.JoinedConnectorsList[j]).ConnectorType = ct_NB then begin if TConnectorObject(Conn.JoinedConnectorsList[j]).ID = aAFigureServer.ID then begin ServerAssigned := true; CurrPath.Add(Line); break; end; end end; if ServerAssigned then break; end; if not ServerAssigned then begin // Check Lines connected by connector (to WS) for i := 0 to TConnectorObject(aAFigureWS).JoinedConnectorsList.Count - 1 do begin Conn := TConnectorObject(TConnectorObject(aAFigureWS).JoinedConnectorsList[i]); PassedPath.Add(Conn); if Conn.ConnectorType = ct_Clear then begin for j := 0 to Conn.JoinedOrtholinesList.Count - 1 do begin Line := TOrthoLine(Conn.JoinedOrtholinesList[j]); LineList.Add(Line); Conn1 := TConnectorObject(Line.JoinConnector1); if PassedPath.IndexOf(Conn1) <> -1 then Conn1 := TConnectorObject(Line.JoinConnector2); // Look for Server connection for k := 0 to Conn1.JoinedConnectorsList.Count - 1 do begin if ( (TConnectorObject(Conn1.JoinedConnectorsList[k]).ConnectorType = ct_NB) and (TConnectorObject(Conn1.JoinedConnectorsList[k]).ID = aAFigureServer.ID)) then begin ServerAssigned := true; CurrPath.Add(Line); Break; end; end; if ServerAssigned then break; end; end; if ServerAssigned then break; end; end; if not ServerAssigned then begin // Sorting Lines by Distance to Server if LineList.Count > 1 then begin for j := 0 to LineList.Count - 1 do begin Line := TOrthoLine(LineList[j]); conn := TConnectorObject(Line.JoinConnector1); if PassedPath.IndexOf(Conn) <> -1 then conn := TConnectorObject(Line.JoinConnector2); SetLength(DistToServer, Length(DistToServer) + 1); DistToServer[Length(DistToServer) - 1] := GetLineLength(aAFigureServer.ap1, conn.ap1); end; LineMoved := True; while LineMoved do begin LineMoved := false; for j := 0 to LineList.Count - 2 do begin if DistToServer[j] > DistToServer[j + 1] then begin LineMoved := true; currLineLen := DistToServer[j]; DistToServer[j] := DistToServer[j + 1]; DistToServer[j + 1] := currLineLen; Line := TOrthoLine(LineList[j]); LineList[j] := LineList[j + 1]; LineList[j + 1] := Line; end; end; end; end; for i := 0 to LineList.Count - 1 do FindPathToServer(LineList[i], CurrPath, PassedPath); end; if not ServerAssigned then begin Result.Clear; FreeAndNil(CurrPath); end else begin Result.Add(currPath); end; FreeAndNil(PassedPath); FreeAndNil(LineList); SetLength(DistToServer,0); end; end; end; end; except on E: Exception do addExceptionToLogEx('U_Common.GetAllTraceInCADByMarked_New1', E.Message); end; Finally if Result = nil then begin if CurrPath <> nil then FreeAndNil(CurrPath); end; if PassedPath <> nil then FreeAndNil(PassedPath); if LineList <> nil then FreeAndNil(LineList); end; End; function GetAllTraceInCADByMarked(aAFigureServer, aAFigureWS: TFigure; SotrListByMarked: Boolean = True): TList; var CurrLength: Double; MinLength: Double; CurrFigure: TFigure; JoinedConn: TConnectorObject; JoinedLine: TOrthoLine; i, j, k: Integer; CurrIDPathList: TList; CurrPathList: TList; ResultList: TList; tmpResult: TList; vList1, vList2: TList; CurrTick, OldTick: TDateTime; AFigureServer, AFigureWS: TFigure; ////////////////////////////////////////////////////////////////////////////// Procedure GetStepInCAD(ASourceWS: TFigure; AInOrder: TList; ATraveledIndex: Integer); var i, j: Integer; ConnectedIDList: TList; InOrder: TList; begin if CheckFigureByClassName(ASourceWS, cTConnectorObject) then begin if TConnectorObject(ASourceWS).FDisableTracing then Exit; end else if CheckFigureByClassName(ASourceWS, cTOrthoLine) then begin if TOrthoLine(ASourceWS).FDisableTracing then Exit; end; {$IF Defined(FINAL_SCS) } // Tolik 26/05/2021 --* CurrTick := Now - OldTick; if CurrTick > 0.00009 then begin if ResultList.Count > 0 then begin ATraveledIndex := ATraveledIndex; //showmessage('CurrTick > 0.00009 and ResultList.Count = '+ inttostr(ResultList.Count)); exit; end; end; if CurrTick > 0.00013 then begin ATraveledIndex := ATraveledIndex; //showmessage('CurrTick > 0.00013 '); exit; end; if ATraveledIndex > 60 then {40} if ResultList.Count > 2 then begin ATraveledIndex := ATraveledIndex; //showmessage('ATraveledIndex > 60 and ResultList.Count > 2'); exit; end else if ResultList.Count > 100 then begin if CurrTick > 0.00006 then begin ATraveledIndex := ATraveledIndex; //showmessage('ATraveledIndex > 60 ResultList.Count > 100'); exit; end; end; {$IFEND} // Tolik 26/05/2021 -- CurrIDPathList.Add(ASourceWS); if (ASourceWS = AFigureWS) then begin //*** Переприсвоить кратчайший путь CurrPathList := TList.Create; for i := 0 to CurrIDPathList.Count - 1 do begin CurrFigure := TFigure(CurrIDPathList[i]); // добавить в лист текущего пути if CheckFigureByClassName(CurrFigure, cTOrthoLine) then begin if not TOrthoLine(CurrFigure).deleted then //Tolik 10/04/2021 -- CurrPathList.Add(CurrFigure) end else if CheckFigureByClassName(CurrFigure, cTConnectorObject) then begin if TConnectorObject(CurrFigure).ConnectorType <> ct_Clear then CurrPathList.Add(CurrFigure); /// **** NEW if (TConnectorObject(CurrFigure).ConnectorType = ct_Clear) and (TConnectorObject(CurrFigure).FIsHouseJoined) then CurrPathList.Add(TConnectorObject(CurrFigure).FHouse); /// **** NEW end; end; // добавить с лист всех путей ResultList.Add(CurrPathList); end else {************************************************************************} begin ConnectedIDList := TList.Create; if CheckFigureByClassName(ASourceWS, cTConnectorObject) then begin // OBJECT if TConnectorObject(ASourceWS).ConnectorType <> ct_Clear then begin for i := 0 to TConnectorObject(ASourceWS).JoinedConnectorsList.Count - 1 do begin JoinedConn := TConnectorObject(TConnectorObject(ASourceWS).JoinedConnectorsList[i]); for j := 0 to JoinedConn.JoinedOrtholinesList.Count - 1 do begin JoinedLine := TOrthoLine(JoinedConn.JoinedOrtholinesList[j]); if not JoinedLine.deleted then //Tolik 10/04/2021 -- ConnectedIDList.Add(JoinedLine); end; end; end // Connector else if TConnectorObject(ASourceWS).ConnectorType = ct_Clear then begin for j := 0 to TConnectorObject(ASourceWS).JoinedConnectorsList.Count - 1 do begin JoinedConn := TConnectorObject(TConnectorObject(ASourceWS).JoinedConnectorsList[j]); ConnectedIDList.Add(JoinedConn); end; for j := 0 to TConnectorObject(ASourceWS).JoinedOrtholinesList.Count - 1 do begin JoinedLine := TOrthoLine(TConnectorObject(ASourceWS).JoinedOrtholinesList[j]); if not JoinedLine.deleted then //Tolik 10/04/2021 -- ConnectedIDList.Add(JoinedLine); end; end; end // Trace else if CheckFigureByClassName(ASourceWS, cTOrthoLine) then begin JoinedConn := TConnectorObject(TOrthoLine(ASourceWS).JoinConnector1); ConnectedIDList.Add(JoinedConn); JoinedConn := TConnectorObject(TOrthoLine(ASourceWS).JoinConnector2); ConnectedIDList.Add(JoinedConn); end; InOrder := TList.Create; if AInOrder <> nil then InOrder.Assign(AInOrder); InOrder.Assign(ConnectedIDList, laOr); for i := 0 to ConnectedIDList.Count - 1 do begin CurrFigure := TFigure(ConnectedIDList[i]); if CheckNoFigureinList(CurrFigure, AInOrder) and CheckNoFigureinList(CurrFigure, CurrIDPathList) then begin if ((AInOrder = nil) or ((AInOrder <> nil) and (AInOrder.IndexOf(CurrFigure) = -1))) and (CurrIDPathList.IndexOf(CurrFigure) = -1) then GetStepInCAD(CurrFigure, InOrder, ATraveledIndex + 1); end; end; FreeAndNil(InOrder); if ConnectedIDList <> nil then FreeAndNil(ConnectedIDList); end; // CurrLength := CurrLength - ComponLength; CurrIDPathList.Delete(ATraveledIndex); end; ////////////////////////////////////////////////////////////////////////////// function GetMarkedCount(aCurrList: TList): Integer; var i: Integer; vFigure: TFigure; begin Result := 0; for i := 0 to aCurrList.Count - 1 do begin vFigure := TFigure(aCurrList[i]); if CheckFigureByClassName(vFigure, cTOrthoLine) then if TOrthoLine(vFigure).FMarkTracing then Result := Result + 1; end; end; function GetPathLength(aCurrList: TList): Double; var i: Integer; vFigure: TFigure; begin Result := 0; for i := 0 to aCurrList.Count - 1 do begin vFigure := TFigure(aCurrList[i]); if CheckFigureByClassName(vFigure, cTOrthoLine) then Result := Result + TOrthoLine(vFigure).LineLength; end; end; // ***** GET SORTED LIST ***************************************************** function GetSortedResultList(aResList: TList): TList; var i, j: Integer; vList: TList; vFigure: TFigure; vLine: TOrthoLine; vConn: TConnectorObject; vLength: Double; vCount: Integer; ShortestIndex: Integer; ShortestList: TList; AllMarkedCount: Integer; CurrMaxCount: Integer; MaxIndex: Integer; // Tolik 08/06/2021 -- ListWithAllMarkedTraces: TList; LenArray: array of double; arrLen: Integer; CanExchange: boolean; function CheckAllMarked(aList: TList): Boolean; var i: integer; begin Result := True; for i := 0 to aList.Count - 1 do begin if CheckFigureByClassName(TFigure(aList[i]), CTOrthoLine) then begin if ((not TOrthoLine(aList[i]).FisRaiseUpDown) and (not TOrthoLine(aList[i]).FisVertical)) then begin if (not TOrthoLine(aList[i]).FMarkTracing) then begin Result := False; break; end; end; end; end; end; // begin Result := TList.Create; // получить кол-во отмеченных на листе AllMarkedCount := 0; //commented by Tolik -- 01/06/2016 -- { for i := 0 to GCadForm.PCad.FigureCount - 1 do begin vFigure := TFigure(GCadForm.PCad.Figures[i]); if CheckFigureByClassName(vFigure, cTOrthoLine) then if TOrthoLine(vFigure).FMarkTracing then AllMarkedCount := AllMarkedCount + 1; end; } // Tolik -- 01/06/2016 -- так быстрее for i := 0 to GCadForm.FSCSFigures.Count - 1 do begin vFigure := TFigure(GCadForm.FSCSFigures[i]); if CheckFigureByClassName(vFigure, cTOrthoLine) then if TOrthoLine(vFigure).FMarkTracing then AllMarkedCount := AllMarkedCount + 1; end; // // получение листа с найкратчайшим путем ShortestList := nil; for i := 0 to aResList.Count - 1 do begin vList := TList(aResList[i]); vLength := GetPathLength(vList); if i = 0 then begin MinLength := vLength; ShortestList := vList; end else if vLength < MinLength then begin MinLength := vLength; ShortestList := vList; end; end; // сортировка листов с отмеченными трассами i := 0; while i < aResList.Count do begin vList := TList(aResList[i]); vCount := GetMarkedCount(vList); vLength := GetPathLength(vList); CurrMaxCount := vCount; MinLength := vLength; MaxIndex := 0; for j := 1 to aResList.Count - 1 do begin vList := TList(aResList[j]); vCount := GetMarkedCount(vList); vLength := GetPathLength(vList); // найден лист с большим кол-вом отмеченных if vCount > CurrMaxCount then begin CurrMaxCount := vCount; MaxIndex := j; end else // кол-во отмеченных совпадает, но длинна пути меньше if (vCount = CurrMaxCount) and (vLength < MinLength) then begin MinLength := vLength; MaxIndex := j; end; end; if CurrMaxCount > 0 then Result.Add(aResList[MaxIndex]); aResList.Delete(MaxIndex); end; if Result.IndexOf(ShortestList) = - 1 then begin if CheckNoListInList(ShortestList, Result) then Result.Add(ShortestList); end; // Tolik 08/06/2021 -- проверить пути, в которых все трассы промаркированы ListWithAllMarkedTraces := TList.Create; MinLength := 0; for i := Result.Count - 1 downto 0 do begin if CheckAllMarked(TList(Result[i])) then begin vList := TList(Result[i]); vLength := GetPathLength(vList); ListWithAllMarkedTraces.Add(TList(Result[i])); Result.Delete(i); inc(arrLen); SetLength(LenArray, arrlen); LenArray[arrlen - 1] := vLength; end; end; if ListWithAllMarkedTraces.Count > 1 then begin if ListWithAllMarkedTraces.Count = 2 then begin if CompareValue(LenArray[1], LenArray[2]) = 1 then begin ListWithAllMarkedTraces.Exchange(0, 1); end; end else begin CanExchange := True; while CanExchange do begin CanExchange := False; for i := 0 to ListWithAllMarkedTraces.Count - 2 do begin if CompareValue(LenArray[i + 1], LenArray[i + 2]) = 1 then begin ListWithAllMarkedTraces.Exchange(i, i + 1); vLength := LenArray[i + 1]; LenArray[i + 1] := LenArray[i + 2]; LenArray[i + 2] := vLength; CanExchange := True; end; end; end; end; end; for i := ListWithAllMarkedTraces.Count - 1 downto 0 do Result.Insert(0, ListWithAllMarkedTraces[i]); ListWithAllMarkedTraces.Free; // end; //function ReverseOrderInLists(aList: TList): TList; //begin //end; begin OldTick := Now; CurrIDPathList := Nil; // Tolik --14/05/2018 -- // Tolik -- 28/09/2016 -- // если лист не один --- будет херня, т.к. рабочая станция можеь быть коннектором С/П межетажного // тогда после переворота получим трейсинг с обратным порядком фигур на листах и не сможем соединить // кабели в правильном порядке if (checkfigurebyclassName(aAFigureServer, cTConnectorObject) and checkfigurebyclassName(aAFigureWS, cTConnectorObject)) then begin { if (TConnectorObject(aAFigureServer).FConnRaiseType <> crt_BetweenFloorDown) and (TConnectorObject(aAFigureServer).FConnRaiseType <> crt_BetweenFloorUP) and (TConnectorObject(aAFigureWS).FConnRaiseType <> crt_BetweenFloorDown) and (TConnectorObject(aAFigureWS).FConnRaiseType <> crt_BetweenFloorUP) then} if (not (TConnectorObject(aAFigureServer).FConnRaiseType in [crt_BetweenFloorDown, crt_BetweenFloorUP, crt_TrunkUP, crt_TrunkDown]) ) and (not (TConnectorObject(aAFigureWS).FConnRaiseType in [crt_BetweenFloorDown, crt_BetweenFloorUP, crt_TrunkUP, crt_TrunkDown]) ) then begin AFigureServer := aAFigureWS; AFigureWS := aAFigureServer; end else begin AFigureServer := aAFigureServer; AFigureWS := aAFigureWS; end; end else begin AFigureServer := aAFigureServer; AFigureWS := aAFigureWS; end; // AFigureServer := aAFigureWS; // AFigureWS := aAFigureServer; // -- // AFigureServer := aAFigureServer; // AFigureWS := aAFigureWS; Result := nil; try ResultList := TList.Create; // получить путь по отмеченным CurrIDPathList := TList.Create; GetStepInCAD(AFigureServer, nil, 0); if ResultList.Count = 0 then Result := ResultList else //Tolik // Result := GetSortedResultList(ResultList) begin if SotrListByMarked then Result := GetSortedResultList(ResultList) else Result := ResultList; end; // if CurrIDPathList <> nil then FreeAndNil(CurrIDPathList); // Реверсировать этот лист (нужно для правильного порядка соединений в МП, при ручной трассировки) // Result := ReverseOrderInLists(Result); except on E: Exception do addExceptionToLogEx('U_Common.GetAllTraceInCADByMarked', E.Message); end; end; function CheckConnJoinBetwFloor(aConn: TConnectorObject; CheckRaiseUpDown: boolean = False): Boolean; var RaiseConn: TConnectorObject; begin Result := false; RaiseConn := GetRaiseConn(aConn); if RaiseConn <> nil then begin if Not CheckRaiseUpDown then begin if RaiseConn.FConnRaiseType in [crt_BetweenFloorUp, crt_BetweenFloorDown] then Result := true; end else if RaiseConn.FConnRaiseType in [crt_BetweenFloorUp, crt_BetweenFloorDown, crt_TrunkUp, crt_TrunkDown] then Result := true; end; end; function CheckOtherTraceBetwFloor(Trace: TOrthoLine; CheckRaiseUpDown: boolean = False; CheckMore: boolean = false): Boolean; var isBetweenFloor: boolean; k, kk: integer; JoinTrace: TOrthoLine; JoinTrace2: TOrthoLine; begin result := False; isBetweenFloor := False; try if Trace.JoinConnector1 <> nil then begin for k := 0 to TConnectorObject(Trace.JoinConnector1).JoinedOrtholinesList.Count - 1 do begin JoinTrace := TOrthoLine(TConnectorObject(Trace.JoinConnector1).JoinedOrtholinesList.Items[k]); if ((JoinTrace.FIsRaiseUpDown or JoinTrace.FIsVertical) and CheckRaiseUpDown) or CheckConnJoinBetwFloor(TConnectorObject(JoinTrace.JoinConnector1), CheckRaiseUpDown) or CheckConnJoinBetwFloor(TConnectorObject(JoinTrace.JoinConnector2), CheckRaiseUpDown) then begin isBetweenFloor := True; break; end else begin if (JoinTrace.JoinConnector2 <> nil) and Not isBetweenFloor and CheckMore then begin for kk := 0 to TConnectorObject(JoinTrace.JoinConnector1).JoinedOrtholinesList.Count - 1 do begin JoinTrace2 := TOrthoLine(TConnectorObject(JoinTrace.JoinConnector1).JoinedOrtholinesList.Items[kk]); if ((JoinTrace2.FIsRaiseUpDown or JoinTrace2.FIsVertical) and CheckRaiseUpDown) or CheckConnJoinBetwFloor(TConnectorObject(JoinTrace2.JoinConnector1), CheckRaiseUpDown) or CheckConnJoinBetwFloor(TConnectorObject(JoinTrace2.JoinConnector2), CheckRaiseUpDown) then begin isBetweenFloor := True; break; end; end; end; if (JoinTrace.JoinConnector2 <> nil) and Not isBetweenFloor and CheckMore then begin for kk := 0 to TConnectorObject(JoinTrace.JoinConnector2).JoinedOrtholinesList.Count - 1 do begin JoinTrace2 := TOrthoLine(TConnectorObject(JoinTrace.JoinConnector2).JoinedOrtholinesList.Items[kk]); if ((JoinTrace2.FIsRaiseUpDown or JoinTrace2.FIsVertical) and CheckRaiseUpDown) or CheckConnJoinBetwFloor(TConnectorObject(JoinTrace2.JoinConnector1), CheckRaiseUpDown) or CheckConnJoinBetwFloor(TConnectorObject(JoinTrace2.JoinConnector2), CheckRaiseUpDown) then begin isBetweenFloor := True; break; end; end; end; end; if isBetweenFloor then break; end; end; if (Trace.JoinConnector2 <> nil) and Not isBetweenFloor then begin for k := 0 to TConnectorObject(Trace.JoinConnector2).JoinedOrtholinesList.Count - 1 do begin JoinTrace := TOrthoLine(TConnectorObject(Trace.JoinConnector2).JoinedOrtholinesList.Items[k]); if ((JoinTrace.FIsRaiseUpDown or JoinTrace.FIsVertical) and CheckRaiseUpDown) or CheckConnJoinBetwFloor(TConnectorObject(JoinTrace.JoinConnector1), CheckRaiseUpDown) or CheckConnJoinBetwFloor(TConnectorObject(JoinTrace.JoinConnector2), CheckRaiseUpDown) then begin isBetweenFloor := True; break; end else begin if (JoinTrace.JoinConnector2 <> nil) and Not isBetweenFloor and CheckMore then begin for kk := 0 to TConnectorObject(JoinTrace.JoinConnector1).JoinedOrtholinesList.Count - 1 do begin JoinTrace2 := TOrthoLine(TConnectorObject(JoinTrace.JoinConnector1).JoinedOrtholinesList.Items[kk]); if ((JoinTrace2.FIsRaiseUpDown or JoinTrace2.FIsVertical) and CheckRaiseUpDown) or CheckConnJoinBetwFloor(TConnectorObject(JoinTrace2.JoinConnector1), CheckRaiseUpDown) or CheckConnJoinBetwFloor(TConnectorObject(JoinTrace2.JoinConnector2), CheckRaiseUpDown) then begin isBetweenFloor := True; break; end; end; end; if (JoinTrace.JoinConnector2 <> nil) and Not isBetweenFloor and CheckMore then begin for kk := 0 to TConnectorObject(JoinTrace.JoinConnector2).JoinedOrtholinesList.Count - 1 do begin JoinTrace2 := TOrthoLine(TConnectorObject(JoinTrace.JoinConnector2).JoinedOrtholinesList.Items[kk]); if ((JoinTrace2.FIsRaiseUpDown or JoinTrace2.FIsVertical) and CheckRaiseUpDown) or CheckConnJoinBetwFloor(TConnectorObject(JoinTrace2.JoinConnector1), CheckRaiseUpDown) or CheckConnJoinBetwFloor(TConnectorObject(JoinTrace2.JoinConnector2), CheckRaiseUpDown) then begin isBetweenFloor := True; break; end; end; end; end; if isBetweenFloor then break; end; end; except end; result := isBetweenFloor; end; function GetAllNoConnectedTraces(aCAD: TF_CAD): TList; var i, k, kk: Integer; Trace: TOrthoLine; isBetweenFloor: boolean; // aList: TList; //function isBetweenFloorExist(TraceCh: TOrthoLine): boolean; //var // JoinTrace: TOrthoLine; // j: integer; //begin // result := False; // if TraceCh.JoinConnector1 <> nil then // begin // for j := 0 to TConnectorObject(TraceCh.JoinConnector1).JoinedOrtholinesList.Count - 1 do // begin // JoinTrace := TOrthoLine(TConnectorObject(TraceCh.JoinConnector1).JoinedOrtholinesList.Items[j]); // if aList.IndexOf(JoinTrace) < 0 then // begin // aList.Add(JoinTrace); // if JoinTrace.JoinConnector1 <> nil then // if (TConnectorObject(JoinTrace.JoinConnector1).FConnRaiseType = crt_BetweenFloorUp) // or (TConnectorObject(JoinTrace.JoinConnector1).FConnRaiseType = crt_BetweenFloorDown) then // result := True; // if result then // break; // if JoinTrace.JoinConnector2 <> nil then // if (TConnectorObject(JoinTrace.JoinConnector1).FConnRaiseType = crt_BetweenFloorUp) // or (TConnectorObject(JoinTrace.JoinConnector1).FConnRaiseType = crt_BetweenFloorDown) then // result := True; // if result then // break; // result := isBetweenFloorExist(JoinTrace); // if result then // break; // end; // end; // end; // // if (TraceCh.JoinConnector2 <> nil) and Not Result then // begin // for j := 0 to TConnectorObject(TraceCh.JoinConnector2).JoinedOrtholinesList.Count - 1 do // begin // JoinTrace := TOrthoLine(TConnectorObject(TraceCh.JoinConnector2).JoinedOrtholinesList.Items[j]); // if aList.IndexOf(JoinTrace) < 0 then // begin // aList.Add(JoinTrace); // if JoinTrace.JoinConnector1 <> nil then // if (TConnectorObject(JoinTrace.JoinConnector1).FConnRaiseType = crt_BetweenFloorUp) // or (TConnectorObject(JoinTrace.JoinConnector1).FConnRaiseType = crt_BetweenFloorDown) then // result := True; // if result then // break; // if JoinTrace.JoinConnector2 <> nil then // if (TConnectorObject(JoinTrace.JoinConnector2).FConnRaiseType = crt_BetweenFloorUp) // or (TConnectorObject(JoinTrace.JoinConnector2).FConnRaiseType = crt_BetweenFloorDown) then // result := True; // if result then // break; // // result := isBetweenFloorExist(JoinTrace); // if result then // break; // end; // end; // end; //end; begin // Result := GetAllFiguresByClass(aCAD, TOrthoLine); // aList := TList.Create; // for i := Result.Count - 1 downto 0 do // begin // Trace := TOrthoLine(Result[i]); // aList.Clear; // isBetweenFloor := isBetweenFloorExist(Trace); // if Trace.FIsRaiseUpDown or Trace.FIsVertical then // Result.Delete(i) // else // if isBetweenFloor then // Result.Delete(i) // end; // aList.Free; Result := GetAllFiguresByClass(aCAD, TOrthoLine); for i := Result.Count - 1 downto 0 do begin Trace := TOrthoLine(Result[i]); isBetweenFloor := False; if Trace.FIsRaiseUpDown or Trace.FIsVertical or CheckConnJoinBetwFloor(TConnectorObject(Trace.JoinConnector1)) or CheckConnJoinBetwFloor(TConnectorObject(Trace.JoinConnector2)) then Result.Delete(i) else begin isBetweenFloor := CheckOtherTraceBetwFloor(Trace); if isBetweenFloor then Result.Delete(i) end; end; end; function CheckNoFigureInList(ACheckFigure: TFigure; AList: TList): Boolean; var i: Integer; begin Result := true; try if AList <> nil then begin for i := 0 to AList.Count - 1 do if ACheckFigure = TFigure(AList[i]) then begin Result := false; Break; end; end; except on E: Exception do addExceptionToLogEx('U_Common.CheckNoFigureinList', E.Message); end; end; function CheckNoCadInList(ACheckCad: TF_CAD; AList: TList): Boolean; var i: Integer; begin Result := true; try if AList <> nil then begin for i := 0 to AList.Count - 1 do if ACheckCad = TF_CAD(AList[i]) then begin Result := false; Break; end; end; except on E: Exception do addExceptionToLogEx('CheckNoFigureInList', E.Message); end; end; function CheckNoListInList(AInList, AList: TList): Boolean; var i: Integer; begin Result := true; try if AList <> nil then begin for i := 0 to AList.Count - 1 do if AInList = TList(AList[i]) then begin Result := false; Break; end; end; except on E: Exception do AddExceptionToLogEx('U_Common.CheckNoListInList', E.Message); end; end; function CheckRaise(APointObject: TConnectorObject): Boolean; var i, j: integer; JoinedLine: TOrthoLine; JoinedConn: TConnectorObject; MinX, MaxX, MinY, MaxY: Double; begin Result := False; try // объект if APointObject.ConnectorType <> ct_Clear then begin for i := 0 to APointObject.JoinedConnectorsList.Count - 1 do begin JoinedConn := TConnectorObject(APointObject.JoinedConnectorsList[i]); for j := 0 to JoinedConn.JoinedOrtholinesList.Count - 1 do begin JoinedLine := TOrthoLine(JoinedConn.JoinedOrtholinesList[j]); if JoinedLine.FObjectFromRaisedLine = APointObject then Result := True; end; end; end else // соединитель begin for i := 0 to APointObject.JoinedOrtholinesList.Count - 1 do begin JoinedLine := TOrthoLine(APointObject.JoinedOrtholinesList[i]); if JoinedLine.FObjectFromRaisedLine = APointObject then Result := True; end; end; except on E: Exception do addExceptionToLogEx('U_Common.CheckRaise', E.Message); end; end; function GetBasisPointByObjFromRaise(aObj: TConnectorObject): TDoublePoint; begin Result := DoublePoint(0,0,0); if aObj.DrawFigure = nil then begin Result.x := aObj.ActualPoints[1].x + aObj.GrpSizeX / 2; Result.y := aObj.ActualPoints[1].y - aObj.GrpSizeY / 2; end else begin if aObj.DrawFigure.InFigures.Count = 0 then begin Result.x := aObj.ActualPoints[1].x + aObj.GrpSizeX / 2; Result.y := aObj.ActualPoints[1].y - aObj.GrpSizeY / 2; end else begin Result.x := aObj.DrawFigure.CenterPoint.x + aObj.GrpSizeX / 2 - 0.5; Result.y := aObj.DrawFigure.CenterPoint.y - aObj.GrpSizeY / 2 + 0.5; end; end; end; function GetRaiseConn(APointObject: TConnectorObject): TConnectorObject; var i, j: integer; JoinedLine: TOrthoLine; JoinedConn: TConnectorObject; MinX, MaxX, MinY, MaxY: Double; CurConn: TConnectorObject; begin Result := nil; try if APointObject = nil then Exit; // соединитель if APointObject.ConnectorType = ct_Clear then begin for i := 0 to APointObject.JoinedOrtholinesList.Count - 1 do begin JoinedLine := TOrthoLine(APointObject.JoinedOrtholinesList[i]); if JoinedLine.FObjectFromRaisedLine = APointObject then begin // 1 CurConn := TConnectorObject(JoinedLine.JoinConnector1); if CurConn.JoinedConnectorsList.Count = 0 then begin if CurConn.FObjectFromRaise = APointObject then Result := CurConn; end else begin if TConnectorObject(CurConn.JoinedConnectorsList[0]).FObjectFromRaise = APointObject then Result := TConnectorObject(CurConn.JoinedConnectorsList[0]); end; // 2 CurConn := TConnectorObject(JoinedLine.JoinConnector2); if CurConn.JoinedConnectorsList.Count = 0 then begin if CurConn.FObjectFromRaise = APointObject then Result := CurConn; end else begin if TConnectorObject(CurConn.JoinedConnectorsList[0]).FObjectFromRaise = APointObject then Result := TConnectorObject(CurConn.JoinedConnectorsList[0]); end; end; end; end else // объект begin for i := 0 to APointObject.JoinedConnectorsList.Count - 1 do begin JoinedConn := TConnectorObject(APointObject.JoinedConnectorsList[i]); for j := 0 to JoinedConn.JoinedOrtholinesList.Count - 1 do begin JoinedLine := TOrthoLine(JoinedConn.JoinedOrtholinesList[j]); if JoinedLine.FObjectFromRaisedLine = APointObject then begin CurConn := TConnectorObject(JoinedLine.JoinConnector1); if CurConn.JoinedConnectorsList.Count = 0 then begin if CurConn.FObjectFromRaise = APointObject then Result := CurConn; end else begin if TConnectorObject(CurConn.JoinedConnectorsList[0]).FObjectFromRaise = APointObject then Result := TConnectorObject(CurConn.JoinedConnectorsList[0]); end; // 2 CurConn := TConnectorObject(JoinedLine.JoinConnector2); if CurConn.JoinedConnectorsList.Count = 0 then begin if CurConn.FObjectFromRaise = APointObject then Result := CurConn; end else begin if TConnectorObject(CurConn.JoinedConnectorsList[0]).FObjectFromRaise = APointObject then Result := TConnectorObject(CurConn.JoinedConnectorsList[0]); end; end; end; end; end; except on E: Exception do addExceptionToLogEx('U_Common.GetRaiseConn', E.Message); end; end; function GetRaiseLine(ARaiseConn: TConnectorObject): TOrthoLine; var i, j: integer; ConnectedConn: TConnectorObject; begin Result := nil; // Tolik 30/09/2016-- if aRaiseConn.deleted then exit; // try // Вершина с-п - соединитель if ARaiseConn.ConnectorType = ct_Clear then begin for i := 0 to ARaiseConn.JoinedOrtholinesList.Count - 1 do // Tolik 07/04/2017 -- { if TOrthoLine(ARaiseConn.JoinedOrtholinesList[i]).FIsRaiseUpDown then Result := TOrthoLine(ARaiseConn.JoinedOrtholinesList[i]); } begin if ((TOrthoLine(ARaiseConn.JoinedOrtholinesList[i]).FIndex <> -1) and TOrthoLine(ARaiseConn.JoinedOrtholinesList[i]).FIsRaiseUpDown) then Result := TOrthoLine(ARaiseConn.JoinedOrtholinesList[i]); end; // end else // Вершина с-п - Объект begin for i := 0 to ARaiseConn.JoinedConnectorsList.Count - 1 do begin ConnectedConn := TConnectorObject(ARaiseConn.JoinedConnectorsList[i]); for j := 0 to ConnectedConn.JoinedOrtholinesList.Count - 1 do // Tolik 07/04/2017 -- { if TOrthoLine(ConnectedConn.JoinedOrtholinesList[j]).FIsRaiseUpDown then Result := TOrthoLine(ConnectedConn.JoinedOrtholinesList[j]); } if ((TOrthoLine(ConnectedConn.JoinedOrtholinesList[j]).FIndex <> -1) and TOrthoLine(ConnectedConn.JoinedOrtholinesList[j]).FIsRaiseUpDown) then Result := TOrthoLine(ConnectedConn.JoinedOrtholinesList[j]); // end; end; // Correct if Result <> nil then begin if Result.FLineRaiseType = lrt_None then begin if ARaiseConn.FObjectFromRaise <> nil then Result.FLineRaiseType := GetRaiseType(ARaiseConn.FObjectFromRaise, aRaiseConn); end; end; except on E: Exception do addExceptionToLogEx('U_Common.GerRaiseLine', E.Message); end; end; function GetRaiseByRaiseLine(aRaiseLine: TOrthoLine): TConnectorObject; begin Result := nil; try if TConnectorObject(aRaiseLine.JoinConnector1).FConnRaiseType <> crt_None then Result := TConnectorObject(aRaiseLine.JoinConnector1); if TConnectorObject(aRaiseLine.JoinConnector2).FConnRaiseType <> crt_None then Result := TConnectorObject(aRaiseLine.JoinConnector2); except on E: Exception do addExceptionToLogEx('U_Common.GetRaiseByRaiseLine', E.Message); end; end; // высота комнаты Procedure SetCurrListHeightRoom(AHeight: Double); begin GCadForm.FRoomHeight := AHeight; end; // высота подвесного потолка Procedure SetCurrListHeightCeiling(AHeight: Double); //*** для потолка begin GCadForm.FFalseFloorHeight := AHeight; end; // высота розеток Procedure SetCurrListHeightSocket(AHeight: Double); //*** для розеток begin GCadForm.FConnHeight := AHeight; end; // выделить подсоединенный коннектор на CAD Procedure SelectConnectedConnector(AID_List, AID_Figure: Integer); var i: integer; CAD_Figure: TFigure; vList: TF_CAD; begin try vList := GetListByID(AID_List); if vList <> nil then begin CAD_Figure := GetFigureByID(vList, AID_Figure); if CAD_Figure <> nil then begin vList.PCad.DeselectAll(2); CAD_Figure.Select; RefreshCAD(vList.PCad); end; end; except on E: Exception do addExceptionToLogEx('U_Common.SelectConnectedConnector', E.Message); end; end; Procedure SelectConnectedCables(AID_List: Integer; ALinesList: TIntList); var FCount: integer; LCount: integer; IDInterf: Integer; ID: Integer; vList: TF_CAD; begin try vList := GetListByID(AID_List); if vList <> nil then begin vList.PCad.DeselectAll(2); for LCount := 0 to ALinesList.Count - 1 do begin IDInterf := ALinesList[LCount]; ID := IDInterf; for FCount := 0 to vList.PCad.FigureCount - 1 do begin if CheckFigureByClassName(TFigure(vList.PCad.Figures[FCount]), cTOrthoLine) then if TFigure(vList.PCad.Figures[FCount]).ID = ID then TOrthoLine(vList.PCad.Figures[FCount]).Select; end; end; RefreshCAD(vList.PCad); end; except on E: Exception do addExceptionToLogEx('U_Common.SelectConnectedCables', E.Message); end; end; // Tolik 17/03/2017 -- Procedure CreateRaiseOnPointObjectNew(APointObject: TConnectorObject; AHeight: Double); var ConnectedConn: TConnectorObject; RaiseConn: TConnectorObject; RaiseLine: TOrthoLine; x, y, z: double; i: integer; JoinedLine: TOrthoLine; JoinedConn: TConnectorObject; JoinedConnBase: TConnectorObject; ObjParams: TObjectParams; TempRaisedConnectors: TList; CurIndex: Integer; //Tolik SetRaiseHeight: Double; RaiseHeight: Double; ObjFromRaise: TConnectorObject; TraceList: TList; RaiseUP: Boolean; function GetTraceList: TList; var i, j : Integer; begin Result := TList.Create; if aPointObject.ConnectorType = ct_NB then begin for i := 0 to aPointObject.JoinedConnectorsList.Count - 1 do begin for j := 0 to TConnectorObject(aPointObject.JoinedConnectorsList[i]).JoinedOrthoLinesList.Count - 1 do begin if Result.IndexOf(TOrthoLine(TConnectorObject(aPointObject.JoinedConnectorsList[i]).JoinedOrthoLinesList[j])) = -1 then Result.Add(TOrthoLine(TConnectorObject(aPointObject.JoinedConnectorsList[i]).JoinedOrthoLinesList[j])); end; end; end; if Result.Count = 0 then begin FreeAndNil(Result); Result := Nil; // на всякий end; end; function CheckCanCreateRaise(AConn: TConnectorObject): Boolean; var i,j: Integer; RaiseLine: TOrthoLine; VertLine: TOrthoLine; currConn: TConnectorObject; JoinedConn: TConnectorObject; begin Result := False; VertLine := nil; RaiseLine := nil; currConn := AConn; if (currConn.ConnectorType = ct_Clear) and (currConn.JoinedConnectorsList.Count > 0) then currConn := TconnectorObject(currConn.JoinedConnectorsList[0]); if (currConn.ConnectorType = ct_Clear) then begin for i := 0 to currConn.JoinedOrtholinesList.Count - 1 do begin if TOrthoLine(currConn.JoinedOrtholinesList[i]).FIsRaiseUpDown then RaiseLine := TOrthoLine(AConn.JoinedOrtholinesList[i]) else if TOrthoLine(currConn.JoinedOrtholinesList[i]).FIsVertical then VertLine := TOrthoLine(AConn.JoinedOrtholinesList[i]); end; end else if currConn.ConnectorType = ct_NB then begin for i := 0 to currConn.JoinedConnectorsList.Count - 1 do begin JoinedConn := TConnectorObject(currConn.JoinedConnectorsList[i]); for j := 0 to JoinedConn.JoinedOrtholinesList.Count - 1 do begin if TOrthoLine(JoinedConn.JoinedOrtholinesList[j]).FIsRaiseUpDown then RaiseLine := TOrthoLine(JoinedConn.JoinedOrtholinesList[i]) else if TOrthoLine(JoinedConn.JoinedOrtholinesList[j]).FIsVertical then VertLine := TOrthoLine(JoinedConn.JoinedOrtholinesList[i]); end; end; end; if (VertLine = nil) and (RaiseLine = nil) then Result := True else begin end; end; begin if not CheckCanCreateRaise(APointObject) then Exit; RaiseUP := False; if CompareValue(APointObject.ActualZOrder[1], aHeight) = 0 then // если на той же высоте -- нах exit; // Куда направлен райз if CompareValue(aPointObject.ActualZOrder[1], aHeight) = -1 then RaiseUP := True; BaseBeginUpdate; try if CheckJoinVertical(APointObject, aHeight) then begin //TraceList := GetTraceList; TraceList := Nil; PutObjectOnHeight(APointObject, AHeight, TraceList); BaseEndUpdate; if TraceList <> nil then FreeAndNil(TraceList); exit; end; x := APointObject.ActualPoints[1].x; y := APointObject.ActualPoints[1].y; // Tolik // z := APointObject.ActualZOrder[1]; if TConnectorObject(APointObject).Radius > 10000000 then //if TConnectorObject(APointObject).Radius > 11000000 then begin if (TConnectorObject(APointObject).Radius - 11000000) <> 999 then z := TConnectorObject(APointObject).Radius - 11000000 else z := APointObject.ActualZOrder[1]; end else z := APointObject.ActualZOrder[1]; // создать присоединенный коннектор // ConnectedConn := TConnectorObject.Create(x, y, AHeight, APointObject.LayerHandle, mydsNormal, GCadForm.PCad); ConnectedConn := TConnectorObject.Create(x, y, APointObject.ActualZOrder[1], APointObject.LayerHandle, mydsNormal, GCadForm.PCad); ConnectedConn.ConnectorType := ct_Clear; GCadForm.PCad.AddCustomFigure (GLN(APointObject.LayerHandle), ConnectedConn, False); ConnectedConn.Name := cCadClasses_Mes12; SetNewObjectNameInPM(ConnectedConn.ID, ConnectedConn.Name); ObjParams := GetFigureParams(ConnectedConn.ID); ConnectedConn.Name := ObjParams.Name; ConnectedConn.FIndex := ObjParams.MarkID; //APointObject.ActualZOrder[1] := AHeight; for i := 0 to APointObject.JoinedConnectorsList.Count - 1 do TConnectorObject(APointObject.JoinedConnectorsList[i]).ActualZOrder[1] := APointObject.ActualZOrder[1]; SetConFigureCoordZInPM(APointObject.ID, APointObject.ActualZOrder[1]); // создать подъем-спуск коннектор RaiseConn := TConnectorObject.Create(x + 10, y - 10, AHeight, APointObject.LayerHandle, mydsNormal, GCadForm.PCad); RaiseConn.ConnectorType := ct_Clear; // создать подъем-спуск линия RaiseLine := TOrthoLine.Create(x, y, AHeight, x + 10, y - 10, z, 1,ord(psSolid), clBlack, 0, APointObject.LayerHandle, mydsNormal, GCadForm.PCad, False); RaiseLine.SetJConnector1(TConnectorObject(ConnectedConn)); RaiseLine.SetJConnector2(TConnectorObject(RaiseConn)); // Tolik //RaiseLine.ActualZOrder[1] := ConnectedConn.ActualZOrder[1]; // RaiseLine.ActualZOrder[2] := RaiseConn.ActualZOrder[1]; if TConnectorObject(APointObject).Radius > 10000000 then begin if ((APointObject.Radius - 11000000) <> 999) and ( (APointObject.Radius - 11000000) <> 0) then RaiseLine.ActualZOrder[2] := APointObject.Radius - 11000000 else RaiseLine.ActualZOrder[2] := RaiseConn.ActualZOrder[1]; end else RaiseLine.ActualZOrder[2] := RaiseConn.ActualZOrder[1]; // SetLineFigureCoordZInPM(RaiseLine.ID, 1, RaiseLine.ActualZOrder[1]); SetLineFigureCoordZInPM(RaiseLine.ID, 2, RaiseLine.ActualZOrder[2]); // приконнектить подъем //SnapConnectorToPointObject(ConnectedConn, APointObject, true); ConnectedConn.JoinedConnectorsList.Add(APointObject); if aPointObject.JoinedConnectorsList.count = 0 then APointObject.JoinedConnectorsList.Add(ConnectedConn) else APointObject.JoinedConnectorsList.Insert(0, ConnectedConn); //Tolik 19/11/2019 -- delete from PM connected CLRAR from POINT DeleteObjectFromPM(ConnectedConn.ID, ConnectedConn.Name); // // Tolik //RaiseLine.ActualZOrder[1] := APointObject.ActualZOrder[1]; //TConnectorObject(RaiseLine.JoinConnector1).ActualZOrder[1] := APointObject.ActualZOrder[1]; // RaiseLine.ActualZOrder[2] := RaiseConn.ActualZOrder[1]; { if TConnectorObject(APointObject).Radius > 10000000 then if (APointObject.Radius - 11000000) <> 999 then RaiseLine.ActualZOrder[2] := APointO;bject.Radius - 11000000 else RaiseLine.ActualZOrder[2] := RaiseConn.ActualZOrder[1];} //else // RaiseLine.ActualZOrder[2] := RaiseConn.ActualZOrder[1];} // // СОЗДАТЬ НА КАД =========================================== GCadForm.PCad.AddCustomFigure (GLN(APointObject.LayerHandle), RaiseConn, False); GMoveWithRaise := False; RaiseConn.MoveConnector(-10, 10, False); GMoveWithRaise := True; RaiseConn.Name := cCadClasses_Mes24; // ??? RaiseConn.FConnRaiseType := crt_OnFloor; //RaiseConn.FObjectFromRaise := APointObject; SetNewObjectNameInPM(RaiseConn.ID, RaiseConn.Name); ObjParams := GetFigureParams(RaiseConn.ID); RaiseConn.Name := ObjParams.Name; RaiseConn.FIndex := ObjParams.MarkID; GCadForm.PCad.AddCustomFigure (GLN(APointObject.LayerHandle), RaiseLine, False); RaiseLine.Name := cCadClasses_Mes25; SetNewObjectNameInPM(RaiseLine.ID, RaiseLine.Name); ObjParams := GetFigureParams(RaiseLine.ID); RaiseLine.Name := ObjParams.Name; RaiseLine.FIndex := ObjParams.MarkID; RaiseLine.FIsRaiseUpDown := True; RaiseLine.FObjectFromRaisedLine := APointObject; if RaiseUp then begin RaiseLine.FLineRaiseType := lrt_Up end else begin RaiseLine.FLineRaiseType := lrt_Down; end; //RaiseLine.FLineRaiseType := GetRaiseType(APointObject, RaiseConn); // тут как-то не очень ... RaiseConn.LockMove := True; RaiseConn.LockModify := True; RaiseLine.LockMove := False; RaiseLine.LockModify := True; ConnectedConn.LockMove := True; ConnectedConn.LockModify := True; //aPointObject.FObjectFromRaise := RaiseConn; RaiseConn.FObjectFromRaise := aPointObject; // Tolik if (TConnectorObject(APointObject).Radius > 10000000) and ((APointObject.Radius - 11000000) <> 999) and ((APointObject.Radius - 11000000) <> 0) then begin RaiseHeight := (APointObject.Radius - 11000000); RaiseHeight := UOMToMetre(RaiseHeight); if RaiseConn.FConnRaiseType = crt_OnFloor then begin SetRaiseHeight := ObjFromRaise.ActualZOrder[1] + RaiseHeight; if SetRaiseHeight > GCadForm.FRoomHeight then SetRaiseHeight := GCadForm.FRoomHeight; if SetRaiseHeight = ObjFromRaise.ActualZOrder[1] then begin if ObjFromRaise.ConnectorType = ct_Clear then DestroyRaiseOnConnector(ObjFromRaise) else DestroyRaiseOnPointObject(ObjFromRaise); end else begin RaiseConn.ActualZOrder[1] := SetRaiseHeight; SetConFigureCoordZInPM(RaiseConn.ID, RaiseConn.ActualZOrder[1]); end; end else // BetweenFloor begin SetRaiseHeight := RaiseConn.ActualZOrder[1] - RaiseHeight; if SetRaiseHeight < 0 then SetRaiseHeight := 0; if SetRaiseHeight > GCadForm.FRoomHeight then SetRaiseHeight := GCadForm.FRoomHeight; if SetRaiseHeight = RaiseConn.ActualZOrder[1] then begin if ObjFromRaise.ConnectorType = ct_Clear then DestroyRaiseOnConnector(ObjFromRaise) else DestroyRaiseOnPointObject(ObjFromRaise); end else begin ObjFromRaise.ActualZOrder[1] := SetRaiseHeight; SetConFigureCoordZInPM(ObjFromRaise.ID, ObjFromRaise.ActualZOrder[1]); end; end; end; RaiseLine.CalculLength := RaiseLine.LengthCalc; RaiseLine.LineLength := RaiseLine.CalculLength; SetLineFigureLengthInPM(RaiseLine.ID, RaiseLine.LineLength); RaiseLine.ReCreateCaptionsGroup(True, false); RaiseLine.UpdateLengthTextBox(True, false); RaiseLine.ReCreateNotesGroup(True); // *** for i := 0 to RaiseConn.JoinedOrtholinesList.Count - 1 do begin JoinedLine := TOrthoLine(RaiseConn.JoinedOrtholinesList[i]); if JoinedLine <> RaiseLine then begin JoinedLine.CalculLength := JoinedLine.LengthCalc; JoinedLine.LineLength := JoinedLine.CalculLength; SetLineFigureLengthInPM(JoinedLine.ID, JoinedLine.LineLength); JoinedLine.UpdateLengthTextBox(True, false); JoinedLine.ReCreateDrawFigureBlock; end; end; SetConnBringToFront(APointObject); SetConnBringToFront(RaiseConn); RefreshCAD(GCadForm.PCad); SetNewObjectNameInPM(RaiseConn.ID, RaiseConn.Name); {**************************************************************************} RaiseConn := GetRaiseConn(APointObject); if RaiseConn <> nil then AutoConnectOverRaiseInCAD(APointObject, RaiseConn); {**************************************************************************} except on E: Exception do addExceptionToLogEx('U_Common.CreateRaiseOnPointObject', E.Message); end; BaseEndUpdate; end; // СОЗДАТЬ С-П НА ОБЪЕКТЕ procedure CreateRaiseOnPointObject(APointObject: TConnectorObject; AHeight: Double; aBaseConnector: TConnectorObject = nil); var ConnectedConn: TConnectorObject; RaiseConn: TConnectorObject; RaiseLine: TOrthoLine; x, y, z: double; i: integer; JoinedLine: TOrthoLine; JoinedConn: TConnectorObject; JoinedConnBase: TConnectorObject; ObjParams: TObjectParams; TempRaisedConnectors: TList; CurIndex: Integer; //Tolik SetRaiseHeight: Double; RaiseHeight: Double; ObjFromRaise: TConnectorObject; TraceList: TList; SnapGrids,SnapGuides: Boolean; function GetTraceList: TList; var i, j : Integer; begin Result := TList.Create; if aPointObject.ConnectorType = ct_NB then begin for i := 0 to aPointObject.JoinedConnectorsList.Count - 1 do begin for j := 0 to TConnectorObject(aPointObject.JoinedConnectorsList[i]).JoinedOrthoLinesList.Count - 1 do begin if Result.IndexOf(TOrthoLine(TConnectorObject(aPointObject.JoinedConnectorsList[i]).JoinedOrthoLinesList[j])) = -1 then Result.Add(TOrthoLine(TConnectorObject(aPointObject.JoinedConnectorsList[i]).JoinedOrthoLinesList[j])); end; end; end; if Result.Count = 0 then begin FreeAndNil(Result); Result := Nil; // на всякий end; end; begin BaseBeginUpdate; TempRaisedConnectors := nil; // Tolik 22/01/2021 -- try if CheckJoinVertical(APointObject, aHeight) then begin //TraceList := GetTraceList; TraceList := Nil; PutObjectOnHeight(APointObject, AHeight, TraceList); BaseEndUpdate; if TraceList <> nil then FreeAndNil(TraceList); exit; end; x := APointObject.ActualPoints[1].x; y := APointObject.ActualPoints[1].y; // Tolik // z := APointObject.ActualZOrder[1]; if TConnectorObject(APointObject).Radius > 10000000 then //if TConnectorObject(APointObject).Radius > 11000000 then begin if (TConnectorObject(APointObject).Radius - 11000000) <> 999 then z := TConnectorObject(APointObject).Radius - 11000000 else z := APointObject.ActualZOrder[1]; end else z := APointObject.ActualZOrder[1]; // создать присоединенный коннектор ConnectedConn := TConnectorObject.Create(x, y, AHeight, APointObject.LayerHandle, mydsNormal, GCadForm.PCad); ConnectedConn.ConnectorType := ct_Clear; GCadForm.PCad.AddCustomFigure (GLN(APointObject.LayerHandle), ConnectedConn, False); ConnectedConn.Name := cCadClasses_Mes12; SetNewObjectNameInPM(ConnectedConn.ID, ConnectedConn.Name); ObjParams := GetFigureParams(ConnectedConn.ID); ConnectedConn.Name := ObjParams.Name; ConnectedConn.FIndex := ObjParams.MarkID; APointObject.ActualZOrder[1] := AHeight; for i := 0 to APointObject.JoinedConnectorsList.Count - 1 do TConnectorObject(APointObject.JoinedConnectorsList[i]).ActualZOrder[1] := APointObject.ActualZOrder[1]; SetConFigureCoordZInPM(APointObject.ID, APointObject.ActualZOrder[1]); // создать подъем-спуск коннектор RaiseConn := TConnectorObject.Create(x + 10, y - 10, z, APointObject.LayerHandle, mydsNormal, GCadForm.PCad); RaiseConn.ConnectorType := ct_Clear; // создать подъем-спуск линия RaiseLine := TOrthoLine.Create(x, y, AHeight, x + 10, y - 10, z, 1,ord(psSolid), clBlack, 0, APointObject.LayerHandle, mydsNormal, GCadForm.PCad, False); RaiseLine.SetJConnector1(TConnectorObject(ConnectedConn)); RaiseLine.SetJConnector2(TConnectorObject(RaiseConn)); // Tolik RaiseLine.ActualZOrder[1] := ConnectedConn.ActualZOrder[1]; // RaiseLine.ActualZOrder[2] := RaiseConn.ActualZOrder[1]; if TConnectorObject(APointObject).Radius > 10000000 then begin if ((APointObject.Radius - 11000000) <> 999) and ( (APointObject.Radius - 11000000) <> 0) then RaiseLine.ActualZOrder[2] := APointObject.Radius - 11000000 else RaiseLine.ActualZOrder[2] := RaiseConn.ActualZOrder[1]; end else RaiseLine.ActualZOrder[2] := RaiseConn.ActualZOrder[1]; // SetLineFigureCoordZInPM(RaiseLine.ID, 1, RaiseLine.ActualZOrder[1]); SetLineFigureCoordZInPM(RaiseLine.ID, 2, RaiseLine.ActualZOrder[2]); //Tolik 13/04/2017 -- RaiseConn.MoveConnector(APointOBject.ActualPoints[1].x - RaiseConn.ActualPoints[1].x, APointOBject.ActualPoints[1].y - RaiseConn.ActualPoints[1].y, False); // // // приконнектить подъем SnapConnectorToPointObject(ConnectedConn, APointObject, true); // Tolik RaiseLine.ActualZOrder[1] := APointObject.ActualZOrder[1]; TConnectorObject(RaiseLine.JoinConnector1).ActualZOrder[1] := APointObject.ActualZOrder[1]; // RaiseLine.ActualZOrder[2] := RaiseConn.ActualZOrder[1]; { if TConnectorObject(APointObject).Radius > 10000000 then if (APointObject.Radius - 11000000) <> 999 then RaiseLine.ActualZOrder[2] := APointO;bject.Radius - 11000000 else RaiseLine.ActualZOrder[2] := RaiseConn.ActualZOrder[1];} //else // RaiseLine.ActualZOrder[2] := RaiseConn.ActualZOrder[1];} // //Tolik 13/04/2017 -- //RaiseConn.MoveConnector(-10, 10, False); // // СОЗДАТЬ НА КАД =========================================== GCadForm.PCad.AddCustomFigure (GLN(APointObject.LayerHandle), RaiseConn, False); RaiseConn.Name := cCadClasses_Mes24; // ??? RaiseConn.FConnRaiseType := crt_OnFloor; RaiseConn.FObjectFromRaise := APointObject; SetNewObjectNameInPM(RaiseConn.ID, RaiseConn.Name); ObjParams := GetFigureParams(RaiseConn.ID); RaiseConn.Name := ObjParams.Name; RaiseConn.FIndex := ObjParams.MarkID; GCadForm.PCad.AddCustomFigure (GLN(APointObject.LayerHandle), RaiseLine, False); RaiseLine.Name := cCadClasses_Mes25; SetNewObjectNameInPM(RaiseLine.ID, RaiseLine.Name); ObjParams := GetFigureParams(RaiseLine.ID); RaiseLine.Name := ObjParams.Name; RaiseLine.FIndex := ObjParams.MarkID; RaiseLine.FIsRaiseUpDown := True; RaiseLine.FObjectFromRaisedLine := APointObject; RaiseLine.FLineRaiseType := GetRaiseType(APointObject, RaiseConn); RaiseConn.LockMove := True; RaiseConn.LockModify := True; RaiseLine.LockMove := False; RaiseLine.LockModify := True; ConnectedConn.LockMove := True; ConnectedConn.LockModify := True; // переподсоединить трассы к подъему TempRaisedConnectors := TList.Create; // небыло прямой привязки коннектора к ТО // Tolik --13/04/2016 -- // тут немножко переделаем совсем, чтобы все трассы коннектора, брошенного на точечный объект // могли приконнектиться к вершине С/П на нужной высоте { if aBaseConnector = nil then begin for i := 0 to APointObject.JoinedConnectorsList.Count - 1 do begin JoinedConn := TConnectorObject(APointObject.JoinedConnectorsList[i]); if JoinedConn <> ConnectedConn then TempRaisedConnectors.Add(JoinedConn); end; end else // непосредственно привязка коннектора к ТО begin TempRaisedConnectors.Add(aBaseConnector); end; } //if aBaseConnector = nil then //begin for i := 0 to APointObject.JoinedConnectorsList.Count - 1 do begin JoinedConn := TConnectorObject(APointObject.JoinedConnectorsList[i]); if JoinedConn <> ConnectedConn then TempRaisedConnectors.Add(JoinedConn); end; //end //else {if aBaseConnector <> nil then // непосредственно привязка коннектора к ТО begin TempRaisedConnectors.Add(aBaseConnector); end; } // // отвязка for i := 0 to TempRaisedConnectors.Count - 1 do begin JoinedConn := TConnectorObject(TempRaisedConnectors[i]); UnsnapConnectorFromPointObject(JoinedConn, APointObject, true); end; // перепривязка к вершине CurIndex := TempRaisedConnectors.Count - 1; // вязать без сортировок if aBaseConnector = nil then begin for i := CurIndex downto 0 do begin JoinedConn := TConnectorObject(TempRaisedConnectors[i]); // IGOR 2017-06-26 //Баг - искривляется трасса если включено привязка к сетке или к направляюшим и РМ и трасса на разных высотах //см. ReAlignLine(Self); // ReAlignObject(Self); // фикс бага - запомним - сбросим - и затем вернем флажки привязки if GCadform.PCad.SnapToGrids then SnapGrids := True else SnapGrids := False; if GCadform.PCad.SnapToGuides then SnapGuides := True else SnapGuides := False; //------------------------------------ GCadform.PCad.SnapToGrids := false; GCadform.PCad.SnapToGuides := false; // Tolik 18/04/2017 -- здесь выровняем по коннектору райза, чтобы не двинулся второй край райза // все равно остальные коннекторы нужны, чтобы ортолинии у них перенять, а потом будут удалены ... JoinedConn.Move(RaiseConn.ActualPoints[1].x - JoinedConn.ActualPoints[1].x, RaiseConn.ActualPoints[1].y - JoinedConn.ActualPoints[1].y); if SnapGrids then GCadform.PCad.SnapToGrids := True; if SnapGuides then GCadform.PCad.SnapToGuides := True; //Tolik -- 29/03/2018 -- //JoinedConn := SnapConnectorToConnector(JoinedConn, RaiseConn, true); CheckingSnapConnectorToConnector(JoinedConn, RaiseConn); // RaiseConn := JoinedConn; end; end else // с учтом того что должен остаться текущий коннектор, который сейчас Move begin for i := 0 to TempRaisedConnectors.Count - 1 do begin JoinedConn := TConnectorObject(TempRaisedConnectors[i]); if JoinedConn <> aBaseConnector then begin // Tolik 29/03/2018 -- //JoinedConn := SnapConnectorToConnector(JoinedConn, RaiseConn, true); CheckingSnapConnectorToConnector(JoinedConn, RaiseConn); // RaiseConn := JoinedConn; end; end; //Tolik 29/03/2018 -- //aBaseConnector := SnapConnectorToConnector(aBaseConnector, RaiseConn, true); CheckingSnapConnectorToConnector(aBaseConnector, RaiseConn); // RaiseConn := aBaseConnector; end; if TempRaisedConnectors <> nil then FreeAndNil(TempRaisedConnectors); // Tolik if (TConnectorObject(APointObject).Radius > 10000000) and ((APointObject.Radius - 11000000) <> 999) and ((APointObject.Radius - 11000000) <> 0) then begin RaiseHeight := (APointObject.Radius - 11000000); RaiseHeight := UOMToMetre(RaiseHeight); if RaiseConn.FConnRaiseType = crt_OnFloor then begin SetRaiseHeight := ObjFromRaise.ActualZOrder[1] + RaiseHeight; if SetRaiseHeight > GCadForm.FRoomHeight then SetRaiseHeight := GCadForm.FRoomHeight; if SetRaiseHeight = ObjFromRaise.ActualZOrder[1] then begin if ObjFromRaise.ConnectorType = ct_Clear then DestroyRaiseOnConnector(ObjFromRaise) else DestroyRaiseOnPointObject(ObjFromRaise); end else begin RaiseConn.ActualZOrder[1] := SetRaiseHeight; SetConFigureCoordZInPM(RaiseConn.ID, RaiseConn.ActualZOrder[1]); end; end else // BetweenFloor begin SetRaiseHeight := RaiseConn.ActualZOrder[1] - RaiseHeight; if SetRaiseHeight < 0 then SetRaiseHeight := 0; if SetRaiseHeight > GCadForm.FRoomHeight then SetRaiseHeight := GCadForm.FRoomHeight; if SetRaiseHeight = RaiseConn.ActualZOrder[1] then begin if ObjFromRaise.ConnectorType = ct_Clear then DestroyRaiseOnConnector(ObjFromRaise) else DestroyRaiseOnPointObject(ObjFromRaise); end else begin ObjFromRaise.ActualZOrder[1] := SetRaiseHeight; SetConFigureCoordZInPM(ObjFromRaise.ID, ObjFromRaise.ActualZOrder[1]); end; end; end; RaiseLine.CalculLength := RaiseLine.LengthCalc; RaiseLine.LineLength := RaiseLine.CalculLength; SetLineFigureLengthInPM(RaiseLine.ID, RaiseLine.LineLength); RaiseLine.ReCreateCaptionsGroup(True, false); RaiseLine.UpdateLengthTextBox(True, false); RaiseLine.ReCreateNotesGroup(True); // *** for i := 0 to RaiseConn.JoinedOrtholinesList.Count - 1 do begin JoinedLine := TOrthoLine(RaiseConn.JoinedOrtholinesList[i]); if JoinedLine <> RaiseLine then begin JoinedLine.CalculLength := JoinedLine.LengthCalc; JoinedLine.LineLength := JoinedLine.CalculLength; SetLineFigureLengthInPM(JoinedLine.ID, JoinedLine.LineLength); JoinedLine.UpdateLengthTextBox(True, false); JoinedLine.ReCreateDrawFigureBlock; end; end; SetConnBringToFront(APointObject); SetConnBringToFront(RaiseConn); RefreshCAD(GCadForm.PCad); SetNewObjectNameInPM(RaiseConn.ID, RaiseConn.Name); {**************************************************************************} RaiseConn := GetRaiseConn(APointObject); if RaiseConn <> nil then AutoConnectOverRaiseInCAD(APointObject, RaiseConn); {**************************************************************************} except on E: Exception do addExceptionToLogEx('U_Common.CreateRaiseOnPointObject', E.Message); end; BaseEndUpdate; end; // ИЗМЕНИТЬ С-П НА ОБЪЕКТЕ Procedure ChangeRaiseOnPointObject(APointObject: TConnectorObject; AHeight: Double); var RaiseConn: TConnectorObject; RaiseLine: TOrthoLine; i, j: integer; JoinedConn: TConnectorObject; JoinedLine: TOrthoLine; ObjParams: TObjectParams; begin BaseBeginUpdate; try JoinedLine := nil; RaiseLine := nil; RaiseConn := GetRaiseConn(APointObject); if RaiseConn <> nil then RaiseLine := GetRaiseLine(RaiseConn); // установить новые значения SetConFigureCoordZInPM(APointObject.ID, APointObject.ActualZOrder[1]); // совпадает с с-п, удалить с-п if RaiseConn.ActualZOrder[1] = AHeight then begin AutoDisconnectOverRaiseInCAD(APointObject, RaiseConn, RaiseLine); //#From Oleg# if RaiseConn <> nil then begin if RaiseConn.ConnectorType = ct_Clear then RemoveRMWithClear(APointObject, RaiseConn) else RemoveRMWithRM(APointObject, RaiseConn); end; end else // изменить высоту begin // установить новые значения APointObject.ActualZOrder[1] := AHeight; SetConnBringToFront(APointObject); for i := 0 to APointObject.JoinedConnectorsList.Count - 1 do begin JoinedConn := APointObject.JoinedConnectorsList[i]; JoinedConn.ActualZOrder[1] := APointObject.ActualZOrder[1]; for j := 0 to JoinedConn.JoinedOrtholinesList.Count - 1 do begin JoinedLine := JoinedConn.JoinedOrtholinesList[j]; if JoinedLine.JoinConnector1 = JoinedConn then begin SetLineFigureCoordZInPM(JoinedLine.ID, 1, APointObject.ActualZOrder[1]); JoinedLine.ActualZOrder[1] := APointObject.ActualZOrder[1]; end; if JoinedLine.JoinConnector2 = JoinedConn then begin SetLineFigureCoordZInPM(JoinedLine.ID, 2, APointObject.ActualZOrder[1]); JoinedLine.ActualZOrder[2] := APointObject.ActualZOrder[1]; end; end; SetConFigureCoordZInPM(JoinedConn.ID, JoinedConn.ActualZOrder[1]); if JoinedLine <> nil then begin JoinedLine.CalculLength := JoinedLine.LengthCalc; JoinedLine.LineLength := JoinedLine.CalculLength; SetLineFigureLengthInPM(JoinedLine.ID, JoinedLine.LineLength); // Обновить поле длинны для ортолинии JoinedLine.UpdateLengthTextBox(false, true); end; end; // подъем-спуск // Tolik 17/12/2020 -- if RaiseLine <> nil then begin if not RaiseLine.Deleted then begin // RaiseLine.FLineRaiseType := GetRaiseType(APointObject, RaiseConn); // RaiseLine.ReCreateCaptionsGroup(True, true); RaiseLine.UpdateLengthTextBox(True, true); RaiseLine.ReCreateNotesGroup(True); end; end; SetConFigureCoordZInPM(APointObject.ID, AHeight); end; RefreshCAD(GCadForm.PCad); except on E: Exception do addExceptionToLogEx('U_Common.ChangeRaiseOnPointObject', E.Message); end; BaseEndUpdate; end; // СОЗДАТЬ ОБЪЕКТ НА СОЕДИНИТЕЛЕ //Tolik -- 05/04/2018-- // старая закомменчена -- смотри ниже Procedure CreateRaiseOnConnector(AConnector: TConnectorObject; AHeight: Double); var ConnectedConn: TConnectorObject; RaiseConn: TConnectorObject; RaiseLine: TOrthoLine; x, y, z: double; i: integer; JoinedLine: TOrthoLine; JoinedConn: TConnectorObject; ObjParams: TObjectParams; RaiseUP: Boolean; // направление райза (если вверх = оставляем как есть, если вниз -- меняем коннекторы ) begin BaseBeginUpdate; try if CheckJoinVertical(AConnector, aHeight) then begin PutObjectOnHeight(AConnector, AHeight); BaseEndUpdate; exit; end; if CompareValue(AConnector.ActualZOrder[1], aHeight) = 0 then begin BaseEndUpdate; exit; end; RaiseUP := (CompareValue(AConnector.ActualZOrder[1], aHeight) = -1); x := AConnector.ActualPoints[1].x; y := AConnector.ActualPoints[1].y; z := AConnector.ActualZOrder[1]; // создать подъем-спуск коннектор RaiseConn := TConnectorObject.Create(x, y, AHeight, AConnector.LayerHandle, mydsNormal, GCadForm.PCad); RaiseConn.ConnectorType := ct_Clear; // создать подъем-спуск линия RaiseLine := TOrthoLine.Create(x, y, AHeight, x, y, z, 1,ord(psSolid), clBlack, 0, AConnector.LayerHandle, mydsNormal, GCadForm.PCad, False); RaiseLine.SetJConnector1(TConnectorObject(AConnector)); RaiseLine.SetJConnector2(TConnectorObject(RaiseConn)); //RaiseLine.ActualZOrder[1] := AConnector.ActualZOrder[1]; //RaiseLine.ActualZOrder[2] := RaiseConn.ActualZOrder[1]; SetLineFigureCoordZInPM(RaiseLine.ID, 1, RaiseLine.ActualZOrder[1]); SetLineFigureCoordZInPM(RaiseLine.ID, 2, RaiseLine.ActualZOrder[2]); // СОЗДАТЬ НА КАД =========================================== GCadForm.PCad.AddCustomFigure (GLN(AConnector.LayerHandle), RaiseConn, False); {if RaiseUP then begin RaiseConn.Name := cCadClasses_Mes24; RaiseConn.FConnRaiseType := crt_OnFloor; RaiseConn.FObjectFromRaise := AConnector; RaiseConn.FConnRaiseType := crt_OnFloor; RaiseConn.FObjectFromRaise := AConnector; end else} begin AConnector.Name := cCadClasses_Mes24; SetNewObjectNameInPM(AConnector.ID, AConnector.Name); AConnector.FConnRaiseType := crt_OnFloor; AConnector.FObjectFromRaise := RaiseConn; RaiseConn.Name := cCadClasses_Mes12; end; SetNewObjectNameInPM(RaiseConn.ID, RaiseConn.Name); ObjParams := GetFigureParams(RaiseConn.ID); RaiseConn.Name := ObjParams.Name; RaiseConn.FIndex := ObjParams.MarkID; GCadForm.PCad.AddCustomFigure (GLN(AConnector.LayerHandle), RaiseLine, False); RaiseLine.Name := cCadClasses_Mes25; SetNewObjectNameInPM(RaiseLine.ID, RaiseLine.Name); ObjParams := GetFigureParams(RaiseLine.ID); RaiseLine.Name := ObjParams.Name; RaiseLine.FIndex := ObjParams.MarkID; RaiseLine.FIsRaiseUpDown := True; //RaiseLine.FObjectFromRaisedLine := AConnector; //основа райза if RaiseUP then //RaiseLine.FLineRaiseType := GetRaiseType(AConnector, RaiseConn); begin RaiseLine.FLineRaiseType := lrt_UP; //RaiseLine.FObjectFromRaisedLine := AConnector; RaiseLine.FObjectFromRaisedLine := RaiseConn; end else begin RaiseLine.FLineRaiseType := lrt_DOWN; RaiseLine.FObjectFromRaisedLine := RaiseConn; end; RaiseLine.CalculLength := RaiseLine.LengthCalc; RaiseLine.LineLength := RaiseLine.CalculLength; SetLineFigureLengthInPM(RaiseLine.ID, RaiseLine.LineLength); RaiseLine.ReCreateCaptionsGroup(True, false); RaiseLine.UpdateLengthTextBox(True, false); RaiseLine.ReCreateNotesGroup(True); // *** if RaiseUP then begin for i := 0 to RaiseConn.JoinedOrtholinesList.Count - 1 do begin JoinedLine := TOrthoLine(RaiseConn.JoinedOrtholinesList[i]); if JoinedLine <> RaiseLine then begin JoinedLine.CalculLength := JoinedLine.LengthCalc; JoinedLine.LineLength := JoinedLine.CalculLength; SetLineFigureLengthInPM(JoinedLine.ID, JoinedLine.LineLength); JoinedLine.UpdateLengthTextBox(True, false); JoinedLine.ReCreateDrawFigureBlock; end; end; end; RaiseConn.LockMove := True; RaiseConn.LockModify := True; RaiseLine.LockMove := False; RaiseLine.LockModify := True; SetConnBringToFront(AConnector); SetConnBringToFront(RaiseConn); RefreshCAD(GCadForm.PCad); {**************************************************************************} RaiseConn := GetRaiseConn(AConnector); if RaiseConn <> nil then AutoConnectOverRaiseInCAD(AConnector, RaiseConn); except on E: Exception do addExceptionToLogEx('U_Common.CreateRaiseOnConnector', E.Message); end; BaseEndUpdate; end; (* Procedure CreateRaiseOnConnector(AConnector: TConnectorObject; AHeight: Double); var ConnectedConn: TConnectorObject; RaiseConn: TConnectorObject; RaiseLine: TOrthoLine; x, y, z: double; i: integer; JoinedLine: TOrthoLine; JoinedConn: TConnectorObject; ObjParams: TObjectParams; begin BaseBeginUpdate; try if CheckJoinVertical(AConnector, aHeight) then begin PutObjectOnHeight(AConnector, AHeight); BaseEndUpdate; exit; end; x := AConnector.ActualPoints[1].x; y := AConnector.ActualPoints[1].y; z := AConnector.ActualZOrder[1]; // создать подъем-спуск коннектор RaiseConn := TConnectorObject.Create(x, y, AHeight, AConnector.LayerHandle, mydsNormal, GCadForm.PCad); RaiseConn.ConnectorType := ct_Clear; // создать подъем-спуск линия RaiseLine := TOrthoLine.Create(x, y, AHeight, x, y, z, 1,ord(psSolid), clBlack, 0, AConnector.LayerHandle, mydsNormal, GCadForm.PCad, False); RaiseLine.SetJConnector1(TConnectorObject(AConnector)); RaiseLine.SetJConnector2(TConnectorObject(RaiseConn)); RaiseLine.ActualZOrder[1] := AConnector.ActualZOrder[1]; RaiseLine.ActualZOrder[2] := RaiseConn.ActualZOrder[1]; SetLineFigureCoordZInPM(RaiseLine.ID, 1, RaiseLine.ActualZOrder[1]); SetLineFigureCoordZInPM(RaiseLine.ID, 2, RaiseLine.ActualZOrder[2]); // СОЗДАТЬ НА КАД =========================================== GCadForm.PCad.AddCustomFigure (GLN(AConnector.LayerHandle), RaiseConn, False); RaiseConn.Name := cCadClasses_Mes24; SetNewObjectNameInPM(RaiseConn.ID, RaiseConn.Name); ObjParams := GetFigureParams(RaiseConn.ID); RaiseConn.Name := ObjParams.Name; RaiseConn.FIndex := ObjParams.MarkID; GCadForm.PCad.AddCustomFigure (GLN(AConnector.LayerHandle), RaiseLine, False); RaiseLine.Name := cCadClasses_Mes25; SetNewObjectNameInPM(RaiseLine.ID, RaiseLine.Name); ObjParams := GetFigureParams(RaiseLine.ID); RaiseLine.Name := ObjParams.Name; RaiseLine.FIndex := ObjParams.MarkID; RaiseConn.FConnRaiseType := crt_OnFloor; RaiseConn.FObjectFromRaise := AConnector; RaiseLine.FIsRaiseUpDown := True; RaiseLine.FObjectFromRaisedLine := AConnector; RaiseLine.FLineRaiseType := GetRaiseType(AConnector, RaiseConn); RaiseLine.CalculLength := RaiseLine.LengthCalc; RaiseLine.LineLength := RaiseLine.CalculLength; SetLineFigureLengthInPM(RaiseLine.ID, RaiseLine.LineLength); RaiseLine.ReCreateCaptionsGroup(True, false); RaiseLine.UpdateLengthTextBox(True, false); RaiseLine.ReCreateNotesGroup(True); // *** for i := 0 to RaiseConn.JoinedOrtholinesList.Count - 1 do begin JoinedLine := TOrthoLine(RaiseConn.JoinedOrtholinesList[i]); if JoinedLine <> RaiseLine then begin JoinedLine.CalculLength := JoinedLine.LengthCalc; JoinedLine.LineLength := JoinedLine.CalculLength; SetLineFigureLengthInPM(JoinedLine.ID, JoinedLine.LineLength); JoinedLine.UpdateLengthTextBox(True, false); JoinedLine.ReCreateDrawFigureBlock; end; end; RaiseConn.LockMove := True; RaiseConn.LockModify := True; RaiseLine.LockMove := False; RaiseLine.LockModify := True; SetConnBringToFront(AConnector); SetConnBringToFront(RaiseConn); RefreshCAD(GCadForm.PCad); {**************************************************************************} RaiseConn := GetRaiseConn(AConnector); if RaiseConn <> nil then AutoConnectOverRaiseInCAD(AConnector, RaiseConn); except on E: Exception do addExceptionToLogEx('U_Common.CreateRaiseOnConnector', E.Message); end; BaseEndUpdate; end; *) // ИЗМЕНИТЬ С-П НА СОЕДИНИТЕЛЕ Procedure ChangeRaiseOnConnector(AConnector: TConnectorObject; AHeight: Double); var RaiseConn: TConnectorObject; RaiseLine: TOrthoLine; i: integer; ObjParams: TObjectParams; begin BaseBeginUpdate; try RaiseLine := nil; if AConnector.FObjectFromRaise <> nil then RaiseConn := AConnector.FObjectFromRaise else RaiseConn := GetRaiseConn(AConnector); if RaiseConn <> nil then RaiseLine := GetRaiseLine(RaiseConn); SetConFigureCoordZInPM(AConnector.ID, AConnector.ActualZOrder[1]); // совпадает с с-п, удалить с-п if RaiseConn.ActualZOrder[1] = AHeight then begin AutoDisconnectOverRaiseInCAD(AConnector, RaiseConn, RaiseLine); //#From Oleg# RaiseConn.ActualZOrder[1] := AConnector.ActualZOrder[1]; AConnector.ActualZOrder[1] := AHeight; end else // изменить высоту begin // установить новые значения AConnector.ActualZOrder[1] := AHeight; SetConnBringToFront(AConnector); // подъем-спуск RaiseLine.FLineRaiseType := GetRaiseType(AConnector, RaiseConn); RaiseLine.CalculLength := RaiseLine.LengthCalc; RaiseLine.LineLength := RaiseLine.CalculLength; SetLineFigureLengthInPM(RaiseLine.ID, RaiseLine.LineLength); // RaiseLine.ReCreateCaptionsGroup(True, True); RaiseLine.UpdateLengthTextBox(True, true); RaiseLine.ReCreateNotesGroup(True); end; SetConFigureCoordZInPM(AConnector.ID, AHeight); RefreshCAD(GCadForm.PCad); except on E: Exception do addExceptionToLogEx('U_Common.ChangeRaiseOnConnector', E.Message); end; BaseEndUpdate; end; // АВТОСОЗДАВАТЬ НА ПРИЛЕГАЮЩИХ ТРАССАХ // Tolik -- 26/04/2016 -- // Procedure CreateRaiseOnNextObject(AConnector: TConnectorObject; AJoinedLine: TOrthoLine; AHeight: Double); Procedure CreateRaiseOnNextObject(AConnector: TConnectorObject; AJoinedLine: TOrthoLine; AHeight: Double; AtraceList: TList); // var PointObject: TConnectorObject; ConnectedConn: TConnectorObject; RaiseConn: TConnectorObject; RaiseLine: TOrthoLine; x, y, z: double; i: integer; JoinedLine: TOrthoLine; JoinedConn: TConnectorObject; NextConnector1, NextConnector2: TConnectorObject; ObjParams: TObjectParams; isDisconnected: Boolean; CurrLine: TOrthoLine; ResPointObject: TConnectorObject; ptrInterfRecord1, ptrInterfRecord2: PConnectObjectParam; ParamsList1, ParamsList2: TList; FirstRaiseLine: TOrthoLine; // Tolik CanSnapToVertical: Boolean; // begin // Tolik 09/02/2017 -- ParamsList1 := nil; ParamsList2 := nil; // BaseBeginUpdate; try if CheckJoinVertical(AConnector, aHeight) then begin // Tolik -- 26/04/2016 -- // PutObjectOnHeight(AConnector, AHeight); PutObjectOnHeight(AConnector, AHeight, ATraceList); // BaseEndUpdate; exit; end; {******************** СОЕДИНИТЕЛЬ *****************************************} if AConnector.JoinedConnectorsList.Count = 0 then begin x := AConnector.ActualPoints[1].x; y := AConnector.ActualPoints[1].y; z := AConnector.ActualZOrder[1]; // создать подъем-спуск коннектор RaiseConn := TConnectorObject.Create(x, y, AHeight, AConnector.LayerHandle, mydsNormal, GCadForm.PCad); RaiseConn.ConnectorType := ct_Clear; // создать подъем-спуск линия RaiseLine := TOrthoLine.Create(x, y, z, x, y, AHeight, 1,ord(psSolid), clBlack, 0, AConnector.LayerHandle, mydsNormal, GCadForm.PCad, False); RaiseLine.SetJConnector1(TConnectorObject(AConnector)); RaiseLine.SetJConnector2(TConnectorObject(RaiseConn)); RaiseLine.ActualZOrder[1] := AConnector.ActualZOrder[1]; RaiseLine.ActualZOrder[2] := RaiseConn.ActualZOrder[1]; SetLineFigureCoordZInPM(RaiseLine.ID, 1, RaiseLine.ActualZOrder[1]); SetLineFigureCoordZInPM(RaiseLine.ID, 2, RaiseLine.ActualZOrder[2]); // СОЗДАТЬ НА КАД =========================================== GCadForm.PCad.AddCustomFigure (GLN(AConnector.LayerHandle), RaiseConn, False); RaiseConn.Name := cCadClasses_Mes24; SetNewObjectNameInPM(RaiseConn.ID, RaiseConn.Name); ObjParams := GetFigureParams(RaiseConn.ID); RaiseConn.Name := ObjParams.Name; RaiseConn.FIndex := ObjParams.MarkID; GCadForm.PCad.AddCustomFigure (GLN(AConnector.LayerHandle), RaiseLine, False); RaiseLine.Name := cCadClasses_Mes25; SetNewObjectNameInPM(RaiseLine.ID, RaiseLine.Name); ObjParams := GetFigureParams(RaiseLine.ID); RaiseLine.Name := ObjParams.Name; RaiseLine.FIndex := ObjParams.MarkID; RaiseConn.FConnRaiseType := crt_OnFloor; RaiseConn.FObjectFromRaise := AConnector; RaiseLine.FIsRaiseUpDown := True; RaiseLine.FObjectFromRaisedLine := AConnector; RaiseLine.FLineRaiseType := GetRaiseType(AConnector, RaiseConn); RaiseLine.CalculLength := RaiseLine.LengthCalc; RaiseLine.LineLength := RaiseLine.CalculLength; SetLineFigureLengthInPM(RaiseLine.ID, RaiseLine.LineLength); RaiseLine.ReCreateCaptionsGroup(True, false); RaiseLine.UpdateLengthTextBox(True, false); RaiseLine.ReCreateNotesGroup(True); // *** for i := 0 to RaiseConn.JoinedOrtholinesList.Count - 1 do begin JoinedLine := TOrthoLine(RaiseConn.JoinedOrtholinesList[i]); if JoinedLine <> RaiseLine then begin JoinedLine.CalculLength := JoinedLine.LengthCalc; JoinedLine.LineLength := JoinedLine.CalculLength; SetLineFigureLengthInPM(JoinedLine.ID, JoinedLine.LineLength); JoinedLine.UpdateLengthTextBox(True, false); JoinedLine.ReCreateDrawFigureBlock; end; end; RaiseConn.LockMove := True; RaiseConn.LockModify := True; RaiseLine.LockMove := False; RaiseLine.LockModify := True; ParamsList1 := TList.create; ParamsList2 := TList.create; // переподсоединить if AJoinedLine.JoinConnector1 = AConnector then begin // New(ptrInterfRecord1); ptrInterfRecord1.IDObject := AJoinedLine.ID; ptrInterfRecord1.Side := 1; ParamsList1.Add(ptrInterfRecord1); // for i := 0 to AConnector.JoinedOrtholinesList.Count - 1 do begin CurrLine := TOrthoLine(AConnector.JoinedOrtholinesList[i]); if CurrLine <> AJoinedLine then begin New(ptrInterfRecord2); ptrInterfRecord2.IDObject := CurrLine.ID; if CurrLine.JoinConnector1 = AConnector then ptrInterfRecord2.Side := 1; if CurrLine.JoinConnector2 = AConnector then ptrInterfRecord2.Side := 2; ParamsList2.Add(ptrInterfRecord2); end; end; // TConnectorObject(AJoinedLine.JoinConnector1).JoinedOrtholinesList.Remove(AJoinedLine); AJoinedLine.SetJConnector1(TConnectorObject(RaiseConn)); AJoinedLine.ActualZOrder[1] := RaiseConn.ActualZOrder[1]; SetLineFigureCoordZInPM(AJoinedLine.ID, 1, AJoinedLine.ActualZOrder[1]); end; if AJoinedLine.JoinConnector2 = AConnector then begin // New(ptrInterfRecord1); ptrInterfRecord1.IDObject := AJoinedLine.ID; ptrInterfRecord1.Side := 2; ParamsList1.Add(ptrInterfRecord1); // for i := 0 to AConnector.JoinedOrtholinesList.Count - 1 do begin CurrLine := TOrthoLine(AConnector.JoinedOrtholinesList[i]); if CurrLine <> AJoinedLine then begin New(ptrInterfRecord2); ptrInterfRecord2.IDObject := CurrLine.ID; if CurrLine.JoinConnector1 = AConnector then ptrInterfRecord2.Side := 1; if CurrLine.JoinConnector2 = AConnector then ptrInterfRecord2.Side := 2; ParamsList2.Add(ptrInterfRecord2); end; end; // TConnectorObject(AJoinedLine.JoinConnector2).JoinedOrtholinesList.Remove(AJoinedLine); AJoinedLine.SetJConnector2(TConnectorObject(RaiseConn)); AJoinedLine.ActualZOrder[2] := RaiseConn.ActualZOrder[1]; SetLineFigureCoordZInPM(AJoinedLine.ID, 2, AJoinedLine.ActualZOrder[2]); end; SetConnBringToFront(AConnector); SetConnBringToFront(RaiseConn); ResPointObject := AConnector; end else {******************** ОБЪЕКТ **********************************************} begin PointObject := TConnectorObject(AConnector.JoinedConnectorsList[0]); x := PointObject.ActualPoints[1].x; y := PointObject.ActualPoints[1].y; z := PointObject.ActualZOrder[1]; RaiseConn := GetRaiseConn(PointObject); FirstRaiseLine := nil; if RaiseConn = Nil then begin // создать присоединенный коннектор ConnectedConn := TConnectorObject.Create(x, y, z, PointObject.LayerHandle, mydsNormal, GCadForm.PCad); ConnectedConn.ConnectorType := ct_Clear; GCadForm.PCad.AddCustomFigure (GLN(PointObject.LayerHandle), ConnectedConn, False); ConnectedConn.Name := cCadClasses_Mes12; SetNewObjectNameInPM(ConnectedConn.ID, ConnectedConn.Name); ObjParams := GetFigureParams(ConnectedConn.ID); ConnectedConn.Name := ObjParams.Name; ConnectedConn.FIndex := ObjParams.MarkID; // создать подъем-спуск коннектор RaiseConn := TConnectorObject.Create(x + 10, y - 10, AHeight, PointObject.LayerHandle, mydsNormal, GCadForm.PCad); RaiseConn.ConnectorType := ct_Clear; // создать подъем-спуск линия RaiseLine := TOrthoLine.Create(x, y, z, x + 10, y - 10, AHeight, 1,ord(psSolid), clBlack, 0, PointObject.LayerHandle, mydsNormal, GCadForm.PCad, False); RaiseLine.SetJConnector1(TConnectorObject(ConnectedConn)); RaiseLine.SetJConnector2(TConnectorObject(RaiseConn)); RaiseLine.ActualZOrder[1] := ConnectedConn.ActualZOrder[1]; RaiseLine.ActualZOrder[2] := RaiseConn.ActualZOrder[1]; SetLineFigureCoordZInPM(RaiseLine.ID, 1, AJoinedLine.ActualZOrder[1]); SetLineFigureCoordZInPM(RaiseLine.ID, 2, AJoinedLine.ActualZOrder[2]); //Tolik 19/04/2017 -- RaiseConn.MoveConnector(PointOBject.ActualPoints[1].x - RaiseConn.ActualPoints[1].x, PointOBject.ActualPoints[1].y - RaiseConn.ActualPoints[1].y, False); // // приконнектить подъем SnapConnectorToPointObject(ConnectedConn, PointObject, true); //RaiseConn.MoveConnector(-10, 10, False); // СОЗДАТЬ НА КАД =========================================== GCadForm.PCad.AddCustomFigure (GLN(PointObject.LayerHandle), RaiseConn, False); // ??? RaiseConn.FConnRaiseType := crt_OnFloor; RaiseConn.FObjectFromRaise := PointObject; RaiseConn.Name := cCadClasses_Mes24; SetNewObjectNameInPM(RaiseConn.ID, RaiseConn.Name); ObjParams := GetFigureParams(RaiseConn.ID); RaiseConn.Name := ObjParams.Name; RaiseConn.FIndex := ObjParams.MarkID; GCadForm.PCad.AddCustomFigure (GLN(PointObject.LayerHandle), RaiseLine, False); RaiseLine.Name := cCadClasses_Mes25; SetNewObjectNameInPM(RaiseLine.ID, RaiseLine.Name); ObjParams := GetFigureParams(RaiseLine.ID); RaiseLine.Name := ObjParams.Name; RaiseLine.FIndex := ObjParams.MarkID; RaiseLine.FIsRaiseUpDown := True; RaiseLine.FObjectFromRaisedLine := PointObject; RaiseLine.FLineRaiseType := GetRaiseType(PointObject, RaiseConn); RaiseLine.CalculLength := RaiseLine.LengthCalc; RaiseLine.LineLength := RaiseLine.CalculLength; SetLineFigureLengthInPM(RaiseLine.ID, RaiseLine.LineLength); RaiseLine.ReCreateCaptionsGroup(True, false); RaiseLine.UpdateLengthTextBox(True, false); RaiseLine.ReCreateNotesGroup(True); // *** for i := 0 to RaiseConn.JoinedOrtholinesList.Count - 1 do begin JoinedLine := TOrthoLine(RaiseConn.JoinedOrtholinesList[i]); if JoinedLine <> RaiseLine then begin JoinedLine.CalculLength := JoinedLine.LengthCalc; JoinedLine.LineLength := JoinedLine.CalculLength; SetLineFigureLengthInPM(JoinedLine.ID, JoinedLine.LineLength); JoinedLine.UpdateLengthTextBox(True, false); JoinedLine.ReCreateDrawFigureBlock; end; end; RaiseConn.LockMove := True; RaiseConn.LockModify := True; RaiseLine.LockMove := False; // Igor - не понятно зачем оно тут было (тем более после поднятия со стрима он всегда визибл) - пока закоментил // D0000006059 //RaiseLine.Visible := False; RaiseLine.LockModify := True; ConnectedConn.LockMove := True; ConnectedConn.LockModify := True; end else begin FirstRaiseLine := GetRaiseLine(RaiseConn); if (PointObject <> nil) and (FirstRaiseLine <> nil) then AutoDisconnectOverRaiseInCAD(PointObject, RaiseConn, FirstRaiseLine); //#From Oleg# end; // переподсоединить трассы к подъему UnsnapConnectorFromPointObject(AConnector, PointObject, true); //Tolik -- 29/03/2018 -- //AConnector := SnapConnectorToConnector(AConnector, RaiseConn, true); CheckingSnapConnectorToConnector(AConnector, RaiseConn); // //SnapConnectorToConnector(AConnector, RaiseConn); // SetConnBringToFront(PointObject); SetConnBringToFront(AConnector); ResPointObject := PointObject; end; RefreshCAD(GCadForm.PCad); {**************************************************************************} RaiseConn := GetRaiseConn(ResPointObject); // Tolik -- 24/05/2016 -- // чтобы не было лишних кабелей на райзе // ини добавятся потом на восстановлении соединения кабелей после поднятия/опускания трассы { if RaiseConn <> nil then AutoConnectOverRaiseInCAD(ResPointObject, RaiseConn); } {**************************************************************************} except on E: Exception do addExceptionToLogEx('U_Common.CreateRaiseOnNextObject', E.Message); end; BaseEndUpdate; // Tolik 09/02/2017 -- if ParamsList1 <> nil then begin for i := 0 to ParamsList1.Count - 1 do begin Dispose(PConnectObjectParam(ParamsList1[i])); end; FreeAndNil(ParamsList1); end; if ParamsList2 <> nil then begin for i := 0 to ParamsList2.Count - 1 do begin Dispose(PConnectObjectParam(ParamsList2[i])); end; FreeAndNil(ParamsList2); end; // end; // Tolik -- старая для истории -- не совсем удачный вариант // АВТОИЗМЕНЯТЬ ПОДЪЕМ НА ПРИЛЕГАЮЩИХ ОБЪЕТАХ (* Procedure ChangeRaiseOnNextObject(AConnector: TConnectorObject; AJoinedLine: TOrthoLine; AHeight: Double); var ObjectOnRaise: TConnectorObject; RaiseConn: TConnectorObject; RaiseLine: TOrthoLine; PointObject: TConnectorObject; JoinedConn: TConnectorObject; JoinedLine: TOrthoLine; i, j: integer; ObjParams: TObjectParams; NewConn: TConnectorObject; begin BaseBeginUpdate; try JoinedLine := nil; //#From Oleg# RaiseLine := nil; //#From Oleg# {************* СОЕДИНИТЕЛЬ ************************************************} if AConnector.JoinedConnectorsList.Count = 0 then begin if AConnector.FObjectFromRaise <> nil then RaiseConn := AConnector.FObjectFromRaise else RaiseConn := GetRaiseConn(AConnector); if RaiseConn <> nil then RaiseLine := GetRaiseLine(RaiseConn); // установить новые значения SetConFigureCoordZInPM(AConnector.ID, AConnector.ActualZOrder[1]); // совпадает с с-п, удалить с-п ------------------------------------------ if RaiseConn.ActualZOrder[1] = AHeight then begin AutoDisconnectOverRaiseInCAD(AConnector, RaiseConn, RaiseLine); //#From Oleg# NewConn := TConnectorObject.Create(RaiseConn.ActualPoints[1].x, RaiseConn.ActualPoints[1].y, RaiseConn.ActualZOrder[1], RaiseConn.LayerHandle, mydsNormal, GCadForm.PCad); NewConn.ConnectorType := ct_Clear; GCadForm.PCad.AddCustomFigure(2, NewConn, False); if AJoinedLine.JoinConnector1 = AConnector then AJoinedLine.SetJConnector1(NewConn); if AJoinedLine.JoinConnector2 = AConnector then AJoinedLine.SetJConnector2(NewConn); AConnector.JoinedOrtholinesList.Remove(AJoinedLine); if RaiseConn.ConnectorType = ct_Clear then SnapConnectorToConnector(NewConn, RaiseConn) else SnapConnectorToPointObject(NewConn, RaiseConn); AutoConnectOverRaiseInCAD(AConnector, RaiseConn); //#From Oleg# //AutoDisconnectOverRaiseInCAD(AConnector, RaiseConn, RaiseLine); //#From Oleg# end else // изменить высоту ------------------------------------------------------- begin // установить новые значения AConnector.ActualZOrder[1] := AHeight; SetConFigureCoordZInPM(AConnector.ID, AConnector.ActualZOrder[1]); SetConnBringToFront(AConnector); for i := 0 to AConnector.JoinedOrtholinesList.Count - 1 do begin JoinedLine := AConnector.JoinedOrtholinesList[i]; if JoinedLine.JoinConnector1 = AConnector then begin SetLineFigureCoordZInPM(JoinedLine.ID, 1, AConnector.ActualZOrder[1]); JoinedLine.ActualZOrder[1] := AConnector.ActualZOrder[1]; end; if JoinedLine.JoinConnector2 = AConnector then begin SetLineFigureCoordZInPM(JoinedLine.ID, 2, AConnector.ActualZOrder[1]); JoinedLine.ActualZOrder[2] := AConnector.ActualZOrder[1]; end; JoinedLine.CalculLength := JoinedLine.LengthCalc; JoinedLine.LineLength := JoinedLine.CalculLength; SetLineFigureLengthInPM(JoinedLine.ID, JoinedLine.LineLength); // Обновить поле длинны для ортолинии JoinedLine.UpdateLengthTextBox(false, true); end; // подъем-спуск RaiseLine.FLineRaiseType := GetRaiseType(AConnector, RaiseConn); // RaiseLine.ReCreateCaptionsGroup(True, false); RaiseLine.UpdateLengthTextBox(True, true); RaiseLine.ReCreateNotesGroup(True); SetConFigureCoordZInPM(AConnector.ID, AHeight); end; end else {************* ОБЪЕКТ *****************************************************} begin PointObject := TConnectorObject(AConnector.JoinedConnectorsList[0]); RaiseConn := GetRaiseConn(PointObject); if RaiseConn <> nil then RaiseLine := GetRaiseLine(RaiseConn); // установить новые значения PointObject.ActualZOrder[1] := AHeight; SetConFigureCoordZInPM(PointObject.ID, PointObject.ActualZOrder[1]); // совпадает с с-п, удалить с-п if RaiseConn.ActualZOrder[1] = AHeight then begin AutoDisconnectOverRaiseInCAD(AConnector, RaiseConn, RaiseLine); //#From Oleg# UnSnapConnectorFrompointObject(AConnector, PointObject); if RaiseConn.ConnectorType = ct_Clear then SnapConnectorToConnector(AConnector, RaiseConn) else SnapConnectorToPointObject(AConnector, RaiseConn); end else // изменить высоту begin SetConnBringToFront(PointObject); for i := 0 to PointObject.JoinedConnectorsList.Count - 1 do begin JoinedConn := PointObject.JoinedConnectorsList[i]; JoinedConn.ActualZOrder[1] := PointObject.ActualZOrder[1]; for j := 0 to JoinedConn.JoinedOrtholinesList.Count - 1 do begin JoinedLine := JoinedConn.JoinedOrtholinesList[j]; if JoinedLine.JoinConnector1 = JoinedConn then begin SetLineFigureCoordZInPM(JoinedLine.ID, 1, PointObject.ActualZOrder[1]); JoinedLine.ActualZOrder[1] := PointObject.ActualZOrder[1]; end; if JoinedLine.JoinConnector2 = JoinedConn then begin SetLineFigureCoordZInPM(JoinedLine.ID, 2, PointObject.ActualZOrder[1]); JoinedLine.ActualZOrder[2] := PointObject.ActualZOrder[1]; end; end; SetConFigureCoordZInPM(JoinedConn.ID, JoinedConn.ActualZOrder[1]); if JoinedLine <> nil then //#From Oleg# begin JoinedLine.CalculLength := JoinedLine.LengthCalc; JoinedLine.LineLength := JoinedLine.CalculLength; SetLineFigureLengthInPM(JoinedLine.ID, JoinedLine.LineLength); // Обновить поле длинны для ортолинии JoinedLine.UpdateLengthTextBox(false, true); end; end; // подъем-спуск RaiseLine.FLineRaiseType := GetRaiseType(PointObject, RaiseConn); // RaiseLine.ReCreateCaptionsGroup(True, false); RaiseLine.UpdateLengthTextBox(True, true); RaiseLine.ReCreateNotesGroup(True); SetConFigureCoordZInPM(PointObject.ID, AHeight); end; end; RefreshCAD(GCadForm.PCad); except on E: Exception do addExceptionToLogEx('U_Common.ChangeRaiseOnNextObject', E.Message); end; BaseEndUpdate; end; *) // Tolik 29/04/2016 -- передадим параметром трейслист для ориентации(что там поднимается, что - нет) Procedure ChangeRaiseOnNextObject(AConnector: TConnectorObject; AJoinedLine: TOrthoLine; AHeight: Double; aTracesList: TList); // Procedure ChangeRaiseOnNextObject(AConnector: TConnectorObject; AJoinedLine: TOrthoLine; AHeight: Double); var ObjectOnRaise: TConnectorObject; RaiseConn: TConnectorObject; RaiseLine: TOrthoLine; PointObject: TConnectorObject; JoinedConn: TConnectorObject; JoinedLine: TOrthoLine; i, j: integer; ObjParams: TObjectParams; NewConn: TConnectorObject; //Tolik -- 20/04/2016 -- NeedToCreateVerticalLine: Boolean; //вертикальная трасса между двумя точечными Procedure CreateVertTraceBetweenTwoPoints(Figure1, Figure2: TConnectorObject); Var VertOnFigure: TConnectorObject; VertHeight: Double; Begin try VertOnFigure := Figure1; if Figure2 <> nil then begin VertHeight := TConnectorObject(Figure2).ActualZOrder[1];//(abs(TConnectorObject(Figure1).ActualZOrder[1] - TConnectorObject(Figure2).ActualZOrder[1])); VertHeight := UOMToMetre(VertHeight); { if VertHeight > GCadForm.FRoomHeight then VertHeight := GCadForm.FRoomHeight;} CreateVerticalOnTwoPointObjects(TConnectorObject(Figure1), TConnectorObject(Figure2), VertHeight); // CreateVerticalOnPointObject(VertOnFigure, Figure2, VertHeight); if not GProjectChanged then // Tolik 28/08/2019 -- SetProjectChanged(True); end else GCadForm.mProtocol.Lines.Add(cMain_Mes128); except on E: Exception do AddExceptionToLogEx('U_Common.CreateVertTraceBetweenTwoPoints', E.Message); end; End; Function CheckNeedVertLine : Boolean; var RConn1, RConn2: TConnectorObject; i: Integer; RaiseLine: TOrthoLine; DirectionUp, DirectionDown: Boolean; begin Result := False; if ATracesList <> nil then begin DirectionUp := False; DirectionDown := False; for i := 0 to AConnector.JoinedOrtholinesList.Count - 1 do begin // if ATracesList.IndexOf(TOrthoLine(AConnector.JoinedOrtholinesList[i])) = -1 then // begin if ((Not TOrthoLine(AConnector.JoinedOrtholinesList[i]).FIsRaiseUpDown) and (Not TOrthoLine(AConnector.JoinedOrtholinesList[i]).FIsVertical)) then begin if (TOrthoLine(AConnector.JoinedOrthoLinesList[i]).Id <> aJoinedLine.ID) then begin Result := True; break; end; end; // end; end; if not Result then begin for i := 0 to AConnector.JoinedOrthoLinesList.Count - 1 do begin if TOrthoLine(AConnector.JoinedOrthoLinesList[i]).FisRaiseUPDown then begin Result := true; break; end end; end; end; //Result := True; end; begin BaseBeginUpdate; try // Tolik 05/05/2016 -- // если высота расположения коннектора равна высоте подъема - вываливаемся сразу if CompareValue(AConnector.ActualZOrder[1], aHeight) = 0 then begin BaseEndUpdate; Exit; end; JoinedLine := nil; //#From Oleg# RaiseLine := nil; //#From Oleg# {************* СОЕДИНИТЕЛЬ ************************************************} // Tolik 29/04/2016 -- if CheckNeedVertLine then begin PutObjectOnHeight(Aconnector, aHeight, ATracesList); BaseEndUpdate; exit; end; // if AConnector.JoinedConnectorsList.Count = 0 then begin if AConnector.FObjectFromRaise <> nil then RaiseConn := AConnector.FObjectFromRaise else RaiseConn := GetRaiseConn(AConnector); if RaiseConn <> nil then RaiseLine := GetRaiseLine(RaiseConn); // установить новые значения SetConFigureCoordZInPM(AConnector.ID, AConnector.ActualZOrder[1]); // совпадает с с-п, удалить с-п ------------------------------------------ if RaiseConn.ActualZOrder[1] = AHeight then begin AutoDisconnectOverRaiseInCAD(AConnector, RaiseConn, RaiseLine); //#From Oleg# NewConn := TConnectorObject.Create(RaiseConn.ActualPoints[1].x, RaiseConn.ActualPoints[1].y, RaiseConn.ActualZOrder[1], RaiseConn.LayerHandle, mydsNormal, GCadForm.PCad); NewConn.ConnectorType := ct_Clear; GCadForm.PCad.AddCustomFigure(2, NewConn, False); if AJoinedLine.JoinConnector1 = AConnector then AJoinedLine.SetJConnector1(NewConn); if AJoinedLine.JoinConnector2 = AConnector then AJoinedLine.SetJConnector2(NewConn); AConnector.JoinedOrtholinesList.Remove(AJoinedLine); if RaiseConn.ConnectorType = ct_Clear then // Tolik 29/03/2018 -- //NewConn := SnapConnectorToConnector(NewConn, RaiseConn) CheckingSnapConnectorToConnector(NewConn, RaiseConn) // else // Tolik 03/04/2018 -- //SnapConnectorToPointObject(NewConn, RaiseConn); CheckingSnapPointObjectToConnector(RaiseConn, NewConn, False, True); // // Tolik -- 30/09/2016-- //v AutoConnectOverRaiseInCAD(AConnector, RaiseConn); //#From Oleg# if (not AConnector.deleted) and (not RaiseConn.deleted) then AutoConnectOverRaiseInCAD(AConnector, RaiseConn); //#From Oleg# // //AutoDisconnectOverRaiseInCAD(AConnector, RaiseConn, RaiseLine); //#From Oleg# end else // изменить высоту ------------------------------------------------------- begin // установить новые значения AConnector.ActualZOrder[1] := AHeight; SetConFigureCoordZInPM(AConnector.ID, AConnector.ActualZOrder[1]); SetConnBringToFront(AConnector); for i := 0 to AConnector.JoinedOrtholinesList.Count - 1 do begin JoinedLine := AConnector.JoinedOrtholinesList[i]; if JoinedLine.JoinConnector1 = AConnector then begin SetLineFigureCoordZInPM(JoinedLine.ID, 1, AConnector.ActualZOrder[1]); JoinedLine.ActualZOrder[1] := AConnector.ActualZOrder[1]; end; if JoinedLine.JoinConnector2 = AConnector then begin SetLineFigureCoordZInPM(JoinedLine.ID, 2, AConnector.ActualZOrder[1]); JoinedLine.ActualZOrder[2] := AConnector.ActualZOrder[1]; end; JoinedLine.CalculLength := JoinedLine.LengthCalc; JoinedLine.LineLength := JoinedLine.CalculLength; SetLineFigureLengthInPM(JoinedLine.ID, JoinedLine.LineLength); // Обновить поле длинны для ортолинии JoinedLine.UpdateLengthTextBox(false, true); end; // подъем-спуск // Tolik -- 20/04/2016 -- if RaiseLine <> nil then begin // RaiseLine.FLineRaiseType := GetRaiseType(AConnector, RaiseConn); // RaiseLine.ReCreateCaptionsGroup(True, false); RaiseLine.UpdateLengthTextBox(True, true); RaiseLine.ReCreateNotesGroup(True); end; SetConFigureCoordZInPM(AConnector.ID, AHeight); end; end else {************* ОБЪЕКТ *****************************************************} begin PointObject := TConnectorObject(AConnector.JoinedConnectorsList[0]); RaiseConn := GetRaiseConn(PointObject); if RaiseConn <> nil then RaiseLine := GetRaiseLine(RaiseConn); //Tolik NeedToCreateVerticalLine := CheckNeedVertLine; // // установить новые значения PointObject.ActualZOrder[1] := AHeight; SetConFigureCoordZInPM(PointObject.ID, PointObject.ActualZOrder[1]); // совпадает с с-п, удалить с-п if RaiseConn.ActualZOrder[1] = AHeight then begin AutoDisconnectOverRaiseInCAD(AConnector, RaiseConn, RaiseLine); //#From Oleg# UnSnapConnectorFrompointObject(AConnector, PointObject); if RaiseConn.ConnectorType = ct_Clear then //Tolik 29/03/2018 -- //AConnector := SnapConnectorToConnector(AConnector, RaiseConn) CheckingSnapConnectorToConnector(AConnector, RaiseConn) // else // Tolik 03/04/2018 -- //SnapConnectorToPointObject(AConnector, RaiseConn); CheckingSnapPointObjectToConnector(RaiseConn, NewConn, False, True); // end else // изменить высоту begin SetConnBringToFront(PointObject); for i := 0 to PointObject.JoinedConnectorsList.Count - 1 do begin JoinedConn := PointObject.JoinedConnectorsList[i]; JoinedConn.ActualZOrder[1] := PointObject.ActualZOrder[1]; for j := 0 to JoinedConn.JoinedOrtholinesList.Count - 1 do begin JoinedLine := JoinedConn.JoinedOrtholinesList[j]; if JoinedLine.JoinConnector1 = JoinedConn then begin SetLineFigureCoordZInPM(JoinedLine.ID, 1, PointObject.ActualZOrder[1]); JoinedLine.ActualZOrder[1] := PointObject.ActualZOrder[1]; end; if JoinedLine.JoinConnector2 = JoinedConn then begin SetLineFigureCoordZInPM(JoinedLine.ID, 2, PointObject.ActualZOrder[1]); JoinedLine.ActualZOrder[2] := PointObject.ActualZOrder[1]; end; end; SetConFigureCoordZInPM(JoinedConn.ID, JoinedConn.ActualZOrder[1]); if JoinedLine <> nil then //#From Oleg# begin JoinedLine.CalculLength := JoinedLine.LengthCalc; JoinedLine.LineLength := JoinedLine.CalculLength; SetLineFigureLengthInPM(JoinedLine.ID, JoinedLine.LineLength); // Обновить поле длинны для ортолинии JoinedLine.UpdateLengthTextBox(false, true); end; end; // подъем-спуск // Tolik -- 20/04/2016 -- if RaiseLine <> nil then begin RaiseLine.FLineRaiseType := GetRaiseType(PointObject, RaiseConn); // RaiseLine.ReCreateCaptionsGroup(True, false); RaiseLine.UpdateLengthTextBox(True, true); RaiseLine.ReCreateNotesGroup(True); end; SetConFigureCoordZInPM(PointObject.ID, AHeight); end; end; RefreshCAD(GCadForm.PCad); except on E: Exception do addExceptionToLogEx('U_Common.ChangeRaiseOnNextObject', E.Message); end; BaseEndUpdate; end; (* // Tolik -- немножко переделано совсем ... // АВТОИЗМЕНЯТЬ ПОДЪЕМ НА ПРИЛЕГАЮЩИХ ОБЪЕТАХ Procedure ChangeRaiseOnNextObject(AConnector: TConnectorObject; AJoinedLine: TOrthoLine; AHeight: Double); var ObjectOnRaise: TConnectorObject; RaiseConn: TConnectorObject; RaiseLine: TOrthoLine; PointObject: TConnectorObject; JoinedConn: TConnectorObject; JoinedLine: TOrthoLine; i, j: integer; ObjParams: TObjectParams; NewConn: TConnectorObject; //Tolik ConnNumber: Integer; DownShift, UpShift: boolean; CanDelRaiseOnPointObject: Boolean; NextRaiseConn, PointObjConnector: TConnectorObject; // function CheckNeedVerticalTrace : Boolean; var i: Integer; begin Result := False; end; Function HasVerticalTraces : Boolean; var i: Integer; begin for i := 0 to AConnector.JoinedOrtholinesList.Count - 1 do begin if TOrthoLine(AConnector.JoinedOrtholinesList[i]).FIsVertical then begin Result := True; Break; //// BREAK ////; end; end; end; // begin BaseBeginUpdate; try JoinedLine := nil; //#From Oleg# RaiseLine := nil; //#From Oleg# {************* СОЕДИНИТЕЛЬ ************************************************} if AConnector.JoinedConnectorsList.Count = 0 then begin if AConnector.FObjectFromRaise <> nil then RaiseConn := AConnector.FObjectFromRaise else RaiseConn := GetRaiseConn(AConnector); if RaiseConn <> nil then RaiseLine := GetRaiseLine(RaiseConn); // Tolik if AConnector = AJoinedLine.JoinConnector1 then ConnNumber := 1 else if AConnector = AJoinedLine.JoinConnector2 then ConnNumber := 2; // // установить новые значения // Tolik // SetConFigureCoordZInPM(AConnector.ID, AConnector.ActualZOrder[1]); // AConnector.ActualZOrder[1] := AHeight; // в ПМ попадает, а в коннектор нужно поставить, иначе остается старое значение SetConFigureCoordZInPM(AConnector.ID, AHeight); // // совпадает с с-п, удалить с-п ------------------------------------------ if RaiseConn.ActualZOrder[1] = AHeight then begin //Tolik // удалить С/П if AConnector.JoinedOrtholinesList.Count < 3 then begin if RaiseLine <> nil then begin TOrthoLine(RaiseLine).Delete; RaiseLine := nil; end; // переопределить коннектор if ConnNumber = 1 then TOrthoLine(AJoinedLine).SetJConnector1(RaiseConn) else if ConnNumber = 2 then TOrthoLine(AJoinedLine).SetJConnector2(RaiseConn); if not AConnector.deleted then begin //переприсоединить линии for i := 0 to AConnector.JoinedOrtholinesList.Count - 1 do begin if TOrthoLine(AConnector.JoinedOrtholinesList[i]) <> nil then if RaiseConn.JoinedOrtholinesList.IndexOf(TOrthoLine(AConnector.JoinedOrtholinesList[i])) = -1 then begin if TOrthoLine(AConnector.JoinedOrtholinesList[i]) <> TOrthoLine(RaiseLine) then RaiseConn.JoinedOrtholinesList.Add(TOrthoLine(AConnector.JoinedOrtholinesList[i])); end; end; // коннектор удалять только после удаления с/п !!!!! обязательно if not AConnector.Deleted then AConnector.Delete(False, False); // может удалиться при удалении ортолинии, если к нему ничего не подключено end; AConnector := RaiseConn; // длины и высоты для присоединенных линий for I := 0 to AConnector.JoinedOrtholinesList.Count - 1 do begin // пересчитать длину линии (для всех на коннекторе) TOrtholine(AConnector.JoinedOrtholinesList[i]).CalculLength := TOrtholine(AConnector.JoinedOrtholinesList[i]).LengthCalc; TOrtholine(AConnector.JoinedOrtholinesList[i]).LineLength := TOrtholine(AConnector.JoinedOrtholinesList[i]).CalculLength; SetLineFigureLengthInPM(TOrtholine(AConnector.JoinedOrtholinesList[i]).ID, TOrtholine(AConnector.JoinedOrtholinesList[i]).LineLength); // Обновить поле длинны для ортолинии TOrtholine(AConnector.JoinedOrtholinesList[i]).UpdateLengthTextBox(false, true); // выставляем высоту края ортолинии (по коннектору) if TOrtholine(AConnector.JoinedOrtholinesList[i]).JoinConnector1 = AConnector then begin SetLineFigureCoordZInPM(TOrtholine(AConnector.JoinedOrtholinesList[i]).ID, 1, AConnector.ActualZOrder[1]); TOrtholine(AConnector.JoinedOrtholinesList[i]).ActualZOrder[1] := AConnector.ActualZOrder[1]; end else if TOrtholine(AConnector.JoinedOrtholinesList[i]).JoinConnector2 = AConnector then begin SetLineFigureCoordZInPM(TOrtholine(AConnector.JoinedOrtholinesList[i]).ID, 2, AConnector.ActualZOrder[1]); TOrtholine(AConnector.JoinedOrtholinesList[i]).ActualZOrder[2] := AConnector.ActualZOrder[1]; end; end; end else begin // переприсоединяем трассу AConnector.JoinedOrtholinesList.Remove(TOrthoLine(AJoinedLine)); // есть ли присоединенный точечный объхект PointObjConnector := nil; if RaiseConn.ConnectorType = ct_NB then PointObjConnector := RaiseConn else begin for i := 0 to RaiseConn.JoinedConnectorsList.Count - 1 do begin if TConnectorObject(RaiseConn.JoinedConnectorsList[i]).ConnectorType = ct_NB then begin PointObjConnector := TConnectorObject(RaiseConn.JoinedConnectorsList[i]); break; end; end; end; if PointObjConnector <> nil then begin // если есть точечный - создаем новый коннектор для ортолинии и присоединяем его к точечному RaiseConn := TConnectorObject.Create(PointObjConnector.ap1.x, PointObjConnector.ap1.y, PointObjConnector.ActualZOrder[1], PointObjConnector.LayerHandle, mydsNormal, PointObjConnector.Owner); RaiseConn.ConnectorType := ct_Clear; GCadForm.PCad.AddCustomFigure(2, RaiseConn, False); end; if AJoinedLine.JoinConnector1 = AConnector then AJoinedLine.SetJConnector1(RaiseConn) else if AJoinedLine.JoinConnector2 = AConnector then AJoinedLine.SetJConnector2(RaiseConn); if RaiseConn.JoinedOrtholinesList.IndexOf(TOrthoLine(AJoinedLine)) = -1 then RaiseConn.JoinedOrtholinesList.Add(AJoinedLine); AConnector := RaiseConn; // если есть точечный - связываем if PointObjConnector <> nil then begin if PointObjConnector.JoinedConnectorsList.IndexOf(AConnector) = -1 then PointObjConnector.JoinedConnectorsList.Add(AConnector); if AConnector.JoinedConnectorsList.IndexOf(PointObjConnector) = -1 then AConnector.JoinedConnectorsList.Add(PointObjConnector); end; AJoinedLine.CalculLength := AJoinedLine.LengthCalc; AJoinedLine.LineLength := AJoinedLine.CalculLength; SetLineFigureLengthInPM(AJoinedLine.ID, AJoinedLine.LineLength); // Обновить поле длинны для ортолинии AJoinedLine.UpdateLengthTextBox(false, true); // выставляем высоту края ортолинии (по коннектору) if AJoinedLine.JoinConnector1 = AConnector then begin SetLineFigureCoordZInPM(AJoinedLine.ID, 1, AConnector.ActualZOrder[1]); AJoinedLine.ActualZOrder[1] := AConnector.ActualZOrder[1]; end else if AJoinedLine.JoinConnector2 = AConnector then begin SetLineFigureCoordZInPM(AJoinedLine.ID, 2, AConnector.ActualZOrder[1]); AJoinedLine.ActualZOrder[2] := AConnector.ActualZOrder[1]; end; end; { AutoDisconnectOverRaiseInCAD(AConnector, RaiseConn, RaiseLine); //#From Oleg# NewConn := TConnectorObject.Create(RaiseConn.ActualPoints[1].x, RaiseConn.ActualPoints[1].y, RaiseConn.ActualZOrder[1], RaiseConn.LayerHandle, mydsNormal, GCadForm.PCad); NewConn.ConnectorType := ct_Clear; GCadForm.PCad.AddCustomFigure(2, NewConn, False); if AJoinedLine.JoinConnector1 = AConnector then AJoinedLine.SetJConnector1(NewConn); if AJoinedLine.JoinConnector2 = AConnector then AJoinedLine.SetJConnector2(NewConn); AConnector.JoinedOrtholinesList.Remove(AJoinedLine); if RaiseConn.ConnectorType = ct_Clear then SnapConnectorToConnector(NewConn, RaiseConn) else SnapConnectorToPointObject(NewConn, RaiseConn); AutoConnectOverRaiseInCAD(AConnector, RaiseConn); //#From Oleg# } //AutoDisconnectOverRaiseInCAD(AConnector, RaiseConn, RaiseLine); //#From Oleg# // Tolik end else // не удаляем с/п // изменить высоту - можно, если другая сторона с/п подключена только к одной ортолинии (той что двигаем) // или все подключенные к обратной стороне с/п линии поднимаются одновременно // при этом не должно быть подключения второй вершины с/п к точечному объекту begin // Tolik // тут нужна проверка на предмет преобразования с/п в вертикальную линию // (если, допустим, с/п направлен вниз и подключен к точечному, а линию поднимаем вверх, или наоборот, // или другая ситуация, приводящая в классическом варианте к установке 2-х с/п в одной точке, тогда, // по-хорошему, следовало бы в таких местах реализовать две вертикальные трассы с заменой существующего // с/п на вертикальную трассу), главное -- не забыть проверить подъем коннектора на вертикальные трассы -- то же // самое, что и для с/п (вдруг вертикальные трассы уже есть и придется просто разделить линию или удлинить) // // установить новые значения AConnector.ActualZOrder[1] := AHeight; SetConFigureCoordZInPM(AConnector.ID, AConnector.ActualZOrder[1]); SetConnBringToFront(AConnector); for i := 0 to AConnector.JoinedOrtholinesList.Count - 1 do begin JoinedLine := AConnector.JoinedOrtholinesList[i]; if JoinedLine.JoinConnector1 = AConnector then begin SetLineFigureCoordZInPM(JoinedLine.ID, 1, AConnector.ActualZOrder[1]); JoinedLine.ActualZOrder[1] := AConnector.ActualZOrder[1]; end; if JoinedLine.JoinConnector2 = AConnector then begin SetLineFigureCoordZInPM(JoinedLine.ID, 2, AConnector.ActualZOrder[1]); JoinedLine.ActualZOrder[2] := AConnector.ActualZOrder[1]; end; JoinedLine.CalculLength := JoinedLine.LengthCalc; JoinedLine.LineLength := JoinedLine.CalculLength; SetLineFigureLengthInPM(JoinedLine.ID, JoinedLine.LineLength); // Обновить поле длинны для ортолинии JoinedLine.UpdateLengthTextBox(false, true); end; // подъем-спуск RaiseLine.FLineRaiseType := GetRaiseType(AConnector, RaiseConn); // RaiseLine.ReCreateCaptionsGroup(True, false); RaiseLine.UpdateLengthTextBox(True, true); RaiseLine.ReCreateNotesGroup(True); SetConFigureCoordZInPM(AConnector.ID, AHeight); end; end else {************* ОБЪЕКТ *****************************************************} begin PointObject := TConnectorObject(AConnector.JoinedConnectorsList[0]); RaiseConn := GetRaiseConn(PointObject); if RaiseConn <> nil then RaiseLine := GetRaiseLine(RaiseConn); // установить новые значения PointObject.ActualZOrder[1] := AHeight; SetConFigureCoordZInPM(PointObject.ID, PointObject.ActualZOrder[1]); // совпадает с с-п, удалить с-п if RaiseConn.ActualZOrder[1] = AHeight then begin //Tolik // с/п удаляем, только если у него нет других подключенных трасс, не входящих в список перемещения CanDelRaiseOnPointObject := False; RaiseLine := GetRaiseLine(RaiseConn); NextRaiseConn := nil; if RaiseLine <> nil then begin if TConnectorObject(RaiseLine.JoinConnector1) <> RaiseConn then NextRaiseConn := TConnectorObject(RaiseLine.JoinConnector1) else if TConnectorObject(RaiseLine.JoinConnector2) <> RaiseConn then NextRaiseConn := TConnectorObject(RaiseLine.JoinConnector2) end; if NextRaiseConn <> nil then begin if NextRaiseConn.JoinedConnectorsList.Count > 0 then CanDelRaiseOnPointObject := False else CanDelRaiseOnPointObject := True; if NextRaiseConn.JoinedOrtholinesList.Count > 1 then CanDelRaiseOnPointObject := False else CanDelRaiseOnPointObject := True; end; if CanDelRaiseOnPointObject then begin AutoDisconnectOverRaiseInCAD(AConnector, RaiseConn, RaiseLine); //#From Oleg# UnSnapConnectorFrompointObject(AConnector, PointObject); if RaiseConn.ConnectorType = ct_Clear then SnapConnectorToConnector(AConnector, RaiseConn) else SnapConnectorToPointObject(AConnector, RaiseConn); end; end else // изменить высоту begin SetConnBringToFront(PointObject); for i := 0 to PointObject.JoinedConnectorsList.Count - 1 do begin JoinedConn := PointObject.JoinedConnectorsList[i]; JoinedConn.ActualZOrder[1] := PointObject.ActualZOrder[1]; for j := 0 to JoinedConn.JoinedOrtholinesList.Count - 1 do begin JoinedLine := JoinedConn.JoinedOrtholinesList[j]; if JoinedLine.JoinConnector1 = JoinedConn then begin SetLineFigureCoordZInPM(JoinedLine.ID, 1, PointObject.ActualZOrder[1]); JoinedLine.ActualZOrder[1] := PointObject.ActualZOrder[1]; end; if JoinedLine.JoinConnector2 = JoinedConn then begin SetLineFigureCoordZInPM(JoinedLine.ID, 2, PointObject.ActualZOrder[1]); JoinedLine.ActualZOrder[2] := PointObject.ActualZOrder[1]; end; end; SetConFigureCoordZInPM(JoinedConn.ID, JoinedConn.ActualZOrder[1]); if JoinedLine <> nil then //#From Oleg# begin JoinedLine.CalculLength := JoinedLine.LengthCalc; JoinedLine.LineLength := JoinedLine.CalculLength; SetLineFigureLengthInPM(JoinedLine.ID, JoinedLine.LineLength); // Обновить поле длинны для ортолинии JoinedLine.UpdateLengthTextBox(false, true); end; end; // подъем-спуск RaiseLine.FLineRaiseType := GetRaiseType(PointObject, RaiseConn); // RaiseLine.ReCreateCaptionsGroup(True, false); RaiseLine.UpdateLengthTextBox(True, true); RaiseLine.ReCreateNotesGroup(True); SetConFigureCoordZInPM(PointObject.ID, AHeight); end; end; RefreshCAD(GCadForm.PCad); except on E: Exception do addExceptionToLogEx('U_Common.ChangeRaiseOnNextObject', E.Message); end; BaseEndUpdate; end; *) // УДАЛИТЬ С-П НА ОБЪЕКТЕ procedure DestroyRaiseOnPointObject(APointObject: TConnectorObject); var i, j: integer; JoinedLine: TOrthoLine; JoinedConn: TConnectorObject; RaiseConn: TConnectorObject; RaiseLine: TOrthoLine; ObjParams: TObjectParams; // Tolik -- 20/04/2017 -- CadRefreshFlag: boolean; // begin BaseBeginUpdate; try RaiseLine := nil; //#From Oleg# RaiseConn := GetRaiseConn(APointObject); if RaiseConn <> nil then RaiseLine := GetRaiseLine(RaiseConn); if (RaiseLine <> nil) and (not RaiseLine.Deleted) then begin AutoDisconnectOverRaiseInCAD(APointObject, RaiseConn, RaiseLine); //#FROM Oleg# TOrthoLine(RaiseLine).Delete; RefreshCAD(GCadForm.PCad); end; if (RaiseConn <> nil) and (not RaiseConn.Deleted) then begin if RaiseConn.JoinedOrtholinesList.Count > 0 then begin if RaiseConn.ConnectorType = ct_Clear then begin SnapConnectorToPointObject(RaiseConn, APointObject, true); RaiseConn.Name := cCadClasses_Mes12; SetNewObjectNameInPM(RaiseConn.ID, RaiseConn.Name); ObjParams := GetFigureParams(RaiseConn.ID); RaiseConn.Name := ObjParams.Name; RaiseConn.FIndex := ObjParams.MarkID; end; RaiseConn.FConnRaiseType := crt_None; RaiseConn.FObjectFromRaise := nil; RaiseConn.LockMove := False; RaiseConn.LockModify := False; end; end; APointObject.FConnRaiseType := crt_None; APointObject.FObjectFromRaise := nil; APointObject.LockMove := False; APointObject.LockModify := False; RefreshCAD(GCadForm.PCad); except on E: Exception do addExceptionToLogEx('U_Common.DestroyRaiseOnPointObject', E.Message); end; BaseEndUpdate; end; // УДАЛИТЬ С-П НА СОЕДИНИТЕЛЕ Procedure DestroyRaiseOnConnector(AConnector: TConnectorObject); var i, j: integer; JoinedLine: TOrthoLine; JoinedConn: TConnectorObject; RaiseConn: TConnectorObject; RaiseLine: TOrthoLine; ObjParams: TObjectParams; begin BaseBeginUpdate; try RaiseLine := nil; //#From Oleg# RaiseConn := GetRaiseConn(AConnector); if RaiseConn <> nil then RaiseLine := GetRaiseLine(RaiseConn); if (RaiseLine <> nil) and (not RaiseLine.Deleted) then begin AutoDisconnectOverRaiseInCAD(AConnector, RaiseConn, RaiseLine); //#From Oleg# TOrthoLine(RaiseLine).Delete; RefreshCAD(GCadForm.PCad); end; if (RaiseConn <> nil) and (not RaiseConn.Deleted) then begin if RaiseConn.ConnectorType = ct_clear then begin // SnapConnectorToConnector(RaiseConn, AConnector, true); //SnapConnectorToConnector(AConnector, RaiseConn, true); // Tolik 29/03/2018 -- //AConnector := SnapConnectorToConnector(AConnector, RaiseConn, true); // Tolik 03/10/2018 -- if not AConnector.Deleted then if not RaiseConn.Deleted then // CheckingSnapConnectorToConnector(AConnector, RaiseConn); // if not RaiseConn.Deleted then begin RaiseConn.Name := cCadClasses_Mes12; SetNewObjectNameInPM(RaiseConn.ID, RaiseConn.Name); ObjParams := GetFigureParams(RaiseConn.ID); RaiseConn.Name := ObjParams.Name; RaiseConn.FIndex := ObjParams.MarkID; end; end; if not RaiseConn.Deleted then begin RaiseConn.FConnRaiseType := crt_None; RaiseConn.FObjectFromRaise := nil; RaiseConn.LockMove := False; RaiseConn.LockModify := False; end; end; if (AConnector <> nil) and (not AConnector.Deleted) then begin AConnector.FConnRaiseType := crt_None; AConnector.FObjectFromRaise := nil; AConnector.LockMove := False; AConnector.LockModify := False; end; except on E: Exception do addExceptionToLogEx('U_Common.DestroyRaiseOnConnector', E.Message); end; BaseEndUpdate; end; // 21/03/2016 -- Tolik -- так было!!! здесь, на всякий, НЕ ЛОМАТЬ!!! // поломано дальше -- попытка сделать все правильно // ПОДНЯТЬ ЛИНИЮ НА ВЫСОТУ Procedure RaiseLineOnHeight(ALine: TOrthoLine; AHeight: Double; ATracesList: TList); var Connector1: TConnectorObject; Connector2: TConnectorObject; RT1: TConnectorObject; RT2: TConnectorObject; RaiseConn: TConnectorObject; ObjFromRaise: TConnectorObject; // Tolik -- если трасса присоединена к магистрали или межэтажному с/п, // просто двигаем коннектор, если он сидит на пустом месте (вместе со всеми присоединенными трассами независомо от того, // выбраны они в данный момент или нет), если коннектор сидит на точечном объекте - не двинаем его совсем // (Чтобы подвинуть такое соединение, пользователю придется подвинуть точечный объект) // Tolik -- 12/11/2020 -- переписана совсем... старая закомменчена... некорректно ведет себя с межэтажками ... Function CheckMoveMagistralOrBetweenFloorConnector(AConnector: TConnectorObject): Boolean; var JoinedLine: TOrthoLine; i, j: Integer; JoinedConn, currConn, NextConn, NB_Conn: TConnectorObject; CanMoveConnector, isTrunk: Boolean; RaiseLine: TOrthoLine; UpTrunkConn, DownTrunkConn: TConnectorObject; function CheckRaiseIsNoMagistral(aLine: TOrthoLine): boolean; begin Result := True; try if aLine.FisRaiseUpDown then Result := not ((TConnectorObject(RaiseLine.JoinConnector1).FConnRaiseType = crt_TRunkUp) or (TConnectorObject(RaiseLine.JoinConnector1).FConnRaiseType = crt_TRunkDown) or (TConnectorObject(RaiseLine.JoinConnector2).FConnRaiseType = crt_TRunkUp) or (TConnectorObject(RaiseLine.JoinConnector2).FConnRaiseType = crt_TRunkDown)); Except On E: Exception do Result := False; end; end; begin Result := False; NextConn := nil; CanMoveConnector := False; isTrunk := False; RaiseLine := Nil; NB_Conn := Nil; currConn := Nil; //проверяем на наличие райза if AConnector.JoinedConnectorsList.Count > 0 then begin Nb_Conn := TConnectorObject(AConnector.JoinedConnectorsList[0]); // точечный на коннекторе for i := 0 to Nb_Conn.JoinedConnectorsList.Count - 1 do begin JoinedConn := TConnectorObject(NB_Conn.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; end; if RaiseLine <> nil then break; end; end else for i := 0 to AConnector.JoinedOrthoLinesList.Count - 1 do begin if TOrthoLine(AConnector.JoinedOrthoLinesList[i]).FisRaiseUpDown then begin RaiseLine := TOrthoLine(AConnector.JoinedOrthoLinesList[i]); break; end; end; // Райза нет, поинта нет - можно двинуть просто так... if (RaiseLine = nil) and (NB_Conn = nil) then exit; if RaiseLine <> nil then //есть райз begin UpTrunkConn := nil; //подъем DownTrunkConn := nil; //спуск if ((TConnectorObject(RaiseLine.JoinConnector1).FConnRaiseType = crt_BetweenFloorUp) or (TConnectorObject(RaiseLine.JoinConnector1).FConnRaiseType = crt_TRunkUp) or (TConnectorObject(RaiseLine.JoinConnector2).FConnRaiseType = crt_BetweenFloorUp) or (TConnectorObject(RaiseLine.JoinConnector2).FConnRaiseType = crt_TRunkUp)) then begin if CompareValue(TConnectorObject(RaiseLine.JoinConnector1).ActualZOrder[1], TConnectorObject(RaiseLine.JoinConnector2).ActualZOrder[1]) = 1 then begin UpTrunkConn := TConnectorObject(RaiseLine.JoinConnector1); NextConn := TConnectorObject(RaiseLine.JoinConnector2); end else if CompareValue(TConnectorObject(RaiseLine.JoinConnector1).ActualZOrder[1], TConnectorObject(RaiseLine.JoinConnector2).ActualZOrder[1]) = -1 then begin UpTrunkConn := TConnectorObject(RaiseLine.JoinConnector2); NextConn := TConnectorObject(RaiseLine.JoinConnector1); end else begin Result := True; exit; end; end; if UpTrunkConn = nil then begin if ((TConnectorObject(RaiseLine.JoinConnector1).FConnRaiseType = crt_BetweenFloorDown) or (TConnectorObject(RaiseLine.JoinConnector1).FConnRaiseType = crt_TRunkDown) or (TConnectorObject(RaiseLine.JoinConnector2).FConnRaiseType = crt_BetweenFloorDown) or (TConnectorObject(RaiseLine.JoinConnector2).FConnRaiseType = crt_TRunkDown)) then begin if CompareValue(TConnectorObject(RaiseLine.JoinConnector1).ActualZOrder[1], TConnectorObject(RaiseLine.JoinConnector2).ActualZOrder[1]) = 1 then begin DownTrunkConn := TConnectorObject(RaiseLine.JoinConnector2); NextConn := TConnectorObject(RaiseLine.JoinConnector1); end else if CompareValue(TConnectorObject(RaiseLine.JoinConnector1).ActualZOrder[1], TConnectorObject(RaiseLine.JoinConnector2).ActualZOrder[1]) = -1 then begin DownTrunkConn := TConnectorObject(RaiseLine.JoinConnector1); NextConn := TConnectorObject(RaiseLine.JoinConnector2); end else begin Result := True; exit; end; end; end; isTrunk := (NextConn <> nil); end; //Райз на поинте - проверить, если это межетажка или магистраль -- нельзя двигать никак .... if ((Nb_Conn <> nil) and isTrunk) then begin Result := True; exit; end; //если межэтажка или магистраль - можно подвинуть, если только не двигается тот конец, который со стрелочкой //(он "прикреплен" к полу или потолку) if isTrunk then begin if CompareValue(AConnector.ActualZOrder[1], NextConn.ActualZOrder[1]) = 0 then // трасса не на конце стрелки begin if (AConnector.JoinedOrtholinesList.Count > 2) then // если есть еще трассы, прикрепленные с того же конца - двигать нельзя.... begin Result := True; exit; end else CanMoveConnector := True; end else // нужно оторвать трассу со стрелки (если можно по высоте такое проделать) begin if ((CompareValue(aHeight, NextConn.ActualZorder[1]) = 0) or (NextConn.JoinedOrtholinesList.Count = 1)) then CanMoveConnector := True else begin Result := True; exit; end; end; // стрелочка вниз if DownTrunkConn <> nil then begin // Нижний коннектор if CompareValue(DownTrunkConn.ActualZOrder[1], NextConn.ActualZOrder[1]) = -1 then currConn := DownTrunkConn else currConn := NextConn; end else //стрелочка вверх if UpTrunkConn <> nil then begin if CompareValue(UpTrunkConn.ActualZOrder[1], NextConn.ActualZOrder[1]) = 1 then currConn := UpTrunkConn else currConn := NextConn; end; end else begin end; if CanMoveConnector then begin AConnector.ActualZOrder[1] := AHeight; SetConFigureCoordZInPM(AConnector.ID, AConnector.ActualZOrder[1]); for i := 0 to aConnector.JoinedOrthoLinesList.Count - 1 do begin JoinedLine := TOrthoLine(AConnector.JoinedOrtholinesList[i]); // выставить высоту поднимаемого края ортолинии if TConnectorObject(JoinedLine.JoinConnector1).Id = AConnector.ID then begin JoinedLine.ActualZOrder[1] := AHeight; end else if TConnectorObject(JoinedLine.JoinConnector2).ID = AConnector.ID then begin JoinedLine.ActualZOrder[2] := AHeight; end; if not JoinedLine.FIsRaiseUpDown then begin // пересчитать длину ортолинии JoinedLine.CalculLength := JoinedLine.LengthCalc; JoinedLine.LineLength := JoinedLine.CalculLength; JoinedLine.UpdateLengthTextBox(False, True); SetLineFigureCoordZInPM(JoinedLine.ID, 1, JoinedLine.ActualZOrder[1]); SetLineFigureCoordZInPM(JoinedLine.ID, 2, JoinedLine.ActualZOrder[2]); //if not JoinedLine.FIsRaiseUpDown then { begin if RaiseLine <> nil then // межэтажка begin RaiseLine.CalculLength := RaiseLine.LengthCalc; RaiseLine.LineLength := RaiseLine.CalculLength; SetLineFigureLengthInPM(RaiseLine.ID, RaiseLine.LineLength); RaiseLine.UpdateLengthTextBox(False, True); SetLineFigureCoordZInPM(RaiseLine.ID, 1, RaiseLine.ActualZOrder[1]); SetLineFigureCoordZInPM(RaiseLine.ID, 2, RaiseLine.ActualZOrder[2]); end; end; } end; end; if RaiseLine <> nil then // межэтажка if CheckRaiseIsNoMagistral(RaiseLine) then begin RaiseLine.CalculLength := RaiseLine.LengthCalc; RaiseLine.LineLength := RaiseLine.CalculLength; SetLineFigureLengthInPM(RaiseLine.ID, RaiseLine.LineLength); RaiseLine.UpdateLengthTextBox(False, True); SetLineFigureCoordZInPM(RaiseLine.ID, 1, RaiseLine.ActualZOrder[1]); SetLineFigureCoordZInPM(RaiseLine.ID, 2, RaiseLine.ActualZOrder[2]); end; Result := True; end; end; { Function CheckMoveMagistralOrBetweenFloorConnector(AConnector: TConnectorObject): Boolean; var JoinedLine: TOrthoLine; i, j: Integer; currConn, NextConn, NB_Conn: TConnectorObject; CanMoveConnector, isTrunk: Boolean; RaiseLine: TOrthoLine; begin Result := False; NextConn := nil; CanMoveConnector := False; isTrunk := False; RaiseLine := Nil; // на пустом коннекторе if aConnector.JoinedConnectorsList.Count = 0 then begin // если трасса прицеплене не к той стороне райза -- вывалиться нах и ничего не двигать if (AConnector.FConnRaiseType = crt_BetweenFloorUp) or (AConnector.FConnRaiseType = crt_BetweenFloorDown) or (AConnector.FConnRaiseType = crt_TRunkUp) or (AConnector.FConnRaiseType = crt_TRunkDown) then begin isTrunk := True; Result := True; Exit; end; if not isTrunk then begin for i := 0 to AConnector.JoinedOrtholinesList.Count - 1 do begin NextConn := nil; RaiseLine := TOrthoLine(AConnector.JoinedOrtholinesList[i]); if RaiseLine.FIsRaiseUpDown then begin if TConnectorObject(RaiseLine.JoinConnector1).ID = AConnector.ID then NextConn := TConnectorObject(RaiseLine.JoinConnector2) else if TConnectorObject(RaiseLine.JoinConnector2).ID = AConnector.Id then NextConn := TConnectorObject(RaiseLine.JoinConnector1); end; // второй коннектор райза if NextConn <> nil then begin if (NextConn.FConnRaiseType = crt_BetweenFloorUp) or (NextConn.FConnRaiseType = crt_BetweenFloorDown) or (NextConn.FConnRaiseType = crt_TRunkUp) or (NextConn.FConnRaiseType = crt_TRunkDown) then begin isTrunk := True; CanMoveConnector := True; end; end; if CanMoveConnector then break; end; end; if CanMoveConnector then begin AConnector.ActualZOrder[1] := AHeight; SetConFigureCoordZInPM(AConnector.ID, AConnector.ActualZOrder[1]); for i := 0 to aConnector.JoinedOrthoLinesList.Count - 1 do begin JoinedLine := TOrthoLine(AConnector.JoinedOrtholinesList[i]); // выставить высоту поднимаемого края ортолинии if TConnectorObject(JoinedLine.JoinConnector1).Id = AConnector.ID then begin JoinedLine.ActualZOrder[1] := AHeight; end else if TConnectorObject(JoinedLine.JoinConnector2).ID = AConnector.ID then begin JoinedLine.ActualZOrder[2] := AHeight; end; //if not JoinedLine.FIsRaiseUpDown then begin // пересчитать длину ортолинии JoinedLine.CalculLength := JoinedLine.LengthCalc; JoinedLine.LineLength := JoinedLine.CalculLength; JoinedLine.UpdateLengthTextBox(False, True); SetLineFigureCoordZInPM(JoinedLine.ID, 1, JoinedLine.ActualZOrder[1]); SetLineFigureCoordZInPM(JoinedLine.ID, 2, JoinedLine.ActualZOrder[2]); end; end; Result := True; end; end else // если коннектор сидит на точечном объекте -- проверяем, нет ли на этом объекте М/Э или магистрали // (если есть - вообще ни х двигать не будем) begin NB_Conn := TConnectorObject(AConnector.JoinedConnectorsList[0]); for i := 0 to NB_Conn.JoinedConnectorsList.Count - 1 do begin currConn := TConnectorObject(NB_Conn.JoinedConnectorsList[i]); if (currConn.FConnRaiseType = crt_BetweenFloorUp) or (currConn.FConnRaiseType = crt_BetweenFloorDown) or (currConn.FConnRaiseType = crt_TRunkUp) or (currConn.FConnRaiseType = crt_TRunkDown) then begin isTrunk := True; end else begin for j := 0 to currConn.JoinedOrtholinesList.Count - 1 do begin JoinedLine := TOrthoLine(currConn.JoinedOrtholinesList[j]); if JoinedLine.FIsRaiseUpDown then begin NextConn := nil; if TConnectorObject(JoinedLine.JoinConnector1).ID = currConn.Id then NextConn := TConnectorObject(JoinedLine.JoinConnector2) else if TConnectorObject(JoinedLine.JoinConnector2).ID = currConn.Id then NextConn := TconnectorObject(JoinedLine.JoinConnector1); if NextConn <> nil then begin if (currConn.FConnRaiseType = crt_BetweenFloorUp) or (currConn.FConnRaiseType = crt_BetweenFloorDown) or (currConn.FConnRaiseType = crt_TRunkUp) or (currConn.FConnRaiseType = crt_TRunkDown) then begin isTrunk := True; end end; end; end; end; if isTrunk then Break; //// BREAK ////; end; if isTrunk then Result := True; end; end;} // begin BaseBeginUpdate; try Connector1 := TConnectorObject(ALine.JoinConnector1); Connector2 := TConnectorObject(ALine.JoinConnector2); // 1 // Tolik 17/11/2016 -- // if Connector1.ActualZOrder[1] <> AHeight then if (Connector1 <> nil) and (not Connector1.deleted) and (Connector1.ActualZOrder[1] <> AHeight) then begin if not CheckMoveMagistralOrBetweenFloorConnector(Connector1) then begin // // не вершина с-п и на нем нет с-п if (Connector1.FConnRaiseType = crt_None) and (GetRaiseConn(Connector1) = nil) then begin if (Connector1.JoinedConnectorsList.Count > 0) or (Connector1.JoinedOrtholinesList.Count > 1) then begin // Conn if (Connector1.ConnectorType = ct_Clear) and (Connector1.JoinedOrtholinesList.Count > 1) then begin if CheckNeedCreateRaiseOnRaiseTrace(ALine, Connector1, ATracesList) then // Tolik 26/04/21016 -- // CreateRaiseOnNextObject(Connector1, ALine, AHeight) CreateRaiseOnNextObject(Connector1, ALine, AHeight, ATracesList) // else begin Connector1.ActualZOrder[1] := AHeight; SetConFigureCoordZInPM(Connector1.ID, Connector1.ActualZOrder[1]);//24.10.2012 ALine.ActualZOrder[1] := AHeight; end; end else // RT begin // RT1 := TConnectorObject(Connector1.JoinedConnectorsList[0]); RaiseConn := GetRaiseConn(RT1); // не вершина с-п и нет с-п if (RT1.FConnRaiseType = crt_None) and (RaiseConn = nil) then // Tolik 26/04/2016 -- // CreateRaiseOnNextObject(Connector1, ALine, AHeight) //Tolik 18/02/2021 -- //CreateRaiseOnNextObject(Connector1, ALine, AHeight, ATracesList) begin Connector1.JoinedConnectorsList.Remove(RT1); RT1.JoinedConnectorsList.Remove(Connector1); Connector1.ActualZOrder[1] := aHeight; aLine.ActualZOrder[1] := aHeight; SnapPointObjectToConnector(RT1, Connector1); end // else begin // есть с-п и он межэтажный if (RaiseConn <> nil) and (RaiseConn.FConnRaiseType <> crt_OnFloor) then begin // Tolik -- 29/04/2016 -- ChangeRaiseOnNextObject(Connector1, ALine, AHeight, ATracesList); //*ChangeRaiseOnNextObject(Connector1, ALine, AHeight); end else if (RaiseConn = nil) and (ObjFromRaise <> nil) then begin RT1.ActualZOrder[1] := AHeight; SetConFigureCoordZInPM(RT1.ID, RT1.ActualZOrder[1]); //24.10.2012 Connector1.ActualZOrder[1] := AHeight; ALine.ActualZOrder[1] := AHeight; end else begin // Tolik -- 26/04/2016 -- //CreateRaiseOnNextObject(Connector1, ALine, AHeight); CreateRaiseOnNextObject(Connector1, ALine, AHeight, ATracesList); // end; end; end; end else begin Connector1.ActualZOrder[1] := AHeight; SetConFigureCoordZInPM(Connector1.ID, Connector1.ActualZOrder[1]);//24.10.2012 ALine.ActualZOrder[1] := AHeight; end; end else // это вершина с-п или не нем есть с-п begin if (Connector1.FConnRaiseType <> crt_BetweenFloorUp) and (Connector1.FConnRaiseType <> crt_BetweenFloorDown) then // Tolik -- 29/04/2016 -- // ChangeRaiseOnNextObject(Connector1, ALine, AHeight); ChangeRaiseOnNextObject(Connector1, ALine, AHeight, ATracesList); // end; end; end; // 2 // Tolik -- 17/11/2016 -- if (Connector2 <> nil) and (not Connector2.deleted) and (Connector2.ActualZOrder[1] <> AHeight) then begin if not CheckMoveMagistralOrBetweenFloorConnector(Connector2) then // begin // не вершина с-п и на нем нет с-п if (Connector2.FConnRaiseType = crt_None) and (GetRaiseConn(Connector2) = nil) then begin if (Connector2.JoinedConnectorsList.Count > 0) or (Connector2.JoinedOrtholinesList.Count > 1) then begin // RT if (Connector2.ConnectorType = ct_Clear) and (Connector2.JoinedOrtholinesList.Count > 1) then begin if CheckNeedCreateRaiseOnRaiseTrace(ALine, Connector2, ATracesList) then // Tolik -- 26/04/2016 -- // CreateRaiseOnNextObject(Connector2, ALine, AHeight) CreateRaiseOnNextObject(Connector2, ALine, AHeight, ATracesList) else begin Connector2.ActualZOrder[1] := AHeight; SetConFigureCoordZInPM(Connector2.ID, Connector2.ActualZOrder[1]);//24.10.2012 ALine.ActualZOrder[2] := AHeight; end; end else begin // RT2 := TConnectorObject(Connector2.JoinedConnectorsList[0]); RaiseConn := GetRaiseConn(RT2); // не вершина с-п и нет с-п if (RT2.FConnRaiseType = crt_None) and (RaiseConn = nil) then // Tolik -- 26/04/2016 -- // CreateRaiseOnNextObject(Connector2, ALine, AHeight) // Tolik 19/02/2021 -- //CreateRaiseOnNextObject(Connector2, ALine, AHeight, ATracesList) begin Connector2.JoinedConnectorsList.Remove(RT2); RT2.JoinedConnectorsList.Remove(Connector2); Connector2.ActualZOrder[1] := aHeight; aLine.ActualZOrder[2] := aHeight; SnapPointObjectToConnector(RT2, Connector2); end // // else begin if (RaiseConn <> nil) and (RaiseConn.FConnRaiseType <> crt_OnFloor) then begin //Tolik -- 29/04/2016 -- //ChangeRaiseOnNextObject(Connector2, ALine, AHeight); ChangeRaiseOnNextObject(Connector1, ALine, AHeight, ATracesList); // end else if (RaiseConn = nil) and (ObjFromRaise <> nil) then begin RT2.ActualZOrder[1] := AHeight; SetConFigureCoordZInPM(RT2.ID, RT2.ActualZOrder[1]); Connector1.ActualZOrder[2] := AHeight; ALine.ActualZOrder[2] := AHeight; end else begin // Tolik 26/04/2016 -- //CreateRaiseOnNextObject(Connector2, ALine, AHeight); CreateRaiseOnNextObject(Connector2, ALine, AHeight, aTracesList); // end; end; end; end else begin Connector2.ActualZOrder[1] := AHeight; SetConFigureCoordZInPM(Connector2.ID, Connector2.ActualZOrder[1]); //24.10.2012 ALine.ActualZOrder[2] := AHeight; end; end else // это вершина с-п или не нем есть с-п begin if (Connector2.FConnRaiseType <> crt_BetweenFloorUp) and (Connector2.FConnRaiseType <> crt_BetweenFloorDown) then //Tolik -- 29/04/2016 -- // ChangeRaiseOnNextObject(Connector2, ALine, AHeight); ChangeRaiseOnNextObject(Connector2, ALine, AHeight, ATracesList); // end; end; end; ALine.CalculLength := ALine.LengthCalc; ALine.LineLength := ALine.CalculLength; ALine.UpdateLengthTextBox(False, True); SetLineFigureCoordZInPM(ALine.ID, 1, ALine.ActualZOrder[1]); SetLineFigureCoordZInPM(ALine.ID, 2, ALine.ActualZOrder[2]); AutoDivideLine(ALine); //31.01.2011 - разделяем линию если нужно except on E: Exception do addExceptionToLogEx('U_Common.RaiseLineOnHeight', E.Message); end; BaseEndUpdate; end; (* // ПОДНЯТЬ ЛИНИЮ НА ВЫСОТУ -- by Tolik Procedure RaiseLineOnHeight(ALine: TOrthoLine; AHeight: Double; ATracesList: TList); var Connector1: TConnectorObject; Connector2: TConnectorObject; RT1: TConnectorObject; RT2: TConnectorObject; RaiseConn: TConnectorObject; ObjFromRaise: TConnectorObject; // Tolik NeedToCreateVertical1, NeedToCreateVertical2: Boolean; // Нужно ли создавать вертикаль (если есть с/п, но подъем трассы идет против направления с/п) // в таком случае создаем вертикальную трассу + преобразовываем существующий с/п в вертикаль ThereIsVerticalLine: Boolean; // Есть ли подключение коннектора к вертикальной линии -- разбивать или удлинять/укорачивать вертикаль CanMoveConn1Simple, CanMoveConn2Simple: Boolean; // Если можно просто двинуть коннектор ThereIsCableConnection: Boolean; // если есть кабельные соединения в поднимаемой трассе MoveUP, MoveDown: Boolean; // Двинуть коннектор вверх-вниз NewConnector: TConnectorObject; CurrLine: TOrthoLine; LHandle: Integer; CanContinue: Boolean; // нужно ли чухать дальше TargetConnector: TConnectorObject; // если при подъеме/спуске коннектор трассы попадает на другой коннектор // // Двигаем коннектор по вертикали (самый простой случай ) Procedure MoveConnectorSimple(AConnector: TConnectorObject); var i: Integer; JoinedLine: TOrthoLine; begin // поднимаем коннектор AConnector.ActualZOrder[1] := AHeight; // изменения -- в ПМ для коннектора SetConFigureCoordZInPM(AConnector.ID, AConnector.ActualZOrder[1]);//24.10.2012 // для всех присоединенных линий -- установка координат соответствующей стороны, // пересчет длины и внесение изменений в ПМ for i := 0 to AConnector.JoinedOrtholinesList.Count - 1 do begin JoinedLine := TOrthoLine(AConnector.JoinedOrtholinesList[i]); if JoinedLine.JoinConnector1.ID = AConnector.Id then JoinedLine.ActualZOrder[1] := AHeight else if JoinedLine.JoinConnector2.ID = AConnector.ID then JoinedLine.ActualZOrder[2] := AHeight; JoinedLine.CalculLength := JoinedLine.LengthCalc; JoinedLine.LineLength := JoinedLine.CalculLength; JoinedLine.UpdateLengthTextBox(False, True); if JoinedLine.JoinConnector1.ID = AConnector.Id then SetLineFigureCoordZInPM(JoinedLine.ID, 1, JoinedLine.ActualZOrder[1]) else if JoinedLine.JoinConnector2.ID = AConnector.Id then SetLineFigureCoordZInPM(JoinedLine.ID, 2, JoinedLine.ActualZOrder[2]); end; end; Function DefineTargetConnector(AConn: TConnectorObject) : TConnectorObject; var i: Integer; Figure: TFigure; begin Result := Nil; for i := 0 to GCadForm.FSCSFigures.Count - 1 do begin Figure := TFigure(GCadForm.FSCSFigures[i]); if CheckFigureByClassName(Figure, cTConnectorObject) then begin if (CompareValue(TConnectorObject(Figure).ActualPoints[1].x, AConn.ActualPoints[1].x) = 0) and (CompareValue(TConnectorObject(Figure).ActualPoints[1].y, AConn.ActualPoints[1].y) = 0) and (CompareValue(TConnectorObject(Figure).ActualZOrder[1], AHeight) = 0) then begin Result := TConnectorObject(Figure); break; end; end; end; end; Function CanMoveConnectorSimple(AConnector: TConnectorObject): Boolean; var i, j : integer; NBConnector: TConnectorObject; NBCatalog: TSCSCatalog; TempList: TList; begin Result := True; TempList := TList.Create; TargetConnector := DefineTargetConnector(AConnector); for i := 0 to AConnector.JoinedOrtholinesList.Count - 1 do begin if TOrthoLine(AConnector.JoinedOrtholinesList[i]).ID <> ALine.ID then begin if ((not TOrthoLine(AConnector.JoinedOrtholinesList[i]).FIsRaiseUpDown) and (not TOrthoLine(AConnector.JoinedOrtholinesList[i]).FIsVertical) and (ATracesList.IndexOf(TOrthoLine(AConnector.JoinedOrtholinesList[i])) = -1)) then begin TempList.Add(TOrthoLine(AConnector.JoinedOrtholinesList[i])); end; end; end; if TempList.Count > 0 then begin Result := False; for i := 0 to TempList.Count - 1 do begin currLine := TOrthoLine(TempList[i]); if TConnectorObject(CurrLine.JoinConnector1) = AConnector then begin CurrLine.JoinConnector1 := nil; NewConnector := TConnectorObject.Create(CurrLine.ActualPoints[1].x, CurrLine.ActualPoints[1].y, AConnector.ActualZOrder[1], LHandle, mydsNormal, GCadForm.PCad); NewConnector.ConnectorType := ct_Clear; GCadForm.PCad.AddCustomFigure (GLN(LHandle), NewConnector, False); CurrLine.SetJConnector1(NewConnector); AConnector.JoinedOrtholinesList.Remove(CurrLine); if AConnector.ActualZOrder[1] <> AHeight then MoveConnectorSimple(AConnector); CheckingSnapConnectorToConnector(NewConnector, AConnector); end else if TConnectorObject(CurrLine.JoinConnector2) = AConnector then begin CurrLine.JoinConnector2 := nil; NewConnector := TConnectorObject.Create(CurrLine.ActualPoints[2].x, CurrLine.ActualPoints[2].y, AConnector.ActualZOrder[1], LHandle, mydsNormal, GCadForm.PCad); NewConnector.ConnectorType := ct_Clear; GCadForm.PCad.AddCustomFigure (GLN(LHandle), NewConnector, False); CurrLine.SetJConnector2(NewConnector); AConnector.JoinedOrtholinesList.Remove(CurrLine); if AConnector.ActualZOrder[1] <> AHeight then MoveConnectorSimple(AConnector); CheckingSnapConnectorToConnector(NewConnector, AConnector); end; end; end; FreeAndNil(TempList); if Result then begin for i := 0 to AConnector.JoinedConnectorsList.Count - 1 do begin if TConnectorObject(AConnector.JoinedConnectorsList[i]).ConnectorType = ct_NB then begin NBConnector := TConnectorObject(AConnector.JoinedConnectorsList[i]); NBCatalog := F_ProJMan.GSCSBase.CurrProject.CurrList.GetCatalogFromReferencesBySCSID(NBConnector.ID); if NBCatalog <> nil then begin for j := 0 to NBCatalog.ComponentReferences.Count - 1 do begin if TSCSComponent(NBCatalog.ComponentReferences[j]).ComponentType.SysName <> ctsnCableChannelElement then begin Result := False; break; end; end; end; end; end; end; end; function CheckVerticalLineConnection(AConnector: TConnectorObject): Boolean; var i, j: Integer; TmpConnector, NBConnector: TConnectorObject; begin result := False; for i := 0 to AConnector.JoinedOrtholinesList.Count - 1 do begin if TOrthoLine(AConnector.JoinedOrtholinesList[i]).FIsVertical then begin result := True; Break; //// BREAK ////; end; end; if not result then begin for i := 0 to AConnector.JoinedConnectorsList.Count - 1 do begin if TConnectorObject(AConnector.JoinedOrtholinesList[i]).ConnectorType = ct_NB then begin NBConnector := TConnectorObject(AConnector.JoinedConnectorsList[i]); break; end; end; for i := 0 to NBConnector.JoinedConnectorsList.Count - 1 do begin TmpConnector := TConnectorObject(NBConnector.JoinedConnectorsList[i]); if TmpConnector <> AConnector then begin for j := 0 to TmpConnector.JoinedOrtholinesList.Count - 1 do begin if TOrthoLine(TmpConnector.JoinedOrtholinesList[j]).FIsVertical then begin Result := true; break; end; end; end; if result then Break; //// BREAK ////; end; end; end; function CheckNeedCreateVertLine(AConnector: TConnectorObject; LineHeighttoMove: Double): Boolean; var i: Integer; ThereIsupDown: Boolean; RaiseLine: TOrthoLine; RaiseConn, RaiseConn1: TConnectorObject; begin Result := not ((AConnector.FConnRaiseType = crt_None) and (GetRaiseConn(AConnector) = nil)); if not Result then Exit; RaiseConn := GetRaiseConn(AConnector); if RaiseConn <> nil then begin RaiseLine := GetRaiseLine(RaiseConn); if RaiseLine <> nil then begin RaiseConn := TConnectorObject(RaiseLine.JoinConnector1); RaiseConn1 := TConnectorObject(RaiseLine.JoinConnector2); // в данном случае играет роль только высота расположения коннекторов if CompareValue(RaiseConn.ActualZOrder[1], RaiseConn1.ActualZOrder[1]) = -1 then begin RaiseConn := TConnectorObject(RaiseLine.JoinConnector2); RaiseConn1 := TConnectorObject(RaiseLine.JoinConnector1); end; Result := ((CompareValue(RaiseConn.ActualZOrder[1], LineHeightToMove) = -1) or (CompareValue(RaiseConn1.ActualZOrder[1], LineHeightToMove) = 1)); end; end; end; Function CheckIsCableConnection(ATrace: TOrthoLine): Boolean; var i: Integer; LineCatalog: TSCSCatalog; LineCompon: TSCSComponent; begin Result := False; if ATrace <> nil then begin LineCatalog := F_ProjMan.GSCSBase.CurrProject.CurrList.GetCatalogFromReferencesBySCSID(ATrace.ID); if LineCatalog <> nil then begin for i := 0 to LineCatalog.ComponentReferences.Count - 1 do begin LineCompon := LineCatalog.ComponentReferences[i]; if LineCompon.JoinedComponents.Count > 0 then begin Result := True; break; end; end; end; end; end; Procedure MoveConnectorWithCheck(AConnector: TConnectorObject); Var i: Integer; Begin if AConnector <> nil then begin end; End; // begin BaseBeginUpdate; try MoveUP := False; MoveDown := False; LHandle := GCadForm.PCad.GetLayerHandle(GCadForm.PCad.ActiveLayer); Connector1 := TConnectorObject(ALine.JoinConnector1); Connector2 := TConnectorObject(ALine.JoinConnector2); CanMoveConn1Simple := False; // можно ли двинуть коннектор 1 if CompareValue(Connector1.ActualZOrder[1], AHeight) <> 0 then CanMoveConn1Simple := CanMoveConnectorSimple(Connector1); CanMoveConn2Simple := False; // можно ли двинуть коннектор 2 if CompareValue(Connector2.ActualZOrder[1], AHeight) <> 0 then CanMoveConn2Simple := CanMoveConnectorSimple(Connector2); // есть ли кабельные соединения ThereIsCableConnection := CheckIsCableConnection(ALine); // ********** самый простой случай - все двигаем, ничего не переподключаем, ничего не создаем ***** if CanMoveConn1Simple then MoveConnectorSimple(Connector1); if CanMoveConn2Simple then MoveConnectorSimple(Connector2); if (not CanMoveConn1Simple) and (CompareValue(Connector1.ActualZOrder[1], AHeight) <> 0) then MoveConnectorWithCheck(Connector1); if (not CanMoveConn2Simple) and (CompareValue(Connector2.ActualZOrder[1], AHeight) <> 0) then MoveConnectorWithCheck(Connector2); except on E: Exception do addExceptionToLogEx('U_Common.RaiseLineOnHeight', E.Message); end; BaseEndUpdate; GCadForm.PCad.Refresh; end; *) (* Procedure RaiseLineOnHeight(ALine: TOrthoLine; AHeight: Double; ATracesList: TList); var Connector1: TConnectorObject; Connector2: TConnectorObject; RT1: TConnectorObject; RT2: TConnectorObject; RaiseConn: TConnectorObject; ObjFromRaise: TConnectorObject; //-- Tolik -- 17/11/2015 -- проверить, есть ли на непустом коннекторе что-либо, кроме элементов кабельного канала Function CheckConnectorCableElementsOnly(AConnector: TConnectorObject): Boolean; var ConnObject: TSCSCatalog; SCSComponent: TSCSComponent; i: Integer; begin Result := True; if AConnector <> nil then begin ConnObject := F_ProjMan.GSCSBase.CurrProject.GetCatalogFromReferencesBySCSID(AConnector.ID); if ConnObject <> nil then begin for i := 0 to ConnObject.ComponentReferences.Count - 1 do begin SCSComponent := TSCSComponent(ConnObject.ComponentReferences[i]); if SCSComponent.ComponentType.SysName <> ctsnCableChannelElement then begin Result := False; break; end; end; end; end; end; begin BaseBeginUpdate; try Connector1 := TConnectorObject(ALine.JoinConnector1); Connector2 := TConnectorObject(ALine.JoinConnector2); // 1 if Connector1.ActualZOrder[1] <> AHeight then begin // не вершина с-п и на нем нет с-п if (Connector1.FConnRaiseType = crt_None) and (GetRaiseConn(Connector1) = nil) then begin // Tolik -- 17/11/2015 -- //if (Connector1.JoinedConnectorsList.Count > 0) or (Connector1.JoinedOrtholinesList.Count > 1) then if ((Connector1.JoinedConnectorsList.Count > 0) and (not CheckConnectorCableElementsOnly(Connector1))) or (Connector1.JoinedOrtholinesList.Count > 1) then // begin // Conn if (Connector1.ConnectorType = ct_Clear) and (Connector1.JoinedOrtholinesList.Count > 1) then begin if CheckNeedCreateRaiseOnRaiseTrace(ALine, Connector1, ATracesList) then CreateRaiseOnNextObject(Connector1, ALine, AHeight) else begin Connector1.ActualZOrder[1] := AHeight; SetConFigureCoordZInPM(Connector1.ID, Connector1.ActualZOrder[1]);//24.10.2012 ALine.ActualZOrder[1] := AHeight; end; end else // RT begin // RT1 := TConnectorObject(Connector1.JoinedConnectorsList[0]); RaiseConn := GetRaiseConn(RT1); // не вершина с-п и нет с-п if (RT1.FConnRaiseType = crt_None) and (RaiseConn = nil) then CreateRaiseOnNextObject(Connector1, ALine, AHeight) else begin // есть с-п и он межэтажный if (RaiseConn <> nil) and (RaiseConn.FConnRaiseType <> crt_OnFloor) then begin ChangeRaiseOnNextObject(Connector1, ALine, AHeight); end else if (RaiseConn = nil) and (ObjFromRaise <> nil) then begin RT1.ActualZOrder[1] := AHeight; SetConFigureCoordZInPM(RT1.ID, RT1.ActualZOrder[1]); //24.10.2012 Connector1.ActualZOrder[1] := AHeight; ALine.ActualZOrder[1] := AHeight; end else begin CreateRaiseOnNextObject(Connector1, ALine, AHeight); end; end; end; end else begin Connector1.ActualZOrder[1] := AHeight; SetConFigureCoordZInPM(Connector1.ID, Connector1.ActualZOrder[1]);//24.10.2012 ALine.ActualZOrder[1] := AHeight; end; end else // это вершина с-п или не нем есть с-п begin if (Connector1.FConnRaiseType <> crt_BetweenFloorUp) and (Connector1.FConnRaiseType <> crt_BetweenFloorDown) then ChangeRaiseOnNextObject(Connector1, ALine, AHeight); end; end; // 2 if Connector2.ActualZOrder[1] <> AHeight then begin // не вершина с-п и на нем нет с-п if (Connector2.FConnRaiseType = crt_None) and (GetRaiseConn(Connector2) = nil) then begin // -- Tolik -- 17/11/2015 //if (Connector2.JoinedConnectorsList.Count > 0) or (Connector2.JoinedOrtholinesList.Count > 1) then if ((Connector2.JoinedConnectorsList.Count > 0) and (not CheckConnectorCableElementsOnly(Connector2))) or (Connector2.JoinedOrtholinesList.Count > 1) then // begin // RT if (Connector2.ConnectorType = ct_Clear) and (Connector2.JoinedOrtholinesList.Count > 1) then begin if CheckNeedCreateRaiseOnRaiseTrace(ALine, Connector2, ATracesList) then CreateRaiseOnNextObject(Connector2, ALine, AHeight) else begin Connector2.ActualZOrder[1] := AHeight; SetConFigureCoordZInPM(Connector2.ID, Connector2.ActualZOrder[1]);//24.10.2012 ALine.ActualZOrder[2] := AHeight; end; end else begin // RT2 := TConnectorObject(Connector2.JoinedConnectorsList[0]); RaiseConn := GetRaiseConn(RT2); // не вершина с-п и нет с-п if (RT2.FConnRaiseType = crt_None) and (RaiseConn = nil) then CreateRaiseOnNextObject(Connector2, ALine, AHeight) else begin if (RaiseConn <> nil) and (RaiseConn.FConnRaiseType <> crt_OnFloor) then begin ChangeRaiseOnNextObject(Connector2, ALine, AHeight); end else if (RaiseConn = nil) and (ObjFromRaise <> nil) then begin RT2.ActualZOrder[1] := AHeight; SetConFigureCoordZInPM(RT2.ID, RT2.ActualZOrder[1]); Connector1.ActualZOrder[2] := AHeight; ALine.ActualZOrder[2] := AHeight; end else begin CreateRaiseOnNextObject(Connector2, ALine, AHeight); end; end; end; end else begin Connector2.ActualZOrder[1] := AHeight; SetConFigureCoordZInPM(Connector2.ID, Connector2.ActualZOrder[1]); //24.10.2012 ALine.ActualZOrder[2] := AHeight; end; end else // это вершина с-п или не нем есть с-п begin if (Connector2.FConnRaiseType <> crt_BetweenFloorUp) and (Connector2.FConnRaiseType <> crt_BetweenFloorDown) then ChangeRaiseOnNextObject(Connector2, ALine, AHeight); end; end; ALine.CalculLength := ALine.LengthCalc; ALine.LineLength := ALine.CalculLength; ALine.UpdateLengthTextBox(False, True); SetLineFigureCoordZInPM(ALine.ID, 1, ALine.ActualZOrder[1]); SetLineFigureCoordZInPM(ALine.ID, 2, ALine.ActualZOrder[2]); AutoDivideLine(ALine); //31.01.2011 - разделяем линию если нужно except on E: Exception do addExceptionToLogEx('U_Common.RaiseLineOnHeight', E.Message); end; BaseEndUpdate; end; *) Function CheckNeedCreateRaiseOnRaiseTrace(ALine: TOrthoLine; AJoinedConn: TConnectorObject; ATracesList: TList): Boolean; var i: integer; CurrLine: TOrthoLine; begin Result := False; //#From Oleg# try for i := 0 to AJoinedConn.JoinedOrtholinesList.Count - 1 do begin CurrLine := TOrthoLine(AJoinedConn.JoinedOrtholinesList[i]); if CurrLine <> ALine then begin if CheckNoFigureinList(CurrLine, ATracesList) then begin Result := True; Break; end; end; end; except on E: Exception do addExceptionToLogEx('U_Common.CheckNeedCreateRaiseOnRaiseTrace', E.Message); end; end; Function CreateBetweenFloorRaiseOnPointObject(APointObject: TConnectorObject; ARaiseType: TLineRaiseType): TConnectorObject; var ConnectedConn: TConnectorObject; RaiseConn: TConnectorObject; RaiseLine: TOrthoLine; x, y, z: double; i: integer; RaiseLineZ: Double; RaiseConnZ: Double; ObjParams: TObjectParams; begin Result := nil; BaseBeginUpdate; try x := APointObject.ActualPoints[1].x; y := APointObject.ActualPoints[1].y; z := APointObject.ActualZOrder[1]; RaiseConnZ := 0; //#From Oleg# if ARaiseType = lrt_Up then RaiseConnZ := GCadForm.FRoomHeight; if ARaiseType = lrt_Down then RaiseConnZ := 0; // создать присоединенный коннектор ConnectedConn := TConnectorObject.Create(x, y, z, APointObject.LayerHandle, mydsNormal, GCadForm.PCad); ConnectedConn.ConnectorType := ct_Clear; GCadForm.PCad.AddCustomFigure (GLN(APointObject.LayerHandle), ConnectedConn, False); ConnectedConn.Name := cCadClasses_Mes12; SetNewObjectNameInPM(ConnectedConn.ID, ConnectedConn.Name); ObjParams := GetFigureParams(ConnectedConn.ID); ConnectedConn.Name := ObjParams.Name; ConnectedConn.FIndex := ObjParams.MarkID; for i := 0 to APointObject.JoinedConnectorsList.Count - 1 do TConnectorObject(APointObject.JoinedConnectorsList[i]).ActualZOrder[1] := APointObject.ActualZOrder[1]; SetConFigureCoordZInPM(APointObject.ID, APointObject.ActualZOrder[1]); // создать подъем-спуск коннектор RaiseConn := TConnectorObject.Create(x + 10, y - 10, RaiseConnZ, APointObject.LayerHandle, mydsNormal, GCadForm.PCad); RaiseConn.ConnectorType := ct_Clear; // создать подъем-спуск линия RaiseLine := TOrthoLine.Create(x, y, z, x + 10, y - 10, RaiseConnZ, 1,ord(psSolid), clBlack, 0, APointObject.LayerHandle, mydsNormal, GCadForm.PCad, False); RaiseLine.SetJConnector1(TConnectorObject(ConnectedConn)); RaiseLine.SetJConnector2(TConnectorObject(RaiseConn)); RaiseLine.ActualZOrder[1] := ConnectedConn.ActualZOrder[1]; RaiseLine.ActualZOrder[2] := RaiseConn.ActualZOrder[1]; SetLineFigureCoordZInPM(RaiseLine.ID, 1, RaiseLine.ActualZOrder[1]); SetLineFigureCoordZInPM(RaiseLine.ID, 2, RaiseLine.ActualZOrder[2]); //Tolik 19/04/2017 -- RaiseConn.MoveConnector(APointOBject.ActualPoints[1].x - RaiseConn.ActualPoints[1].x, APointOBject.ActualPoints[1].y - RaiseConn.ActualPoints[1].y, False); // // приконнектить подъем SnapConnectorToPointObject(ConnectedConn, APointObject); //RaiseConn.MoveConnector(-10, 10, False); // СОЗДАТЬ НА КАД =========================================== GCadForm.PCad.AddCustomFigure (GLN(APointObject.LayerHandle), RaiseConn, False); RaiseConn.Name := cCadClasses_Mes26; SetNewObjectNameInPM(RaiseConn.ID, RaiseConn.Name); ObjParams := GetFigureParams(RaiseConn.ID); RaiseConn.Name := ObjParams.Name; RaiseConn.FIndex := ObjParams.MarkID; GCadForm.PCad.AddCustomFigure (GLN(APointObject.LayerHandle), RaiseLine, False); RaiseLine.Name := cCadClasses_Mes27; SetNewObjectNameInPM(RaiseLine.ID, RaiseLine.Name); ObjParams := GetFigureParams(RaiseLine.ID); RaiseLine.Name := ObjParams.Name; RaiseLine.FIndex := ObjParams.MarkID; if ARaiseType = lrt_Up then RaiseConn.FConnRaiseType := crt_BetweenFloorUp; if ARaiseType = lrt_Down then RaiseConn.FConnRaiseType := crt_BetweenFloorDown; RaiseConn.FObjectFromRaise := APointObject; RaiseLine.FIsRaiseUpDown := True; RaiseLine.FObjectFromRaisedLine := APointObject; RaiseLine.FLineRaiseType := ARaiseType; RaiseLine.CalculLength := RaiseLine.LengthCalc; RaiseLine.LineLength := RaiseLine.CalculLength; SetLineFigureLengthInPM(RaiseLine.ID, RaiseLine.LineLength); // RaiseLine.ReCreateCaptionsGroup(True, false); RaiseLine.UpdateLengthTextBox(True, false); RaiseLine.ReCreateNotesGroup(True); RaiseConn.LockMove := True; RaiseConn.LockModify := True; RaiseLine.LockMove := False; RaiseLine.LockModify := True; ConnectedConn.LockMove := True; ConnectedConn.LockModify := True; SetConnBringToFront(APointObject); SetConnBringToFront(RaiseConn); RefreshCAD(GCadForm.PCad); Result := RaiseConn; except on E: Exception do addExceptionToLogEx('U_Common.CreateBetweenFloorRaiseOnPointObject', E.Message); end; BaseEndUpdate; end; Function CreateBetweenFloorRaiseOnConnector(AConnector: TConnectorObject; ARaiseType: TLineRaiseType): TConnectorObject; var ConnectedConn: TConnectorObject; RaiseConn: TConnectorObject; RaiseLine: TOrthoLine; x, y, z: double; i: integer; RaiseConnZ: Double; RaiseLineZ: Double; ObjParams: TObjectParams; begin Result := nil; BaseBeginUpdate; try x := AConnector.ActualPoints[1].x; y := AConnector.ActualPoints[1].y; z := AConnector.ActualZOrder[1]; RaiseConnZ := 0; //#From Oleg# if ARaiseType = lrt_Up then RaiseConnZ := GCadForm.FRoomHeight else // Tolik 11/05/2018 -- if ARaiseType = lrt_Down then RaiseConnZ := 0; // создать подъем-спуск коннектор RaiseConn := TConnectorObject.Create(x, y, RaiseConnZ, AConnector.LayerHandle, mydsNormal, GCadForm.PCad); RaiseConn.ConnectorType := ct_Clear; // создать подъем-спуск линия RaiseLine := TOrthoLine.Create(x, y, z, x, y, RaiseConnZ, 1,ord(psSolid), clBlack, 0, AConnector.LayerHandle, mydsNormal, GCadForm.PCad, False); RaiseLine.SetJConnector1(TConnectorObject(AConnector)); RaiseLine.SetJConnector2(TConnectorObject(RaiseConn)); RaiseLine.ActualZOrder[1] := AConnector.ActualZOrder[1]; RaiseLine.ActualZOrder[2] := RaiseConn.ActualZOrder[1]; SetLineFigureCoordZInPM(RaiseLine.ID, 1, RaiseLine.ActualZOrder[1]); SetLineFigureCoordZInPM(RaiseLine.ID, 2, RaiseLine.ActualZOrder[2]); // СОЗДАТЬ НА КАД =========================================== GCadForm.PCad.AddCustomFigure (GLN(AConnector.LayerHandle), RaiseConn, False); RaiseConn.Name := cCadClasses_Mes26; SetNewObjectNameInPM(RaiseConn.ID, RaiseConn.Name); ObjParams := GetFigureParams(RaiseConn.ID); RaiseConn.Name := ObjParams.Name; RaiseConn.FIndex := ObjParams.MarkID; GCadForm.PCad.AddCustomFigure (GLN(AConnector.LayerHandle), RaiseLine, False); RaiseLine.Name := cCadClasses_Mes27; SetNewObjectNameInPM(RaiseLine.ID, RaiseLine.Name); ObjParams := GetFigureParams(RaiseLine.ID); RaiseLine.Name := ObjParams.Name; RaiseLine.FIndex := ObjParams.MarkID; if ARaiseType = lrt_Up then RaiseConn.FConnRaiseType := crt_BetweenFloorUp; if ARaiseType = lrt_Down then RaiseConn.FConnRaiseType := crt_BetweenFloorDown; RaiseConn.FObjectFromRaise := AConnector; RaiseLine.FIsRaiseUpDown := True; RaiseLine.FObjectFromRaisedLine := AConnector; RaiseLine.FLineRaiseType := ARaiseType; RaiseLine.CalculLength := RaiseLine.LengthCalc; RaiseLine.LineLength := RaiseLine.CalculLength; SetLineFigureLengthInPM(RaiseLine.ID, RaiseLine.LineLength); //Tolik 14/06/2016 -- нельзя такое комментить - вылезет подпись неизвестно где потом ... RaiseLine.ReCreateCaptionsGroup(True, false); // RaiseLine.UpdateLengthTextBox(True, false); RaiseLine.ReCreateNotesGroup(True); RaiseConn.LockMove := True; RaiseConn.LockModify := True; RaiseLine.LockMove := False; RaiseLine.LockModify := True; SetConnBringToFront(AConnector); SetConnBringToFront(RaiseConn); Result := RaiseConn; RefreshCAD(GCadForm.PCad); except on E: Exception do addExceptionToLogEx('U_Common.CreateBetweenFloorRaiseOnConnector', E.Message); end; BaseEndUpdate; end; // создать магистральный с-п на объекте Function CreateTrunkRaiseOnPointObject(APointObject: TConnectorObject; ARaiseType: TLineRaiseType; aTrunkLength: Double): TConnectorObject; var ConnectedConn: TConnectorObject; RaiseConn: TConnectorObject; RaiseLine: TOrthoLine; x, y, z: double; i: integer; RaiseLineZ: Double; RaiseConnZ: Double; ObjParams: TObjectParams; begin Result := nil; BaseBeginUpdate; try x := APointObject.ActualPoints[1].x; y := APointObject.ActualPoints[1].y; z := APointObject.ActualZOrder[1]; RaiseConnZ := 0; //#From Oleg# if ARaiseType = lrt_Up then RaiseConnZ := GCadForm.FRoomHeight; if ARaiseType = lrt_Down then RaiseConnZ := 0; // создать присоединенный коннектор ConnectedConn := TConnectorObject.Create(x, y, z, APointObject.LayerHandle, mydsNormal, GCadForm.PCad); ConnectedConn.ConnectorType := ct_Clear; GCadForm.PCad.AddCustomFigure (GLN(APointObject.LayerHandle), ConnectedConn, False); ConnectedConn.Name := cCadClasses_Mes12; SetNewObjectNameInPM(ConnectedConn.ID, ConnectedConn.Name); ObjParams := GetFigureParams(ConnectedConn.ID); ConnectedConn.Name := ObjParams.Name; ConnectedConn.FIndex := ObjParams.MarkID; for i := 0 to APointObject.JoinedConnectorsList.Count - 1 do TConnectorObject(APointObject.JoinedConnectorsList[i]).ActualZOrder[1] := APointObject.ActualZOrder[1]; SetConFigureCoordZInPM(APointObject.ID, APointObject.ActualZOrder[1]); // создать подъем-спуск коннектор RaiseConn := TConnectorObject.Create(x + 10, y - 10, RaiseConnZ, APointObject.LayerHandle, mydsNormal, GCadForm.PCad); RaiseConn.ConnectorType := ct_Clear; // создать подъем-спуск линия RaiseLine := TOrthoLine.Create(x, y, z, x + 10, y - 10, RaiseConnZ, 1,ord(psSolid), clBlack, 0, APointObject.LayerHandle, mydsNormal, GCadForm.PCad, False); RaiseLine.SetJConnector1(TConnectorObject(ConnectedConn)); RaiseLine.SetJConnector2(TConnectorObject(RaiseConn)); RaiseLine.ActualZOrder[1] := ConnectedConn.ActualZOrder[1]; RaiseLine.ActualZOrder[2] := RaiseConn.ActualZOrder[1]; SetLineFigureCoordZInPM(RaiseLine.ID, 1, RaiseLine.ActualZOrder[1]); SetLineFigureCoordZInPM(RaiseLine.ID, 2, RaiseLine.ActualZOrder[2]); //Tolik 19/04/2017 -- RaiseConn.MoveConnector(APointOBject.ActualPoints[1].x - RaiseConn.ActualPoints[1].x, APointOBject.ActualPoints[1].y - RaiseConn.ActualPoints[1].y, False); // // приконнектить подъем SnapConnectorToPointObject(ConnectedConn, APointObject); //RaiseConn.MoveConnector(-10, 10, False); // СОЗДАТЬ НА КАД =========================================== GCadForm.PCad.AddCustomFigure (GLN(APointObject.LayerHandle), RaiseConn, False); RaiseConn.Name := cCadClasses_Mes30; SetNewObjectNameInPM(RaiseConn.ID, RaiseConn.Name); ObjParams := GetFigureParams(RaiseConn.ID); RaiseConn.Name := ObjParams.Name; RaiseConn.FIndex := ObjParams.MarkID; GCadForm.PCad.AddCustomFigure (GLN(APointObject.LayerHandle), RaiseLine, False); RaiseLine.Name := cCadClasses_Mes31; SetNewObjectNameInPM(RaiseLine.ID, RaiseLine.Name); ObjParams := GetFigureParams(RaiseLine.ID); RaiseLine.Name := ObjParams.Name; RaiseLine.FIndex := ObjParams.MarkID; if ARaiseType = lrt_Up then RaiseConn.FConnRaiseType := crt_TrunkUp; if ARaiseType = lrt_Down then RaiseConn.FConnRaiseType := crt_TrunkDown; RaiseConn.FObjectFromRaise := APointObject; RaiseLine.FIsRaiseUpDown := True; RaiseLine.FObjectFromRaisedLine := APointObject; RaiseLine.FLineRaiseType := ARaiseType; // LENGTH !!! RaiseLine.CalculLength := RaiseLine.LengthCalc; // RaiseLine.LineLength := RaiseLine.CalculLength + aAddTrunkLength; RaiseLine.LineLength := aTrunkLength; RaiseLine.UserLength := aTrunkLength; SetLineFigureLengthInPM(RaiseLine.ID, RaiseLine.LineLength); RaiseLine.UpdateLengthTextBox(True, false); RaiseLine.ReCreateNotesGroup(True); RaiseConn.LockMove := True; RaiseConn.LockModify := True; RaiseLine.LockMove := False; RaiseLine.LockModify := True; ConnectedConn.LockMove := True; ConnectedConn.LockModify := True; SetConnBringToFront(APointObject); SetConnBringToFront(RaiseConn); RefreshCAD(GCadForm.PCad); Result := RaiseConn; except on E: Exception do AddExceptionToLogEx('U_Common.CreateTrunkRaiseOnPointObject', E.Message); end; BaseEndUpdate; end; // создать магистральный с-п на коннекторе Function CreateTrunkRaiseOnConnector(AConnector: TConnectorObject; ARaiseType: TLineRaiseType; aTrunkLength: Double): TConnectorObject; var ConnectedConn: TConnectorObject; RaiseConn: TConnectorObject; RaiseLine: TOrthoLine; x, y, z: double; i: integer; RaiseConnZ: Double; RaiseLineZ: Double; ObjParams: TObjectParams; begin Result := nil; BaseBeginUpdate; try x := AConnector.ActualPoints[1].x; y := AConnector.ActualPoints[1].y; z := AConnector.ActualZOrder[1]; RaiseConnZ := 0; //#From Oleg# if ARaiseType = lrt_Up then RaiseConnZ := GCadForm.FRoomHeight; if ARaiseType = lrt_Down then RaiseConnZ := 0; // создать подъем-спуск коннектор RaiseConn := TConnectorObject.Create(x, y, RaiseConnZ, AConnector.LayerHandle, mydsNormal, GCadForm.PCad); RaiseConn.ConnectorType := ct_Clear; // создать подъем-спуск линия RaiseLine := TOrthoLine.Create(x, y, z, x, y, RaiseConnZ, 1,ord(psSolid), clBlack, 0, AConnector.LayerHandle, mydsNormal, GCadForm.PCad, False); RaiseLine.SetJConnector1(TConnectorObject(AConnector)); RaiseLine.SetJConnector2(TConnectorObject(RaiseConn)); RaiseLine.ActualZOrder[1] := AConnector.ActualZOrder[1]; RaiseLine.ActualZOrder[2] := RaiseConn.ActualZOrder[1]; SetLineFigureCoordZInPM(RaiseLine.ID, 1, RaiseLine.ActualZOrder[1]); SetLineFigureCoordZInPM(RaiseLine.ID, 2, RaiseLine.ActualZOrder[2]); // СОЗДАТЬ НА КАД =========================================== GCadForm.PCad.AddCustomFigure (GLN(AConnector.LayerHandle), RaiseConn, False); RaiseConn.Name := cCadClasses_Mes30; SetNewObjectNameInPM(RaiseConn.ID, RaiseConn.Name); ObjParams := GetFigureParams(RaiseConn.ID); RaiseConn.Name := ObjParams.Name; RaiseConn.FIndex := ObjParams.MarkID; GCadForm.PCad.AddCustomFigure (GLN(AConnector.LayerHandle), RaiseLine, False); RaiseLine.Name := cCadClasses_Mes31; SetNewObjectNameInPM(RaiseLine.ID, RaiseLine.Name); ObjParams := GetFigureParams(RaiseLine.ID); RaiseLine.Name := ObjParams.Name; RaiseLine.FIndex := ObjParams.MarkID; if ARaiseType = lrt_Up then RaiseConn.FConnRaiseType := crt_TrunkUp; if ARaiseType = lrt_Down then RaiseConn.FConnRaiseType := crt_TrunkDown; RaiseConn.FObjectFromRaise := AConnector; RaiseLine.FIsRaiseUpDown := True; RaiseLine.FObjectFromRaisedLine := AConnector; RaiseLine.FLineRaiseType := ARaiseType; // LENGTH !!! RaiseLine.CalculLength := RaiseLine.LengthCalc; // RaiseLine.LineLength := RaiseLine.CalculLength + aAddTrunkLength; RaiseLine.LineLength := aTrunkLength; RaiseLine.UserLength := aTrunkLength; SetLineFigureLengthInPM(RaiseLine.ID, RaiseLine.LineLength); RaiseLine.UpdateLengthTextBox(True, false); RaiseLine.ReCreateNotesGroup(True); RaiseConn.LockMove := True; RaiseConn.LockModify := True; RaiseLine.LockMove := False; RaiseLine.LockModify := True; SetConnBringToFront(AConnector); SetConnBringToFront(RaiseConn); Result := RaiseConn; RefreshCAD(GCadForm.PCad); except on E: Exception do AddExceptionToLogEx('U_Common.CreateTrunkRaiseOnConnector', E.Message); end; BaseEndUpdate; end; // Переоткрыть лист на CAD Procedure ReOpenListInCAD(AListID: Integer; const AListName: string); var AddLayer: TLayer; NewTab: TTabSheet; MenuItem: TMenuItem; i, j: integer; ListStream: TMemoryStream; //08.09.2011 Buffer: array[0..1023] of Char; TempPath: string; ListCaption: string; fFileName: string; Figure: TFigure; ObjIdx: Integer; ListParams: TListParams; //Tolik CadFigList: TList; // begin try ListParams := GetListParams(AListID); // создать лист в проекте TF_CAD.Create(FSCS_Main); GCadForm.FCADListID := AListID; // List ID GCadForm.FCADListName := AListName; // List name if AListName = '' then GCadForm.FCADListName := ListParams.Name; GCadForm.FCADProjectName := GetCurrProjectName; // Project Name LoadSettingsForList(AListID, False); //17.08.2012 ListCaption := GetListParams(GCadForm.FCADListID).Caption; ListCaption := ListParams.Caption; SetIsOpenedListInCADToPM(AListID, True); // Добавить переключатель в панель листов проекта NewTab := TTabSheet.Create(nil); NewTab.PageControl := FSCS_Main.pageCADList; NewTab.Tag := GCadForm.Handle; NewTab.Caption := ListCaption; FSCS_Main.pageCADList.ActivePage := NewTab; // Добавить Листы в главное меню for i := 0 to FSCS_Main.mainWindow.Count - 1 do if FSCS_Main.mainWindow.Items[i].Caption = '-' then break; j := 0; inc(i); while FSCS_Main.mainWindow.Count > i do begin MenuItem := FSCS_Main.mainWindow.Items[FSCS_Main.mainWindow.Count - 1]; FSCS_Main.mainWindow.Delete(FSCS_Main.mainWindow.Count - 1); MenuItem.Free; end; for j := 0 to FSCS_Main.pageCADList.PageCount - 1 do begin MenuItem := TMenuItem.Create(nil); MenuItem.Caption := FSCS_Main.pageCADList.Pages[j].Caption; MenuItem.Tag := FSCS_Main.pageCADList.Pages[j].Tag; MenuItem.AutoCheck := True; MenuItem.RadioItem := True; MenuItem.Checked := FSCS_Main.pageCADList.Pages[j] = FSCS_Main.pageCADList.ActivePage; MenuItem.OnClick := FSCS_Main.SwitchWindow; FSCS_Main.mainWindow.Add(MenuItem); end; // поднять Stream с листа ListStream := GetCadDataFromPM(AListID, fFileName); if ListStream <> nil then begin TempPath := GetAnsiTempPath; //08.09.2011 SetString(TempPath, Buffer, GetTempPath(Sizeof(Buffer) - 1, Buffer)); ListStream.SaveToFile(TempPath + 'tempCAD.pwd'); // подгрузить из файла GCadForm.PCad.OnObjectInserted := Nil; GCadForm.PCad.LoadFromFile(TempPath + 'tempCAD.pwd'); GCadForm.PCad.OnObjectInserted := GCadForm.PCadObjectInserted; end else if fFileName <> '' then begin // подгрузить из файла GCadForm.PCad.OnObjectInserted := Nil; GCadForm.PCad.LoadFromFile(fFileName); GCadForm.PCad.OnObjectInserted := GCadForm.PCadObjectInserted; end; if (ListStream <> nil) or (fFileName <> '') then begin // для старых проектов - пересоздать слои if GCadForm.PCad.LayerCount = 7 then begin AddLayer := TLayer.Create(cCad_Mes7); GCadForm.PCad.Layers.Add(Addlayer); end; if GCadForm.PCad.LayerCount = 8 then begin AddLayer := TLayer.create(cCad_Mes8); GCadForm.PCad.Layers.Add(AddLayer); end; RaiseActiveNet(GCadForm); if GCadForm.PCad.LayerCount = 9 then begin AddLayer := TLayer.create(cCad_Mes29); GCadForm.PCad.Layers.Add(AddLayer); end; {//17.11.2011 GCadForm.FFrameProjectName := nil; GCadForm.FFrameListName := nil; GCadForm.FFrameCodeName := nil; GCadForm.FFrameIndexName := nil;} GCadForm.ClearFrameFigures; GNeedReRaiseProperties := False; //Tolik CadFigList := TList.Create; for i := 0 to GCadForm.PCad.FigureCount - 1 do CadFigList.Add(TFigure(GCadForm.PCad.Figures.Items[i])); for i := 0 to GCadForm.PCad.FigureCount - 1 do begin Figure := TFigure(GCadForm.PCad.Figures.Items[i]); if CheckFigureByClassName(Figure, cTConnectorObject) then TConnectorObject(Figure).RaiseProperties(CadFigList) else if CheckFigureByClassName(Figure, cTOrthoLine) then TOrthoLine(Figure).RaiseProperties(CadFigList) else if CheckFigureByClassName(Figure, cTFrame) then TFrame(Figure).RaiseProperties else if CheckFigureByClassName(Figure, cTPlanTrace) then TPlanTrace(Figure).RaiseProperties(CadFigList) else if CheckFigureByClassName(Figure, cTPlanObject) then TPlanObject(Figure).RaiseProperties(CadFigList) else if CheckFigureByClassName(Figure, cTPlanConnector) then TPlanConnector(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, 'TRichText') then begin {//17.11.2011 if TRichText(Figure).DataID = 100 then GCadForm.FFrameProjectName := TRichText(Figure); if TRichText(Figure).DataID = 200 then GCadForm.FFrameListName := TRichText(Figure); if TRichText(Figure).DataID = 300 then GCadForm.FFrameCodeName := TRichText(Figure); if TRichText(Figure).DataID = 400 then GCadForm.FFrameIndexName := TRichText(Figure);} ObjIdx := GCadForm.FFrameObjects.IndexOf(IntToStr(TRichText(Figure).DataID)); if ObjIdx <> -1 then GCadForm.FFrameObjects.Objects[ObjIdx] := TRichText(Figure); end else if CheckFigureByClassName(Figure, cTSCSFigureGrp) then TSCSFigureGrp(Figure).RaiseProperties(CadFigList) else if CheckFigureByClassName(Figure, cTHouse) then THouse(Figure).RaiseProperties(CadFigList); end; //Tolik // все сделано на райзе за один проход // поэтому рерайз пока устраним {if GNeedReRaiseProperties then begin i := 0; while i < GCadForm.PCad.FigureCount do begin Figure := TFigure(GCadForm.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; } //Tolik FreeAndNil(CadFigList); // GCadForm.SetFrameFigures; CorrectStampView; SetVisibleCabinetsNumbers(GCadForm.FShowCabinetsNumbers); SetVisibleCabinetsBounds(GCadForm.FShowCabinetsBounds); FindObjectsForConvertClasses; SetCADFrameParams(GCadForm); if GListRaiseWithErrors then begin ShowLog; GListRaiseWithErrors := False; end; end; if ListStream <> nil then FreeAndNil(ListStream); GCadForm.WindowState := wsMaximized; SwitchListInPM(GCadForm.FCADListID, ''); if GCadForm.FListType = lt_Normal then begin FSCS_Main.aSetSCSLayer.Execute; EnableOptionsForNormalList; end else if GCadForm.FListType = lt_DesignBox then begin FSCS_Main.aSetSubstrateLayer.Execute; DisableOptionsForDesignList; end else if GCadForm.FListType = lt_ProjectPlan then begin FSCS_Main.aSetSubstrateLayer.Execute; DisableOptionsForDesignList; end // Tolik 10/02/2021 -- else if GCadForm.FListType = lt_ElScheme then begin FSCS_Main.aSetSubstrateLayer.Execute; DisableOptionsForEl_Scheme; end else if GCadForm.FListType = lt_AScheme then begin FSCS_Main.aSetSubstrateLayer.Execute; DisableOptionsForEl_Scheme; end; RefreshCAD(GCadForm.PCad); except on E: Exception do addExceptionToLogEx('U_Common.ReOpenListInCAD', E.Message); end; // Tolik 13/06/2017 -- if GCadForm <> nil then begin if GCadForm.FListSettings.ShowTracesCrossPoints > 0 then ShowTracesIntersections(2, GCadForm.FListSettings.ShowTracesCrossPoints); // 13/09/2017 -- GCadForm.PCad.Refresh; end; // end; Procedure ReOpenListInCADIfClosed(AListID: Integer; const AListName: string); begin if Not CheckListExist(AListID) then begin ProcessMessagesEx; ReopenListInCAD(AListID, ''); ProcessMessagesEx; end; end; Function CheckListExist(AListID: integer): Boolean; begin Result := False; try if GetListByID(AListID) <> nil then Result := True; except on E: Exception do addExceptionToLogEx('U_Common.CheckListExist', E.Message); end; end; // переход по проектам (выгрузка старого) Procedure UnloadCurrentProject; begin try FSCS_Main.CloseAll; except on E: Exception do addExceptionToLogEx('U_Common.UnloadCurrentProject', E.Message); end; end; // переход по проектам (загрузка нового) Procedure LoadNewProject(AListsID: TList; ACurrentListID: Integer); var i, j: integer; ID: integer; IDPointer: ^Integer; LName: string; FirstListID: Integer; //Tolik 28/08/2019 -- //OldTick, CurrTick: Cardinal; OldTick, CurrTick: DWord; // OldQuotaMessCount: Integer; // Tolik -- 01/03/2017 -- CloseList: TList; FormsList: TList; PM_TreeView_Clear: Boolean; ChangeFlag: Boolean; // Node, ChildNode: TTreeNode; {procedure CheckProjTree(aCad: TF_Cad); var currList: TSCSList; i: Integer; begin currList := F_ProjMan.GSCSBase.CurrProject.GetListBySCSID(aCAD.FCADListID); if currList <> nil then begin if currList.TreeViewNode <> nil then begin node := currList.TreeViewNode; if Node.Parent <> nil then end; end;} Procedure ClearPMNodes(aCad: TF_Cad); Var currList: TSCSList; CanClearFigures: Boolean; i: Integer; begin CanClearFigures := False; currList := F_ProjMan.GSCSBase.CurrProject.GetListBySCSID(aCAD.FCADListID); if currList <> nil then begin // PM_TreeView_Clear := True; if currList.TreeViewNode <> nil then begin node := currList.TreeViewNode; if Node.Count > 0 then CanclearFigures := True; Node.StateIndex := -2; if Node.Expanded then Node.Collapse(False); end; end; if CanClearFigures then begin aCAD.FSCSFigures.Clear; aCAD.PCad.Figures.Clear; // if aCad.FNotSCSDeletedFiguresList <> nil then // FreeAndNil(aCad.FNotSCSDeletedFiguresList); // иначе трабла на закрытии листа //TF_CAD(aCAD).Close; end; end; // begin OldTick := GetTickCount; CloseList := TList.Create; //FormsList := TList.Create; PM_TreeView_Clear := False; GIsProjectOpening := True; // Tolik 25/01/2021 -- try FirstListID := 0; //#From Oleg# OldQuotaMessCount := GUserOBjectsQuotaLimit_Message_Counter; for i := 0 to AListsID.Count - 1 do begin // Tolik -- 15/11/2016-- GCanRefreshCad := False; // try // Tolik -- 01/03/2017 -- // при превышении квоты -- остановить загрузку листов // if OldQuotaMessCount <> GUserOBjectsQuotaLimit_Message_Counter then // break; // // Tolik 03/07/2017 -- сброс для CashedCompon (чтобы не пришли значения с предидущего проекта) if Assigned(F_ProjMan) then if TF_Main(F_ProjMan).CashedCompon <> nil then TF_Main(F_ProjMan).CashedCompon.Clear; if Assigned(F_NormBase) then if TF_Main(F_NormBase).CashedCompon <> nil then TF_Main(F_NormBase).CashedCompon.Clear; // IDPointer := AListsID[i]; ID := IDPointer^; if i = 0 then FirstListID := ID; LName := GetListNameFromPM(ID); OpenListsInProject(ID, LName); //if OldQuotaMessCount <> GUserOBjectsQuotaLimit_Message_Counter then if (GCadForm.PCad.FBreakedOnQuota or (GCadForm.PCad.Figures.Count = 0)) then CloseList.Add(GCadForm); {else FormsList.Add(GCadForm);} except on E: Exception do; end; // Tolik -- 15/11/2016-- GCanRefreshCad := True; // end; // Tolik -- 01/03/2017 -- if CloseList.Count > 0 then begin PM_TreeView_Clear := True; for i := 0 to CloseList.Count - 1 do ClearPMNodes(TF_CAD(CloseList[i])); end; // Tolik -- 01/03/2017 -- // если записали/подняли проект с багами -- почистить ПМ от // объектов, которых нет на КАДе (т.е. очистить лист в ПМ) { for i := FormsList.Count - 1 downto 0 do begin if TF_CAD(FormsList[i]).PCad.Figures.Count < 3 then ClearPMNodes(TF_CAD(FormsList[i])); end; } //FreeAndNil(FormsList); FreeAndNil(CloseList); // if GetCurrProjectParams.DefListSetting.SCSType = st_Internal then FSCS_Main.aMarkingPages.Enabled := True else if GetCurrProjectParams.DefListSetting.SCSType = st_External then FSCS_Main.aMarkingPages.Enabled := False; // Tolik 01/03/2017 -- { if ACurrentListID = - 1 then SwitchListInCAD(FirstListID, '') else SwitchListInCAD(ACurrentListID, ''); } if ((ACurrentListID = - 1) or PM_TreeView_Clear) then SwitchListInCAD(FirstListID, '') else SwitchListInCAD(ACurrentListID, ''); // except on E: Exception do addExceptionToLogEx('U_Common.LoadNewProject', E.Message); end; CurrTick := GetTickCount - OldTick; CurrTick := GetTickCount - OldTick; GIsProjectOpening := False; // end; // сравнение двух чисел типа Double function DoubleCMP(Double1, Double2: Double): Boolean; var String1, String2: string; begin Result := false; try String1 := FormatFloat('0.00', Double1); String2 := FormatFloat('0.00', Double2); Double1 := StrToFloat_My(String1); Double2 := StrToFloat_My(String2); if Double1 = Double2 then Result := True else Result := False; except on E: Exception do addExceptionToLogEx('U_Common.DoubleCMP', E.Message); end; end; procedure SetConnBringToFront(AConnector: TConnectorObject); begin try GCadForm.PCad.DeselectAll(2); AConnector.Select; GCadForm.PCad.RecordUndo := True; GCadForm.PCad.OrderSelection(osFront); GCadForm.PCad.RecordUndo := False; AConnector.Deselect; except end; end; function GetAllFiguresByClass(ACADForm: TF_CAD; aClass: TClass): TList; var i: Integer; procedure CheckFigure(aFigure: TFigure); var i: Integer; CurrFigure: TFigure; begin if aFigure is aClass then Result.Add(aFigure) else if aFigure is TFigureGrp then for i := 0 to TFigureGrp(aFigure).InFigures.Count - 1 do CheckFigure(TFigure(TFigureGrp(aFigure).InFigures[i])); end; begin Result := TList.Create; for i := 0 to ACADForm.PCad.FigureCount - 1 do CheckFigure(TFigure(ACADForm.PCad.Figures[i])); end; function GetAllFiguresByClassFromProj(aClass: TClass): TList; var i, j: Integer; List: TForm; procedure CheckFigure(aFigure: TFigure); var i: Integer; CurrFigure: TFigure; begin if aFigure is aClass then Result.Add(aFigure) else if aFigure is TFigureGrp then for i := 0 to TFigureGrp(aFigure).InFigures.Count - 1 do CheckFigure(TFigure(TFigureGrp(aFigure).InFigures[i])); end; begin Result := TList.Create; for i := 0 to FSCS_Main.MDIChildCount - 1 do begin List := FSCS_Main.MDIChildren[i]; if List is TF_CAD then for j := 0 to TF_CAD(List).PCad.FigureCount - 1 do CheckFigure(TFigure(TF_CAD(List).PCad.Figures[j])); end; end; function GetFigureByID(ACADForm: TF_CAD; AID_Figure: Integer): TFigure; var i: integer; FFigure: TFigure; FigLayerHandle1: Integer; FigLayerHandle2: Integer; begin Result := nil; try if (ACADForm <> nil) and (ACADForm.PCad <> nil) then begin Result := TFigure(ACADForm.FSCSFigures.GetObject(AID_Figure)); if Result = nil then begin FigLayerHandle1 := ACADForm.PCad.GetLayerHandle(lnSCSCommon); FigLayerHandle2 := ACADForm.PCad.GetLayerHandle(lnRoom); for i := 0 to ACadForm.PCad.FigureCount - 1 do begin FFigure := TFigure(ACadForm.PCad.Figures[i]); if (FFigure.LayerHandle = FigLayerHandle1) or (FFigure.LayerHandle = FigLayerHandle2) then begin if CheckFigureByClassName(FFigure, cTConnectorObject) or CheckFigureByClassName(FFigure, cTOrthoLine) then //if CheckFigureByClassIdx(FFigure, ciTConnectorObject) or CheckFigureByClassIdx(FFigure, ciTOrthoLine) then begin if FFigure.ID = AID_Figure then begin Result := FFigure; Break; end; end else if CheckFigureByClassName(FFigure, cTCabinet) then //else if CheckFigureByClassIdx(FFigure, ciTCabinet) then begin if TCabinet(FFigure).FSCSID = AID_Figure then begin Result := FFigure; Break; end; end else if CheckFigureByClassName(FFigure, cTCabinetExt) then //else if CheckFigureByClassIdx(FFigure, ciTCabinetExt) then begin if TCabinetExt(FFigure).FSCSID = AID_Figure then begin Result := FFigure; Break; end; end; end; end; end; end; except on E: Exception do addExceptionToLogEx('U_Common.GetFigureByID', E.Message); end; end; function GetFigureByOrign(aFigureList: TList): TFigure; var Figure: TFigure; FigurePointCount: Integer; MinFigDist: Double; MinPointDist: Double; pDist: Double; i, j: Integer; begin Result := nil; MinFigDist := -1; for i := 0 to aFigureList.Count - 1 do begin Figure := TFigure(aFigureList[i]); FigurePointCount := Figure.PointCount; if Figure.ClassName = TConnectorObject.ClassName then FigurePointCount := 4; if FigurePointCount > 0 then begin MinPointDist := -1; for j := 1 to FigurePointCount do begin pDist := GetLineLenght(Figure.ActualPoints[j], DoublePoint(0,0)); if (MinPointDist = -1) or (pDist < MinPointDist) then MinPointDist := pDist; end; if (MinFigDist = -1) or (MinPointDist < MinFigDist) then begin Result := Figure; MinFigDist := MinPointDist; end; end; end; end; function GetFigureByIDProj(AID_Figure: Integer): TFigure; var CADForm: TF_CAD; i: Integer; begin Result := nil; for i := 0 to FSCS_Main.MDIChildCount - 1 do begin CADForm := TF_CAD(FSCS_Main.MDIChildren[i]); Result := GetFigureByID(CADForm, AID_Figure); if Result <> nil then Break; //// BREAK //// end; end; function GetHouseByID(ACADForm: TF_CAD; AID_Figure: Integer): THouse; var i: integer; FFigure: TFigure; begin Result := nil; try if (ACADForm <> nil) and (ACADForm.PCad <> nil) then begin for i := 0 to ACadForm.PCad.FigureCount - 1 do begin FFigure := TFigure(ACadForm.PCad.Figures[i]); if CheckFigureByClassName(FFigure, cTHouse) then begin if FFigure.ID = AID_Figure then begin Result := THouse(FFigure); Break; end; end; end; end; except on E: Exception do AddExceptionToLogEx('U_Common.GetHouseByID', E.Message); end; end; function GetApproachByComponID(ACADForm: TF_CAD; AID_Compon: Integer): TConnectorObject; var i: integer; FFigure: TFigure; begin Result := nil; try if (ACADForm <> nil) and (ACADForm.PCad <> nil) then begin for i := 0 to ACadForm.PCad.FigureCount - 1 do begin FFigure := TFigure(ACadForm.PCad.Figures[i]); if CheckFigureByClassName(FFigure, cTConnectorObject) and (TConnectorObject(FFigure).FIsApproach) then begin if TConnectorObject(FFigure).FComponID = AID_Compon then begin Result := TConnectorObject(FFigure); Break; end; end; end; end; except on E: Exception do AddExceptionToLogEx('', E.Message); end; end; function GetFigureByIDInSCSFigureGroups(ACADForm: TF_CAD; AID_Figure: Integer): TFigure; var i, j: integer; SCSFigureGrp: TSCSFigureGrp; FFigure: TFigure; begin Result := nil; try if (ACADForm <> nil) and (ACADForm.PCad <> nil) then begin for i := 0 to ACadForm.PCad.FigureCount - 1 do begin if CheckFigureByClassName(TFigure(ACadForm.PCad.Figures[i]), cTSCSFigureGrp) then begin SCSFigureGrp := TSCSFigureGrp(ACadForm.PCad.Figures[i]); for j := 0 to SCSFigureGrp.InFigures.Count - 1 do begin FFigure := TFigure(SCSFigureGrp.InFigures[j]); if CheckFigureByClassName(FFigure, cTConnectorObject) or CheckFigureByClassName(FFigure, cTOrthoLine) then begin if FFigure.ID = AID_Figure then begin Result := FFigure; Exit; end; end; end; end; end; end; except on E: Exception do addExceptionToLogEx('U_Common.GetFigureByIDInSCSFigureGroups', E.Message); end; end; function GetFigureByIDInSCSFigureGrp(ASCSFigureGrp: TSCSFigureGrp; AID_Figure: Integer): TFigure; var i, j: integer; SCSFigureGrp: TSCSFigureGrp; FFigure: TFigure; begin Result := nil; try for i := 0 to ASCSFigureGrp.InFigures.Count - 1 do begin FFigure := TFigure(ASCSFigureGrp.InFigures[i]); if CheckFigureByClassName(FFigure, cTConnectorObject) or CheckFigureByClassName(FFigure, cTOrthoLine) then begin if FFigure.ID = AID_Figure then begin Result := FFigure; Exit; end; end; end; except on E: Exception do addExceptionToLogEx('U_Common.GetFigureByIDInSCSFigureGrp', E.Message); end; end; function GetSCSFigureGrp(ACADForm: TF_CAD; AID_Figure: Integer): TSCSFigureGrp; var i, j: integer; SCSFigureGrp: TSCSFigureGrp; FFigure: TFigure; begin Result := nil; try if (ACADForm <> nil) and (ACADForm.PCad <> nil) then begin for i := 0 to ACadForm.PCad.FigureCount - 1 do begin if CheckFigureByClassName(TFigure(ACadForm.PCad.Figures[i]), cTSCSFigureGrp) then begin SCSFigureGrp := TSCSFigureGrp(ACadForm.PCad.Figures[i]); for j := 0 to SCSFigureGrp.InFigures.Count - 1 do begin FFigure := TFigure(SCSFigureGrp.InFigures[j]); if CheckFigureByClassName(FFigure, cTConnectorObject) or CheckFigureByClassName(FFigure, cTOrthoLine) then begin if FFigure.ID = AID_Figure then begin Result := SCSFigureGrp; Exit; end; end; end; end; end; end; except on E: Exception do addExceptionToLogEx('U_Common.GetSCSFigureGrp', E.Message); end; end; function GetListByID(AID_List: Integer): TF_CAD; var i: integer; begin Result := nil; try for i := 0 to FSCS_Main.MDIChildCount - 1 do begin if TF_CAD(FSCS_Main.MDIChildren[i]).FCADListID = AID_List then begin Result := TF_CAD(FSCS_Main.MDIChildren[i]); break; end; end; except on E: Exception do addExceptionToLogEx('U_Common.GetListByID', E.Message); end; end; Function GetListOfPassage(AListID: Integer): TF_CAD; begin Result := nil; try Result := GetListByID(AListID); except on E: Exception do addExceptionToLogEx('U_Common.GetListOfPassage', E.Message); end; end; //Tolik -- 10/04/2018 Function SnapConnectorToConnector(AConnector, ASnapConnector: TConnectorObject; AOnRaise: Boolean = false): TConnectorObject; var i, j: integer; NewDeltaX, NewDeltaY: double; OLine: TOrthoLine; TempFigure: TFigure; PrevLine: TOrthoLine; CurrentLine: TOrthoLine; SplitFigure: TOrthoLine; ObjectFromRaise: TConnectorObject; RaiseConn: TConnectorObject; RaiseLine: TOrthoLine; ObjParams: TObjectParams; JoinedLine: TOrthoLine; OtherList: TF_CAD; OtherRaise: TConnectorObject; // House: THouse; HouseIndex: Integer; // Tolik -- 20/03/2017 -- NB_Conn: TConnectorObject; SwapConnectors: Boolean; // // Tolik -- 05/12/2016 -- проверка, чтобы не убить коннектор райза или межэтажки/магистрали function CheckIsRaise(aConn: TConnectorObject): Boolean; var i: Integer; begin Result := False; for i := 0 to AConn.JoinedOrthoLinesList.Count - 1 do begin if TOrthoLine(AConn.JoinedOrthoLinesList[i]).FIsRaiseUpDown then begin Result := True; break; end; end; end; begin Result := AConnector; if AConnector.Deleted or ASnapConnector.Deleted then Exit; // Tolik 08/11/2017 -- на всякий, бывали преценденты.... if aConnector.ID = ASnapConnector.ID then exit; // SwapConnectors := False; if CheckIsRaise(ASnapConnector) then //if (AConnector.FConnRaiseType = crt_None) and (ASnapConnector.FConnRaiseType <> crt_None) then begin AConnector := ASnapConnector; ASnapConnector := Result; Result := AConnector; SwapConnectors := True; end; try NewDeltaX := 0; NewDeltaY := 0; {// #Oleg Commented#} if Not AOnRaise then FindConnectionsInterfaces(AConnector, ASnapConnector); // { if AConnector.joinedOrtholinesList.count > 0 then begin if (ASnapConnector.ActualZOrder[1]>=TOrtholine(AConnector.JoinedOrtholinesList[0]).ActualZOrder[1]) and(ASnapConnector.ActualZOrder[1]>=TOrtholine(AConnector.JoinedOrtholinesList[0]).ActualZOrder[2]) then begin if TOrtholine(AConnector.JoinedOrtholinesList[0]).ActualZOrder[1] < TOrtholine(AConnector.JoinedOrtholinesList[0]).ActualZOrder[2] then AConnector.ActualZOrder[1] := TOrtholine(AConnector.joinedOrtholinesList[0]).ActualZOrder[1] else AConnector.ActualZOrder[1] := TOrtholine(AConnector.joinedOrtholinesList[0]).ActualZOrder[2]; end else begin if TOrtholine(AConnector.JoinedOrtholinesList[0]).ActualZOrder[1] < TOrtholine(AConnector.JoinedOrtholinesList[0]).ActualZOrder[2] then AConnector.ActualZOrder[1] := TOrtholine(AConnector.joinedOrtholinesList[0]).ActualZOrder[2] else AConnector.ActualZOrder[1] := TOrtholine(AConnector.joinedOrtholinesList[0]).ActualZOrder[1]; end; end else } // // AConnector.ActualZOrder[1] := ASnapConnector.ActualZOrder[1]; //Tolik {if AOnRaise then AConnector.ActualZOrder[1] := ASnapConnector.ActualZOrder[1];} // { if AOnRaise then AConnector.ActualZOrder[1] := ASnapConnector.ActualZOrder[1]; } { AConnector.FConnRaiseType := ASnapConnector.FConnRaiseType; AConnector.FObjectFromRaise := ASnapConnector.FObjectFromRaise; AConnector.tmpParentDupID := ASnapConnector.tmpParentDupID; // House AConnector.fHouse := ASnapConnector.fHouse; AConnector.FIsHouseJoined := ASnapConnector.FIsHouseJoined; if (ASnapConnector.FIsHouseJoined) and (ASnapConnector.fHouse <> nil) then begin House := ASnapConnector.fHouse; HouseIndex := House.fJoined.IndexOf(ASnapConnector); if HouseIndex <> -1 then House.fJoined[HouseIndex] := AConnector; end; // ***** RaiseConn := GetRaiseConn(ASnapConnector); if RaiseConn <> nil then begin RaiseConn.FObjectFromRaise := AConnector; RaiseLine := GetRaiseLine(RaiseConn); if RaiseLine <> nil then RaiseLine.FObjectFromRaisedLine := AConnector; end; if (ASnapConnector.FConnRaiseType = crt_BetweenFloorUp) or (ASnapConnector.FConnRaiseType = crt_BetweenFloorDown) or (ASnapConnector.FConnRaiseType = crt_TrunkUp) or (ASnapConnector.FConnRaiseType = crt_TrunkDown)then begin AConnector.FID_ConnToPassage := ASnapConnector.FID_ConnToPassage; AConnector.FID_ListToPassage := ASnapConnector.FID_ListToPassage; OtherList := GetListByID(ASnapConnector.FID_ListToPassage); if OtherList <> nil then begin OtherRaise := TConnectorObject(GetFigureByID(OtherList, ASnapConnector.FID_ConnToPassage)); if OtherRaise <> nil then OtherRaise.FID_ConnToPassage := AConnector.ID; end; end; AConnector.Name := ASnapConnector.Name; } // Tolik 30/03/2018 -- if not SwapConnectors then // сдвиг нужен, если коннеткор не заменяем на коннектор райза, иначе сдвинем то, что есть (не гут) begin // // вычисление разницы в координатах для соединения обьектов {NewDeltaX := ASnapConnector.ActualPoints[1].x - AConnector.ActualPoints[1].x; NewDeltaY := ASnapConnector.ActualPoints[1].y - AConnector.ActualPoints[1].y; AConnector.ActualPoints[1] := DoublePoint(ASnapConnector.ActualPoints[1].x, ASnapConnector.ActualPoints[1].y); if ((NewDeltaX <> 0) or (NewDeltaY <> 0)) then AConnector.DrawFigure.move(NewDeltaX, NewDeltaY); } for i := 0 to AConnector.JoinedOrtholinesList.Count - 1 do begin if AConnector = TOrthoLine(AConnector.JoinedOrtholinesList[i]).JoinConnector1 then begin TOrthoLine(AConnector.JoinedOrtholinesList[i]).ActualPoints[1] := DoublePoint( TOrthoLine(AConnector.JoinedOrtholinesList[i]).ActualPoints[1].x + NewDeltaX, TOrthoLine(AConnector.JoinedOrtholinesList[i]).ActualPoints[1].y + NewDeltaY); end; if AConnector = TOrthoLine(AConnector.JoinedOrtholinesList[i]).JoinConnector2 then begin TOrthoLine(AConnector.JoinedOrtholinesList[i]).ActualPoints[2] := DoublePoint( TOrthoLine(AConnector.JoinedOrtholinesList[i]).ActualPoints[2].x + NewDeltaX, TOrthoLine(AConnector.JoinedOrtholinesList[i]).ActualPoints[2].y + NewDeltaY); end; end; end; { // переназначаем связи от обьекта к которому присоединились обьекту который присоединяется if (AConnector.ConnectorType = ct_Clear) and (ASnapConnector.ConnectorType <> ct_Clear) then begin TConnectorObject(TempFigure) := AConnector; AConnector := ASnapConnector; ASnapConnector := TConnectorObject(TempFigure); end; } for i := 0 to ASnapConnector.JoinedOrtholinesList.Count - 1 do begin OLine := TOrthoLine(ASnapConnector.JoinedOrtholinesList[i]); if OLine.JoinConnector1 = ASnapConnector then OLine.SetJConnector1(AConnector); if OLine.JoinConnector2 = ASnapConnector then OLine.SetJConnector2(AConnector); end; // Tolik aSnapConnector.JoinedOrthoLinesList.Clear; // // Tolik -- 20/03/2017 -- // если есть присоединенный точечный объект (чтобы не пропало соединение с ортолиниями у поинта) if ((aSnapConnector.JoinedConnectorsList.Count > 0) and (AConnector.JoinedConnectorsList.Count = 0)) then begin NB_Conn := TConnectorObject(aSnapConnector.JoinedConnectorsList[0]); if NB_Conn.ConnectorType = ct_NB then begin NB_Conn.JoinedConnectorsList.Remove(ASnapConnector); ASnapConnector.JoinedConnectorsList.Remove(NB_Conn); NB_Conn.JoinedConnectorsList.Add(AConnector); AConnector.JoinedConnectorsList.Insert(0, Nb_Conn); // Tolik 19/11/2019 -- delete Empty Joined from PM DeleteObjectFromPM(AConnector.ID, AConnector.NAME); // end; end; // SplitFigure := Nil; //ObjectFromRaise := AConnector.FObjectFromRaise; // если есть с-п {if ObjectFromRaise <> nil then begin if AConnector.ActualZOrder[1] > ObjectFromRaise.ActualZOrder[1] then begin AConnector.Name := cCadClasses_Mes24; SetNewObjectNameInPM(AConnector.ID, AConnector.Name); ObjParams := GetFigureParams(AConnector.ID); AConnector.Name := ObjParams.Name; AConnector.FIndex := ObjParams.MarkID; end; if AConnector.ActualZOrder[1] < ObjectFromRaise.ActualZOrder[1] then begin AConnector.Name := cCadClasses_Mes24; SetNewObjectNameInPM(AConnector.ID, AConnector.Name); ObjParams := GetFigureParams(AConnector.ID); AConnector.Name := ObjParams.Name; AConnector.FIndex := ObjParams.MarkID; end; SetConFigureCoordZInPM(AConnector.ID, AConnector.ActualZOrder[1]); SetNewObjectNameInPM(AConnector.ID, AConnector.Name); SetConnBringToFront(ObjectFromRaise); SetConnBringToFront(AConnector); AConnector.LockMove := True; AConnector.LockModify := True; end;} try // Протокол GCadForm.mProtocol.Lines.Add(cEndPoints_Mes1 + AConnector.Name + cCommon_Mes1 + ASnapConnector.Name + '"'); ASnapConnector.FConnRaiseType := crt_None; ASnapConnector.FObjectFromRaise := Nil; ASnapConnector.Delete(False, False); except on E: Exception do addExceptionToLogEx('U_Common.SnapConnectorToConnector', E.Message); end; // Tolik 15/03/2017 -- if not aSnapConnector.deleted then aSnapConnector.Move(-NewDeltaX, -NewDeltaY); // ReCalcZCoordSnapObjects(AConnector); if GCadForm.PCad.SnapToGrids then begin for i := 0 to AConnector.JoinedOrtholinesList.Count - 1 do begin JoinedLine := TOrthoLine(AConnector.JoinedOrtholinesList[i]); ReAlignLine(JoinedLine); end; end; except on E: Exception do addExceptionToLogEx('U_Common.SnapConnectorToConnector', E.Message); end; { if not AConnector.deleted then begin if AConnector.JoinedConnectorsList.count > 0 then begin TConnectorObject(AConnector.JoinedConnectorsList[0]).MoveP(0.1, 0.1, False); TConnectorObject(AConnector.JoinedConnectorsList[0]).MoveP(-0.1, -0.1, False); end else begin AConnector.MoveP(0.1, 0.1, False); AConnector.MoveP(-0.1, -0.1, False); end; end; } RefreshCad(GCadForm.PCad); end; (* // Tolik 22/11/2016 так как было -- никуда не годится, ломает магистральные и межэтажные переходы, // поэтому переписана, а старая в виде процедуры (как была) оставлена ниже в комментах для истории // Function SnapConnectorToConnector(AConnector, ASnapConnector: TConnectorObject; AOnRaise: Boolean = false): TConnectorObject; var i, j: integer; NewDeltaX, NewDeltaY: double; OLine: TOrthoLine; TempFigure: TFigure; PrevLine: TOrthoLine; CurrentLine: TOrthoLine; SplitFigure: TOrthoLine; ObjectFromRaise: TConnectorObject; RaiseConn: TConnectorObject; RaiseLine: TOrthoLine; ObjParams: TObjectParams; JoinedLine: TOrthoLine; OtherList: TF_CAD; OtherRaise: TConnectorObject; // House: THouse; HouseIndex: Integer; // Tolik -- 20/03/2017 -- NB_Conn: TConnectorObject; SwapConnectors: Boolean; // // Tolik -- 05/12/2016 -- проверка, чтобы не убить коннектор райза или межэтажки/магистрали function CheckIsRaise(aConn: TConnectorObject): Boolean; var i: Integer; begin Result := False; for i := 0 to AConn.JoinedOrthoLinesList.Count - 1 do begin if TOrthoLine(AConn.JoinedOrthoLinesList[i]).FIsRaiseUpDown then begin Result := True; break; end; end; end; begin Result := AConnector; if AConnector.Deleted or ASnapConnector.Deleted then Exit; // Tolik 08/11/2017 -- на всякий, бывали преценденты.... if aConnector.ID = ASnapConnector.ID then exit; // SwapConnectors := False; if CheckIsRaise(ASnapConnector) then //if (AConnector.FConnRaiseType = crt_None) and (ASnapConnector.FConnRaiseType <> crt_None) then begin AConnector := ASnapConnector; ASnapConnector := Result; Result := AConnector; SwapConnectors := True; end; try {// #Oleg Commented#} if Not AOnRaise then FindConnectionsInterfaces(AConnector, ASnapConnector); // { if AConnector.joinedOrtholinesList.count > 0 then begin if (ASnapConnector.ActualZOrder[1]>=TOrtholine(AConnector.JoinedOrtholinesList[0]).ActualZOrder[1]) and(ASnapConnector.ActualZOrder[1]>=TOrtholine(AConnector.JoinedOrtholinesList[0]).ActualZOrder[2]) then begin if TOrtholine(AConnector.JoinedOrtholinesList[0]).ActualZOrder[1] < TOrtholine(AConnector.JoinedOrtholinesList[0]).ActualZOrder[2] then AConnector.ActualZOrder[1] := TOrtholine(AConnector.joinedOrtholinesList[0]).ActualZOrder[1] else AConnector.ActualZOrder[1] := TOrtholine(AConnector.joinedOrtholinesList[0]).ActualZOrder[2]; end else begin if TOrtholine(AConnector.JoinedOrtholinesList[0]).ActualZOrder[1] < TOrtholine(AConnector.JoinedOrtholinesList[0]).ActualZOrder[2] then AConnector.ActualZOrder[1] := TOrtholine(AConnector.joinedOrtholinesList[0]).ActualZOrder[2] else AConnector.ActualZOrder[1] := TOrtholine(AConnector.joinedOrtholinesList[0]).ActualZOrder[1]; end; end else } // // AConnector.ActualZOrder[1] := ASnapConnector.ActualZOrder[1]; //Tolik {if AOnRaise then AConnector.ActualZOrder[1] := ASnapConnector.ActualZOrder[1];} // { if AOnRaise then AConnector.ActualZOrder[1] := ASnapConnector.ActualZOrder[1]; } { AConnector.FConnRaiseType := ASnapConnector.FConnRaiseType; AConnector.FObjectFromRaise := ASnapConnector.FObjectFromRaise; AConnector.tmpParentDupID := ASnapConnector.tmpParentDupID; // House AConnector.fHouse := ASnapConnector.fHouse; AConnector.FIsHouseJoined := ASnapConnector.FIsHouseJoined; if (ASnapConnector.FIsHouseJoined) and (ASnapConnector.fHouse <> nil) then begin House := ASnapConnector.fHouse; HouseIndex := House.fJoined.IndexOf(ASnapConnector); if HouseIndex <> -1 then House.fJoined[HouseIndex] := AConnector; end; // ***** RaiseConn := GetRaiseConn(ASnapConnector); if RaiseConn <> nil then begin RaiseConn.FObjectFromRaise := AConnector; RaiseLine := GetRaiseLine(RaiseConn); if RaiseLine <> nil then RaiseLine.FObjectFromRaisedLine := AConnector; end; if (ASnapConnector.FConnRaiseType = crt_BetweenFloorUp) or (ASnapConnector.FConnRaiseType = crt_BetweenFloorDown) or (ASnapConnector.FConnRaiseType = crt_TrunkUp) or (ASnapConnector.FConnRaiseType = crt_TrunkDown)then begin AConnector.FID_ConnToPassage := ASnapConnector.FID_ConnToPassage; AConnector.FID_ListToPassage := ASnapConnector.FID_ListToPassage; OtherList := GetListByID(ASnapConnector.FID_ListToPassage); if OtherList <> nil then begin OtherRaise := TConnectorObject(GetFigureByID(OtherList, ASnapConnector.FID_ConnToPassage)); if OtherRaise <> nil then OtherRaise.FID_ConnToPassage := AConnector.ID; end; end; AConnector.Name := ASnapConnector.Name; } // Tolik 30/03/2018 -- if not SwapConnectors then // сдвиг нужен, если коннеткор не заменяем на коннектор райза, иначе сдвинем то, что есть (не гут) begin // // вычисление разницы в координатах для соединения обьектов NewDeltaX := ASnapConnector.ActualPoints[1].x - AConnector.ActualPoints[1].x; NewDeltaY := ASnapConnector.ActualPoints[1].y - AConnector.ActualPoints[1].y; AConnector.ActualPoints[1] := DoublePoint(ASnapConnector.ActualPoints[1].x, ASnapConnector.ActualPoints[1].y); AConnector.DrawFigure.move(NewDeltaX, NewDeltaY); for i := 0 to AConnector.JoinedOrtholinesList.Count - 1 do begin if AConnector = TOrthoLine(AConnector.JoinedOrtholinesList[i]).JoinConnector1 then begin TOrthoLine(AConnector.JoinedOrtholinesList[i]).ActualPoints[1] := DoublePoint( TOrthoLine(AConnector.JoinedOrtholinesList[i]).ActualPoints[1].x + NewDeltaX, TOrthoLine(AConnector.JoinedOrtholinesList[i]).ActualPoints[1].y + NewDeltaY); end; if AConnector = TOrthoLine(AConnector.JoinedOrtholinesList[i]).JoinConnector2 then begin TOrthoLine(AConnector.JoinedOrtholinesList[i]).ActualPoints[2] := DoublePoint( TOrthoLine(AConnector.JoinedOrtholinesList[i]).ActualPoints[2].x + NewDeltaX, TOrthoLine(AConnector.JoinedOrtholinesList[i]).ActualPoints[2].y + NewDeltaY); end; end; end; { // переназначаем связи от обьекта к которому присоединились обьекту который присоединяется if (AConnector.ConnectorType = ct_Clear) and (ASnapConnector.ConnectorType <> ct_Clear) then begin TConnectorObject(TempFigure) := AConnector; AConnector := ASnapConnector; ASnapConnector := TConnectorObject(TempFigure); end; } for i := 0 to ASnapConnector.JoinedOrtholinesList.Count - 1 do begin OLine := TOrthoLine(ASnapConnector.JoinedOrtholinesList[i]); if OLine.JoinConnector1 = ASnapConnector then OLine.SetJConnector1(AConnector); if OLine.JoinConnector2 = ASnapConnector then OLine.SetJConnector2(AConnector); end; // Tolik aSnapConnector.JoinedOrthoLinesList.Clear; // // Tolik -- 20/03/2017 -- // если есть присоединенный точечный объект (чтобы не пропало соединение с ортолиниями у поинта) if ((aSnapConnector.JoinedConnectorsList.Count > 0) and (AConnector.JoinedConnectorsList.Count = 0)) then begin NB_Conn := TConnectorObject(aSnapConnector.JoinedConnectorsList[0]); if NB_Conn.ConnectorType = ct_NB then begin NB_Conn.JoinedConnectorsList.Remove(ASnapConnector); NB_Conn.JoinedConnectorsList.Add(AConnector); AConnector.JoinedConnectorsList.Insert(0, Nb_Conn); end; end; // SplitFigure := Nil; //ObjectFromRaise := AConnector.FObjectFromRaise; // если есть с-п {if ObjectFromRaise <> nil then begin if AConnector.ActualZOrder[1] > ObjectFromRaise.ActualZOrder[1] then begin AConnector.Name := cCadClasses_Mes24; SetNewObjectNameInPM(AConnector.ID, AConnector.Name); ObjParams := GetFigureParams(AConnector.ID); AConnector.Name := ObjParams.Name; AConnector.FIndex := ObjParams.MarkID; end; if AConnector.ActualZOrder[1] < ObjectFromRaise.ActualZOrder[1] then begin AConnector.Name := cCadClasses_Mes24; SetNewObjectNameInPM(AConnector.ID, AConnector.Name); ObjParams := GetFigureParams(AConnector.ID); AConnector.Name := ObjParams.Name; AConnector.FIndex := ObjParams.MarkID; end; SetConFigureCoordZInPM(AConnector.ID, AConnector.ActualZOrder[1]); SetNewObjectNameInPM(AConnector.ID, AConnector.Name); SetConnBringToFront(ObjectFromRaise); SetConnBringToFront(AConnector); AConnector.LockMove := True; AConnector.LockModify := True; end;} try // Протокол GCadForm.mProtocol.Lines.Add(cEndPoints_Mes1 + AConnector.Name + cCommon_Mes1 + ASnapConnector.Name + '"'); ASnapConnector.FConnRaiseType := crt_None; ASnapConnector.FObjectFromRaise := Nil; ASnapConnector.Delete(False, False); except on E: Exception do addExceptionToLogEx('U_Common.SnapConnectorToConnector', E.Message); end; // Tolik 15/03/2017 -- if not aSnapConnector.deleted then aSnapConnector.Move(-NewDeltaX, -NewDeltaY); // ReCalcZCoordSnapObjects(AConnector); if GCadForm.PCad.SnapToGrids then begin for i := 0 to AConnector.JoinedOrtholinesList.Count - 1 do begin JoinedLine := TOrthoLine(AConnector.JoinedOrtholinesList[i]); ReAlignLine(JoinedLine); end; end; except on E: Exception do addExceptionToLogEx('U_Common.SnapConnectorToConnector', E.Message); end; RefreshCad(GCadForm.PCad); end; *) (* // ПРИВЯЗКА КОНЕКТОРА К КОНЕКТОРУ procedure SnapConnectorToConnector(AConnector, ASnapConnector: TConnectorObject; AOnRaise: Boolean = false); var i, j: integer; NewDeltaX, NewDeltaY: double; OLine: TOrthoLine; TempFigure: TFigure; PrevLine: TOrthoLine; CurrentLine: TOrthoLine; SplitFigure: TOrthoLine; ObjectFromRaise: TConnectorObject; RaiseConn: TConnectorObject; RaiseLine: TOrthoLine; ObjParams: TObjectParams; JoinedLine: TOrthoLine; OtherList: TF_CAD; OtherRaise: TConnectorObject; // House: THouse; HouseIndex: Integer; begin try if AConnector.Deleted or ASnapConnector.Deleted then Exit; {// #Oleg Commented#} if Not AOnRaise then FindConnectionsInterfaces(AConnector, ASnapConnector); // { if AConnector.joinedOrtholinesList.count > 0 then begin if (ASnapConnector.ActualZOrder[1]>=TOrtholine(AConnector.JoinedOrtholinesList[0]).ActualZOrder[1]) and(ASnapConnector.ActualZOrder[1]>=TOrtholine(AConnector.JoinedOrtholinesList[0]).ActualZOrder[2]) then begin if TOrtholine(AConnector.JoinedOrtholinesList[0]).ActualZOrder[1] < TOrtholine(AConnector.JoinedOrtholinesList[0]).ActualZOrder[2] then AConnector.ActualZOrder[1] := TOrtholine(AConnector.joinedOrtholinesList[0]).ActualZOrder[1] else AConnector.ActualZOrder[1] := TOrtholine(AConnector.joinedOrtholinesList[0]).ActualZOrder[2]; end else begin if TOrtholine(AConnector.JoinedOrtholinesList[0]).ActualZOrder[1] < TOrtholine(AConnector.JoinedOrtholinesList[0]).ActualZOrder[2] then AConnector.ActualZOrder[1] := TOrtholine(AConnector.joinedOrtholinesList[0]).ActualZOrder[2] else AConnector.ActualZOrder[1] := TOrtholine(AConnector.joinedOrtholinesList[0]).ActualZOrder[1]; end; end else } // AConnector.ActualZOrder[1] := ASnapConnector.ActualZOrder[1]; //Tolik {if AOnRaise then AConnector.ActualZOrder[1] := ASnapConnector.ActualZOrder[1];} // if AOnRaise then AConnector.ActualZOrder[1] := ASnapConnector.ActualZOrder[1]; AConnector.FConnRaiseType := ASnapConnector.FConnRaiseType; AConnector.FObjectFromRaise := ASnapConnector.FObjectFromRaise; AConnector.tmpParentDupID := ASnapConnector.tmpParentDupID; // House AConnector.fHouse := ASnapConnector.fHouse; AConnector.FIsHouseJoined := ASnapConnector.FIsHouseJoined; if (ASnapConnector.FIsHouseJoined) and (ASnapConnector.fHouse <> nil) then begin House := ASnapConnector.fHouse; HouseIndex := House.fJoined.IndexOf(ASnapConnector); if HouseIndex <> -1 then House.fJoined[HouseIndex] := AConnector; end; // ***** RaiseConn := GetRaiseConn(ASnapConnector); if RaiseConn <> nil then begin RaiseConn.FObjectFromRaise := AConnector; RaiseLine := GetRaiseLine(RaiseConn); if RaiseLine <> nil then RaiseLine.FObjectFromRaisedLine := AConnector; end; if (ASnapConnector.FConnRaiseType = crt_BetweenFloorUp) or (ASnapConnector.FConnRaiseType = crt_BetweenFloorDown) or (ASnapConnector.FConnRaiseType = crt_TrunkUp) or (ASnapConnector.FConnRaiseType = crt_TrunkDown)then begin AConnector.FID_ConnToPassage := ASnapConnector.FID_ConnToPassage; AConnector.FID_ListToPassage := ASnapConnector.FID_ListToPassage; OtherList := GetListByID(ASnapConnector.FID_ListToPassage); if OtherList <> nil then begin OtherRaise := TConnectorObject(GetFigureByID(OtherList, ASnapConnector.FID_ConnToPassage)); if OtherRaise <> nil then OtherRaise.FID_ConnToPassage := AConnector.ID; end; end; AConnector.Name := ASnapConnector.Name; // вычисление разницы в координатах для соединения обьектов NewDeltaX := ASnapConnector.ActualPoints[1].x - AConnector.ActualPoints[1].x; NewDeltaY := ASnapConnector.ActualPoints[1].y - AConnector.ActualPoints[1].y; AConnector.ActualPoints[1] := DoublePoint(ASnapConnector.ActualPoints[1].x, ASnapConnector.ActualPoints[1].y); AConnector.DrawFigure.move(NewDeltaX, NewDeltaY); for i := 0 to AConnector.JoinedOrtholinesList.Count - 1 do begin if AConnector = TOrthoLine(AConnector.JoinedOrtholinesList[i]).JoinConnector1 then begin TOrthoLine(AConnector.JoinedOrtholinesList[i]).ActualPoints[1] := DoublePoint( TOrthoLine(AConnector.JoinedOrtholinesList[i]).ActualPoints[1].x + NewDeltaX, TOrthoLine(AConnector.JoinedOrtholinesList[i]).ActualPoints[1].y + NewDeltaY); end; if AConnector = TOrthoLine(AConnector.JoinedOrtholinesList[i]).JoinConnector2 then begin TOrthoLine(AConnector.JoinedOrtholinesList[i]).ActualPoints[2] := DoublePoint( TOrthoLine(AConnector.JoinedOrtholinesList[i]).ActualPoints[2].x + NewDeltaX, TOrthoLine(AConnector.JoinedOrtholinesList[i]).ActualPoints[2].y + NewDeltaY); end; end; // переназначаем связи от обьекта к которому присоединились обьекту который присоединяется if (AConnector.ConnectorType = ct_Clear) and (ASnapConnector.ConnectorType <> ct_Clear) then begin TConnectorObject(TempFigure) := AConnector; AConnector := ASnapConnector; ASnapConnector := TConnectorObject(TempFigure); end; for i := 0 to ASnapConnector.JoinedOrtholinesList.Count - 1 do begin OLine := TOrthoLine(ASnapConnector.JoinedOrtholinesList[i]); if OLine.JoinConnector1 = ASnapConnector then OLine.SetJConnector1(AConnector); if OLine.JoinConnector2 = ASnapConnector then OLine.SetJConnector2(AConnector); end; // Tolik aSnapConnector.JoinedOrthoLinesList.Clear; // SplitFigure := Nil; ObjectFromRaise := AConnector.FObjectFromRaise; // если есть с-п if ObjectFromRaise <> nil then begin if AConnector.ActualZOrder[1] > ObjectFromRaise.ActualZOrder[1] then begin AConnector.Name := cCadClasses_Mes24; SetNewObjectNameInPM(AConnector.ID, AConnector.Name); ObjParams := GetFigureParams(AConnector.ID); AConnector.Name := ObjParams.Name; AConnector.FIndex := ObjParams.MarkID; end; if AConnector.ActualZOrder[1] < ObjectFromRaise.ActualZOrder[1] then begin AConnector.Name := cCadClasses_Mes24; SetNewObjectNameInPM(AConnector.ID, AConnector.Name); ObjParams := GetFigureParams(AConnector.ID); AConnector.Name := ObjParams.Name; AConnector.FIndex := ObjParams.MarkID; end; SetConFigureCoordZInPM(AConnector.ID, AConnector.ActualZOrder[1]); SetNewObjectNameInPM(AConnector.ID, AConnector.Name); SetConnBringToFront(ObjectFromRaise); SetConnBringToFront(AConnector); AConnector.LockMove := True; AConnector.LockModify := True; end; try // Протокол GCadForm.mProtocol.Lines.Add(cEndPoints_Mes1 + AConnector.Name + cCommon_Mes1 + ASnapConnector.Name + '"'); ASnapConnector.FConnRaiseType := crt_None; ASnapConnector.FObjectFromRaise := Nil; ASnapConnector.Delete(False, False); except on E: Exception do addExceptionToLogEx('U_Common.SnapConnectorToConnector', E.Message); end; ReCalcZCoordSnapObjects(AConnector); if GCadForm.PCad.SnapToGrids then begin for i := 0 to AConnector.JoinedOrtholinesList.Count - 1 do begin JoinedLine := TOrthoLine(AConnector.JoinedOrtholinesList[i]); ReAlignLine(JoinedLine); end; end; except on E: Exception do addExceptionToLogEx('U_Common.SnapConnectorToConnector', E.Message); end; end; *) // Tolik -- 05/02/2018 -- немножко переписано с учетом интернальных соединений // старая закомменчена -- смотри ниже (ее клинит, если кабель проложен по замкнутому контуру) function GetCableWayTraceList(aCableCompon: TSCSComponent): TIntList; var i, j, k: integer; CableWay: TList; FCableNpp, currNpp: Integer; CableWayCompon: TCableWayCompon; Side1CableCompon, Side2CableCompon: TSCSComponent; InterfacePosition, ConnectedInterfPos: TSCSInterfPosition; Side1InterfList, Side2InterfList: TList; CanSeekCable : Boolean; ConnectedPosFound: Boolean; ConnectInerfSide1, ConnectInterfSide2 : integer; FCableCatalog: TSCSCatalog; FCableFigure: TFigure; CurrentInterface: TSCSInterface; currCompon: TSCSComponent; //Side1Compons, Side2Compons: TSCSComponents; Side1Compons, Side2Compons: TList; WayList: TList; PassedList: TStringList; // список пройденных связок ConnectDescription: String; // описание связки ConnectedInterface: TSCSInterface; ConnectedPoint, ConnectedLine: TSCSComponent; ConnectedInterfPosList: TList; InterfaceStartPosNum: Integer; InterfacePath: TInterfPath; function GetFigureByCatalogId(CatalogId: Integer): TFigure; var i: Integer; begin Result := nil; for i := 0 to GCadForm.FSCSFigures.Count - 1 do begin if TFigure(GCadForm.FSCSFigures[i]).ID = CatalogId then begin Result := TFigure(GCadForm.FSCSFigures[i]); break; end; end; end; // отсортировать списки интерфейсов согласно порядковым номерам интерфейсов Procedure SortInterfList(aList: TList); var i: Integer; CanSort: Boolean; begin if aList <> nil then if aList.Count > 1 then begin CanSort := True; While CanSort do begin CanSort := False; for i := 0 to aList.Count - 2 do begin if TSCSInterface(aList[i]).Npp > TSCSInterface(aList[i]).Npp then begin aList.Exchange(i, i + 1); CanSort := true; end; end; end; end; end; //проверить, есть ли в точечном компененте интернальные соединения Function CheckHasInternalConn(aPoint: TSCSComponent): Boolean; var i: integer; currInterf: TSCSInterface; begin Result := False; if aPoint.IsLine = biTrue then exit; for i := 0 to aPoint.Interfaces.Count - 1 do begin currInterf := TSCSInterface(aPoint.Interfaces[i]); if currInterf.TypeI = itFunctional then if (currInterf.IsBusy = biTrue) or (currInterf.BusyPositions.Count > 0) then if currInterf.InternalConnected.Count > 0 then begin Result := True; break; end; end; end; // получить сторону подключения кабеля(aCompon1) к точечному объекту(aCompon2) Function GetConnectSide(aCompon1, aCompon2: TSCSComponent): Integer; var i,j: Integer; Interf: TSCSInterface; InterfPos, ConnectedInterfPos: TSCSInterfPosition; begin Result := 0; for i := 0 to aCompon1.Interfaces.Count - 1 do begin Interf := TSCSInterface(aCompon1.Interfaces[i]); if Interf.TypeI = itFunctional then begin for j := 0 to Interf.BusyPositions.Count - 1 do begin InterfPos := Interf.BusyPositions[j]; ConnectedInterfPos := InterfPos.GetConnectedPos; if ConnectedInterfPos <> nil then begin if ConnectedInterfPos.InterfOwner.ComponentOwner <> nil then if ConnectedInterfPos.InterfOwner.ComponentOwner.ID = aCompon2.ID then begin Result := Interf.Side; exit; end; end; end; end; end; end; //получить список компонент, подключенных к кабелю через интернальное соединение function GetInternalConnList(aLine, aPointCompon: TSCSComponent; aConnectSide: Integer): TList; var i, j, k, l, m: Integer; currInterf, ConnectedInterface, InternalInterFace: TSCSInterface; interfPos, connectedPos: TSCSInterfPosition; CurrPosNum: Integer; PosList: TList; begin Result := TList.Create; PosList := TList.Create; for i := 0 to aLine.Interfaces.Count - 1 do begin currInterf := aLine.Interfaces[i]; if currInterf.TypeI = itFunctional then if currInterf.Side = aConnectSide then begin for j := 0 to currInterf.BusyPositions.Count - 1 do begin interfPos := TSCSInterfPosition(currInterf.BusyPositions[j]); connectedPos := Interfpos.GetConnectedPos; if ConnectedPos <> nil then begin ConnectedInterface := ConnectedPos.InterfOwner; CurrPosNum := 0; if ConnectedInterface.InternalConnected.Count > 0 then // если к интерфейсу есть внутренние подключения внутри поинта begin for k := 0 to ConnectedInterface.InternalConnected.Count - 1 do begin InternalInterface := TSCSInterface(ConnectedInterface.InternalConnected[k]); for l := 0 to InternalInterface.BusyPositions.Count - 1 do begin if ((TSCSInterfPosition(InternalInterface.BusyPositions[l]).FromPos + CurrPosNum) >= connectedPos.FromPos) then if ((TSCSInterfPosition(InternalInterface.BusyPositions[l]).FromPos + CurrPosNum) <= connectedPos.ToPos) then if PosList.IndexOf(TSCSInterfPosition(InternalInterface.BusyPositions[l])) = -1 then PosList.Add(TSCSInterfPosition(InternalInterface.BusyPositions[l])); end; CurrPosNum := CurrPosNum + InternalInterface.Kolvo; end; end else begin for k := 0 to ConnectedInterface.ComponentOwner.Interfaces.Count - 1 do begin if TSCSInterface(ConnectedInterface.ComponentOwner.Interfaces[k]).InternalConnected.IndexOf(ConnectedInterface) <> -1 then begin InternalInterface := TSCSInterface(ConnectedInterface.ComponentOwner.Interfaces[k]); for l := 0 to InternalInterface.InternalConnected.Count - 1 do begin if TSCSInterface(InternalInterface.InternalConnected[l]).ID = ConnectedInterface.ID then break else CurrPosNum := CurrPosNum + TSCSInterface(InternalInterface.InternalConnected[l]).Kolvo; end; for l := 0 to InternalInterface.BusyPositions.Count - 1 do begin if ((TSCSInterfPosition(InternalInterface.BusyPositions[l]).FromPos + CurrPosNum) >= connectedPos.FromPos) then if ((TSCSInterfPosition(InternalInterface.BusyPositions[l]).FromPos + CurrPosNum) <= connectedPos.ToPos) then if PosList.IndexOf(TSCSInterfPosition(InternalInterface.BusyPositions[l])) = -1 then PosList.Add(TSCSInterfPosition(InternalInterface.BusyPositions[l])); end; end; end; end; if PosList.Count > 0 then begin for k := 0 to PosList.Count - 1 do begin InterfPos := TSCSInterfPosition(PosList[k]); InterfPos := InterfPos.GetConnectedPos; if InterfPos <> nil then begin if InterfPos.InterfOwner.ComponentOwner <> nil then if Result.IndexOf(InterfPos.InterfOwner.ComponentOwner) = -1 then Result.Add(InterfPos.InterfOwner.ComponentOwner); end; end; end; end; end; end; end; PosList.Free; end; //получить путь прохождения кабеля по присоединенным компонентам Procedure GetPathList (aCompon: TSCSComponent; aList: TList); var i, j: Integer; ConnectList: TList; currCompon: TSCSComponent; ConnectedInterface: TSCSInterface; ConnectSide: Integer; begin currCompon := nil; ConnectList := Nil; if aList.Count > 0 then begin ConnectList := TList.Create; for i := 0 to aList.Count - 1 do begin currCompon := TSCSComponent(aList[i]); if WayList.IndexOf(currCompon) = -1 then WayList.Add(currCompon); if isCableComponent(currCompon) then // кабель - кабель begin for j := 0 to currCompon.JoinedComponents.Count - 1 do begin if WayList.IndexOf(TSCSComponent(currCompon.JoinedComponents[j]))= -1 then begin ConnectList.Add(TSCSComponent(currCompon.JoinedComponents[j])); end; end; end else begin // кабель - точечный компонент if isCableComponent(aCompon) then // только если приходим кабелем к точечному begin if CheckHasInternalConn(currCompon) then // если в точечном компоненте есть проходящие соединения, нужно их проверить begin ConnectSide:= 0; ConnectSide := GetConnectSide(aCompon, currCompon); if ConnectSide <> 0 then begin if ConnectList <> nil then FreeAndNil(ConnectList); ConnectList := GetInternalConnList(aCompon, currCompon, ConnectSide); end; end; end; end; if ConnectList.Count > 0 then GetPathList(currCompon, ConnectList); ConnectList.Clear; end; if ConnectList <> nil then ConnectList.Free; end; end; begin Result := Nil; if aCableCompon = nil then exit; if aCableCompon.ServToDelete then exit; Result := TIntList.Create; ConnectedPoint := nil; ConnectedLine := nil; InterfacePosition := Nil; ConnectedInterfPos := nil; ConnectedInterfPosList := Nil; //если к кабелю ничего не подключено -- добавляем его в результат и выходим FCableCatalog := aCableCompon.GetFirstParentCatalog; if FCableCatalog <> nil then begin FCableFigure := GetFigureByCatalogId(FCableCatalog.SCSID); if FCableFigure <> nil then begin if checkFigureByClassName(FCableFigure, cTOrthoLine) then Result.Add(FCableFigure.ID); end; end; if aCableCompon.JoinedComponents.Count = 0 then begin if Result.Count = 0 then FreeAndNil(Result); exit; end; CableWay := nil; FCableNpp := 0; currNpp := 0; Side1InterfList := TList.Create; Side2InterfList := TList.Create; PassedList := TStringList.Create; // список пройденных, чтобы не вернуться и не зациклить Side1Compons := TList.Create; Side2Compons := TList.Create; WayList := TList.Create; WayList.Add(aCableCompon); //разнести занятые интерфейсы кабеля по сторонам в отдельные списки for i := 0 to aCableCompon.Interfaces.Count - 1 do begin if TSCSInterface(aCableCompon.Interfaces[i]).TypeI = itFunctional then begin if (TSCSInterface(aCableCompon.Interfaces[i]).IsBusy = biTrue) or (TSCSInterface(aCableCompon.Interfaces[i]).BusyPositions.Count > 0) then begin if TSCSInterface(aCableCompon.Interfaces[i]).Side = 1 then Side1InterfList.Add(TSCSInterface(aCableCompon.Interfaces[i])) else if TSCSInterface(aCableCompon.Interfaces[i]).Side = 2 then Side2InterfList.Add(TSCSInterface(aCableCompon.Interfaces[i])); end; end; end; //сортануть списки интерфейсов по NPP SortInterfList(Side1InterfList); SortInterfList(Side2InterfList); for i := 0 to Side1InterfList.Count - 1 do begin CurrentInterface := TSCSInterface(Side1InterfList[i]); for j := 0 to CurrentInterface.BusyPositions.Count - 1 do begin ConnectedInterfPos := TSCSInterfPosition(CurrentInterface.BusyPositions[j]).GetConnectedPos; if ConnectedInterfPos <> nil then begin If ConnectedInterfPos.InterfOwner.ComponentOwner <> nil then if Side1Compons.IndexOf(ConnectedInterfPos.InterfOwner.ComponentOwner) = -1 then Side1Compons.Add(ConnectedInterfPos.InterfOwner.ComponentOwner); end; end; end; for i := 0 to Side2InterfList.Count - 1 do begin CurrentInterface := TSCSInterface(Side2InterfList[i]); for j := 0 to CurrentInterface.BusyPositions.Count - 1 do begin ConnectedInterfPos := TSCSInterfPosition(CurrentInterface.BusyPositions[j]).GetConnectedPos; if ConnectedInterfPos <> nil then begin If ConnectedInterfPos.InterfOwner.ComponentOwner <> nil then if Side2Compons.IndexOf(ConnectedInterfPos.InterfOwner.ComponentOwner) = -1 then Side2Compons.Add(ConnectedInterfPos.InterfOwner.ComponentOwner); end; end; end; GetPathList(aCablecompon, Side1Compons); GetPathList(aCableCompon, Side2Compons); Result := TIntList.Create; for i := 0 to WayList.Count - 1 do begin currCompon := TSCSComponent(WayList[i]); if isCableComponent(currCompon) then begin FCableCatalog := currCompon.GetFirstParentCatalog; if FCableCatalog <> nil then begin FCableFigure := GetFigureByCatalogId(FCableCatalog.SCSID); if FCableFigure <> nil then begin if (checkFigureByClassName(FCableFigure, cTOrthoLine) and (Result.IndexOf(FCableFigure.Id) = -1)) then if Result.IndexOf(FCableFigure.ID) = -1 then Result.Add(FCableFigure.ID); end; end; end; end; if Result.Count = 0 then FreeAndNil(Result); FreeAndNil(Side1InterfList); FreeAndNil(Side2InterfList); FreeAndNil(PassedList); FreeAndNil(Side1Compons); FreeAndNil(Side2Compons); FreeAndNil(WayList); end; //Tolik 11/05/2018 -- function CheckRaiseIsNotBetweenFloorOrMagistral(aRaise: TOrthoLine; var aMess: String): Boolean; begin Result := True; aMess := ''; if TConnectorObject(aRaise.JoinConnector1).FConnRaiseType in [crt_BetweenFloorUp, crt_BetweenFloorDown] then begin aMess := cCadMess1; Result := False; exit; end; if TConnectorObject(aRaise.JoinConnector1).FConnRaiseType in [crt_TrunkUP, crt_TrunkDown] then begin aMess := cCadMess2; Result := False; exit; end; if TConnectorObject(aRaise.JoinConnector2).FConnRaiseType in [crt_BetweenFloorUp, crt_BetweenFloorDown] then begin aMess := cCadMess1; Result := False; exit; end; if TConnectorObject(aRaise.JoinConnector2).FConnRaiseType in [crt_TrunkUP, crt_TrunkDown] then begin aMess := cCadMess2; Result := False; exit; end; end; (* function GetCableWayTraceList(aCableCompon: TSCSComponent): TIntList; var i, j, k: integer; CableWay: TList; FCableNpp, currNpp: Integer; CableWayCompon: TCableWayCompon; Side1CableCompon, Side2CableCompon: TSCSComponent; InterfacePosition: TSCSInterfPosition; Side1InterfList, Side2InterfList: TList; CanSeekCable : Boolean; ConnectedPosFound: Boolean; ConnectInerfSide1, ConnectInterfSide2 : integer; FCableCatalog: TSCSCatalog; FCableFigure: TFigure; CurrentInterface: TSCSInterface; currCompon: TSCSComponent; function GetFigureByCatalogId(CatalogId: Integer): TFigure; var i: Integer; begin Result := nil; for i := 0 to GCadForm.FSCSFigures.Count - 1 do begin if TFigure(GCadForm.FSCSFigures[i]).ID = CatalogId then begin Result := TFigure(GCadForm.FSCSFigures[i]); break; end; end; end; function CheckInternalConnection(aWayComponent: TSCSComponent): Boolean; var i: Integer; begin Result := False; if ((aWayComponent <> nil) and (aWayComponent.isLine = biFalse)) then begin for i := 0 to aWayComponent.Interfaces.Count - 1 do begin if (TSCSInterface(aWayComponent.Interfaces[i]).TypeI = itFunctional) and (TSCSInterface(aWayComponent.Interfaces[i]).InternalConnected.Count > 0) then begin Result := true; break; end; end; end; end; Procedure GetCableWayBySide(aSide, aNpp, ACurrNpp: Integer; aCableCompon: TSCSComponent; aWayListSide: Integer); var i, j, k: Integer; InterfPos, CableInterfPos: TSCSInterfPosition; TempNpp, CurrNpp: Integer; CurrInterface, PointComponInterface, InternalInterface: TSCSInterface; InterfSide: Integer; ConnectedPosFound: Boolean; //CanSeekCable: Boolean; InternalConnection: Boolean; PointCompon, InternalConnectedCompon: TSCSComponent; InternalConnSide: Integer; CanSeekCable: Boolean; // Tolik 05/02/2017 -- нужно отслеживать пройденные связки интерфейсов по позициям, чтобы не зациклилось // а такое может быть, если есть компоненты с интерфейсами, смотрящими друг на друга, соединенные одним кабелем PassedList: TList; S: String; // begin PassedList := TList.Create; CurrNpp := ACurrNpp; TempNpp := 0; //смещение позиции интерфейса InterfSide := aSide; CanSeekCable := True; ConnectedPosFound := False; InterfPos := Nil; // сброс конечного компонента if aWayListSide = 1 then begin TCableWayCompon(CableWay[aNpp-1]).FirstCompon := nil; TCableWayCompon(CableWay[aNpp-1]).Side1ConnectedInterface := nil; end else if aWayListSide = 2 then begin TCableWayCompon(CableWay[aNpp-1]).LastCompon := nil; TCableWayCompon(CableWay[aNpp-1]).Side2ConnectedInterface := nil; end; // определить позицию жилы for j := 0 to aCableCompon.Interfaces.Count - 1 do begin CurrInterface := TSCSInterface(aCableCompon.Interfaces[j]); //if (CurrInterface.TypeI = itFunctional) and (CurrInterface.Side = ConnectInerfSide1) then if (CurrInterface.TypeI = itFunctional) and (CurrInterface.Side = aSide) then begin if ((CurrInterface.IsBusy = biTrue) or (CurrInterface.BusyPositions.Count > 0)) then begin for k := 0 to CurrInterface.BusyPositions.Count - 1 do begin InterfPos := TSCSInterfPosition(CurrInterface.BusyPositions[k]); if (((InterfPos.FromPos + TempNpp) <= ACurrNpp) and ((InterfPos.ToPos + TempNpp) >= ACurrNpp)) then begin ConnectedPosFound := True; CableInterfPos := InterfPos; InterfPos := InterfPos.GetConnectedPos; break; end; end; if ConnectedPosFound then Break; //// BREAK //// end end; end; if ConnectedPosFound then begin InternalInterface := nil; if ((InterfPos.InterfOwner.ComponentOwner <> nil) and (InterfPos.InterfOwner.ComponentOwner.isLine = biFalse)) then begin InternalConnection := False; PointComponInterface := TSCSInterface(InterfPos.InterfOwner); // прописать конец пути (пришли на поинт) if aWayListSide = 1 then begin TCableWayCompon(CableWay[aNpp-1]).FirstCompon := PointComponInterface.ComponentOwner; TCableWayCompon(CableWay[aNpp-1]).Side1ConnectedInterface := InterfPos.InterfOwner; end else if aWayListSide = 2 then begin TCableWayCompon(CableWay[aNpp-1]).LastCompon := PointComponInterface.ComponentOwner; TCableWayCompon(CableWay[aNpp-1]).Side2ConnectedInterface := InterfPos.InterfOwner; end; // если это проходящее соединение -- TempNpp := 0; for i := 0 to PointComponInterface.InternalConnected.Count - 1 do begin InternalInterface := TSCSInterface(PointComponInterface.InternalConnected[i]); if ((TempNpp <= ACurrNpp) and ((InternalInterface.Kolvo + TempNpp) >= ACurrNpp)) then begin //ShowMessage('InternalConnection Found on ' + PointComponInterface.ComponentOwner.Name); break; end else begin CurrNpp := CurrNpp - InternalInterface.Kolvo; TempNpp := TempNpp + InternalInterface.Kolvo; end; end; end; if InternalInterface <> nil then begin TempNpp := 0; if InternalInterface.Kolvo > InterfPos.InterfOwner.Kolvo then begin for i := 0 to InternalInterface.InternalConnected.Count - 1 do begin if InternalInterface.InternalConnected[i] <> InterfPos.InterfOwner then begin TempNpp := TempNpp + InternalInterface.InternalConnected[i].Kolvo; end else begin CurrNpp := currNpp + TempNpp; TempNpp := 0; Break; //// BREAK ////; end; end; end; // определить позицию пришедшего интерфейса по отношению к подключенному через точку for i := 0 to InternalInterface.BusyPositions.Count - 1 do begin InterfPos := TSCSInterfPosition(InternalInterface.BusyPositions[i]); if (InterfPos.FromPos <= CurrNpp) and (InterfPos.ToPos >= currNpp) then begin InterfPos := InterfPos.GetConnectedPos; if InterfPos <> nil then begin InterNalConnectedCompon := InterfPos.InterfOwner.ComponentOwner; if ((InternalConnectedCompon <> nil) and IsCableComponent(InternalConnectedCompon)) then begin if InterfPos.InterfOwner.Side = 1 then InternalConnSide := 2 else if InterfPos.InterfOwner.Side = 2 then InternalConnSide := 1; // вписать путь if aWayListSide = 1 then begin TCableWayCompon(CableWay[aNpp - 1]).WayList.Insert(0, TCableWayCompon(CableWay[aNpp - 1]).FirstCompon); TCableWayCompon(CableWay[aNpp - 1]).FirstCompon := nil; TCableWayCompon(CableWay[aNpp - 1]).Side1ConnectedInterface := Nil; TCableWayCompon(CableWay[aNpp - 1]).WayList.Insert(0, InterNalConnectedCompon); end else if aWayListSide = 2 then begin TCableWayCompon(CableWay[aNpp - 1]).WayList.Add(TCableWayCompon(CableWay[aNpp - 1]).LastCompon); TCableWayCompon(CableWay[aNpp - 1]).LastCompon := nil; TCableWayCompon(CableWay[aNpp - 1]).Side2ConnectedInterface := Nil; TCableWayCompon(CableWay[aNpp - 1]).WayList.Add(InterNalConnectedCompon); end; CanSeekCable := True; while CanSeekCable do begin CanSeekCable := False; for j := 0 to InterNalConnectedCompon.Interfaces.Count - 1 do begin if (TSCSInterface(InterNalConnectedCompon.Interfaces[j]).TypeI = itFunctional) and (TSCSInterface(InterNalConnectedCompon.Interfaces[j]).Side = InternalConnSide) and ((TSCSInterface(InterNalConnectedCompon.Interfaces[j]).isBusy = biTrue) or ((TSCSInterface(InterNalConnectedCompon.Interfaces[j]).BusyPositions.Count > 0 ))) then begin InterfPos := TSCSInterfPosition(TSCSInterface(InterNalConnectedCompon.Interfaces[j]).BusyPositions[0]); InterfPos := InterfPos.GetConnectedPos; if InterfPos <> nil then begin // присоединен кабель if IsCableComponent(InterfPos.InterfOwner.ComponentOwner) then begin //сторона для последующего соединения if InterfPos.InterfOwner.Side = 1 then InternalConnSide := 2 else if InterfPos.InterfOwner.Side = 2 then InternalConnSide := 1; // переопределяем текущий кабель InterNalConnectedCompon := TSCSComponent(InterfPos.InterfOwner.ComponentOwner); // вписать путь if aWayListSide = 1 then TCableWayCompon(CableWay[aNpp -1]).WayList.Insert(0, InterNalConnectedCompon) else if aWayListSide = 2 then TCableWayCompon(CableWay[aNpp -1]).WayList.Add(InterNalConnectedCompon); CanSeekCable := True; Break; //// BREAK //// end // дошли до точки else begin if TSCSComponent(InterfPos.InterfOwner.ComponentOwner).isLine = biFalse then begin // точка PointCompon := TSCSComponent(InterfPos.InterfOwner.ComponentOwner); if aWayListSide = 1 then begin TCableWayCompon(CableWay[aNpp -1]).FirstCompon := TSCSComponent(InterfPos.InterfOwner.ComponentOwner); TCableWayCompon(CableWay[aNpp -1]).Side1ConnectedInterface := InterfPos.InterfOwner; end else if aWayListSide = 2 then begin TCableWayCompon(CableWay[aNpp -1]).LastCompon := TSCSComponent(InterfPos.InterfOwner.ComponentOwner); TCableWayCompon(CableWay[aNpp -1]).Side2ConnectedInterface := InterfPos.InterfOwner; end; end; CanSeekCable := False; Break; //// BREAK //// end; end; end; end; end; // GetCableWayBySide(aSide, aNpp, CurrNpp, InterNalConnectedCompon, aWayListSide); GetCableWayBySide(InternalConnSide, aNpp, CurrNpp, InterNalConnectedCompon, aWayListSide); end; end; end; end; end; end; end; begin CableWay := nil; FCableNpp := 0; currNpp := 0; Side1InterfList := TList.Create; Side2InterfList := TList.Create; //список прохождения каждого интерфейса (от и до) //количество жил for i := 0 to aCableCompon.Interfaces.Count - 1 do begin if ((TSCSInterface(aCableCompon.Interfaces[i]).TypeI = itFunctional) and (TSCSInterface(aCableCompon.Interfaces[i]).Side = 1)) then FCableNpp := FCableNpp + TSCSInterface(aCableCompon.Interfaces[i]).Kolvo; end; if FCableNpp > 0 then begin // создать пути CableWay := TList.Create; for i := 1 to FCableNpp do begin CableWayCompon := TCableWayCompon.Create; CableWayCompon.WayList.Add(aCableCompon); CableWayCompon.Npp := i; CableWay.Add(CableWayCompon); CableWayCompon.GroupedNpp.Add(i); end; // забить наименования интерфейсов в пути прохождения //CanSeekCable := True; currNPP := 0; for i := 0 to aCableCompon.Interfaces.Count - 1 do begin if (TSCSInterface(aCableCompon.Interfaces[i]).TypeI = itFunctional) and (TSCSInterface(aCableCompon.Interfaces[i]).Side = 1) then begin for j := 1 to TSCSInterface(aCableCompon.Interfaces[i]).Kolvo do begin TCableWayCompon(CableWay[currNpp]).CableInterfName := TSCSInterface(aCableCompon.Interfaces[i]).LoadName; TCableWayCompon(CableWay[currNpp]).CableInterface := TSCSInterface(aCableCompon.Interfaces[i]); Inc(CurrNpp); end; end; end; for i := 0 to aCableCompon.Interfaces.Count - 1 do begin // занятые интерфейсы кабеля с одной стороны if ((TSCSInterface(aCableCompon.Interfaces[i]).TypeI = itFunctional) and (TSCSInterface(aCableCompon.Interfaces[i]).Side = 1) and ((TSCSInterface(aCableCompon.Interfaces[i]).BusyPositions.Count > 0) or (TSCSInterface(aCableCompon.Interfaces[i]).IsBusy = biTrue))) then Side1InterfList.Add(TSCSInterface(aCableCompon.Interfaces[i])) else // занятые интерфейсы кабеля с другой стороны if ((TSCSInterface(aCableCompon.Interfaces[i]).TypeI = itFunctional) and (TSCSInterface(aCableCompon.Interfaces[i]).Side = 2) and ((TSCSInterface(aCableCompon.Interfaces[i]).BusyPositions.Count > 0) or (TSCSInterface(aCableCompon.Interfaces[i]).IsBusy = biTrue))) then Side2InterfList.Add(TSCSInterface(aCableCompon.Interfaces[i])); end; // края кабеля с обеих сторон (если стали где-то на средине) Side1CableCompon := aCableCompon; Side2CableCompon := aCableCompon; //первая сторона CanSeekCable := True; ConnectInerfSide1 := 1; while CanSeekCable do begin CanSeekCable := False; for i := 0 to Side1CableCompon.Interfaces.Count - 1 do begin if (TSCSInterface(Side1CableCompon.Interfaces[i]).TypeI = itFunctional) and (TSCSInterface(Side1CableCompon.Interfaces[i]).Side = ConnectInerfSide1) and ((TSCSInterface(Side1CableCompon.Interfaces[i]).isBusy = biTrue) or ((TSCSInterface(Side1CableCompon.Interfaces[i]).BusyPositions.Count > 0 ))) then begin InterfacePosition := TSCSInterfPosition(TSCSInterface(Side1CableCompon.Interfaces[i]).BusyPositions[0]); InterfacePosition := InterfacePosition.GetConnectedPos; if InterfacePosition <> nil then begin // присоединен кабель if IsCableComponent(InterfacePosition.InterfOwner.ComponentOwner) then begin //сторона для последующего соединения if InterfacePosition.InterfOwner.Side = 1 then ConnectInerfSide1 := 2 else if InterfacePosition.InterfOwner.Side = 2 then ConnectInerfSide1 := 1; // переопределяем текущий кабель Side1CableCompon := TSCSComponent(InterfacePosition.InterfOwner.ComponentOwner); // вписать путь for j := 0 to CableWay.Count - 1 do begin TCableWayCompon(CableWay[j]).WayList.Insert(0, Side1CableCompon); end; CanSeekCable := True; Break; //// BREAK //// end; end; end; end; end; //вторая сторона CanSeekCable := True; ConnectInterfSide2 := 2; while CanSeekCable do begin CanSeekCable := False; for i := 0 to Side2CableCompon.Interfaces.Count - 1 do begin if (TSCSInterface(Side2CableCompon.Interfaces[i]).TypeI = itFunctional) and (TSCSInterface(Side2CableCompon.Interfaces[i]).Side = ConnectInterfSide2) and ((TSCSInterface(Side2CableCompon.Interfaces[i]).isBusy = biTrue) or ((TSCSInterface(Side2CableCompon.Interfaces[i]).BusyPositions.Count > 0 ))) then begin InterfacePosition := TSCSInterfPosition((TSCSInterface(Side2CableCompon.Interfaces[i]).BusyPositions[0])); InterfacePosition := InterfacePosition.GetConnectedPos; if InterfacePosition <> nil then begin // присоединен кабель if IsCableComponent(InterfacePosition.InterfOwner.ComponentOwner) then begin //сторона для последующего соединения if InterfacePosition.InterfOwner.Side = 1 then ConnectInterfSide2 := 2 else if InterfacePosition.InterfOwner.Side = 2 then ConnectInterfSide2 := 1; // переопределяем текущий кабель Side2CableCompon := TSCSComponent(InterfacePosition.InterfOwner.ComponentOwner); for j := 0 to CableWay.Count - 1 do begin TCableWayCompon(CableWay[j]).WayList.Add(Side2CableCompon); end; CanSeekCable := True; Break; //// BREAK //// end; end; end; end; end; // если есть незанятые позиции кабеля на концах -- сбрасываем их сразу // сторона 1 for i := 0 to CableWay.Count - 1 do begin currNPP := 0;//смещение позиции интерфейса CanSeekCable := True; ConnectedPosFound := False; for j := 0 to Side1CableCompon.Interfaces.Count - 1 do begin CurrentInterface := TSCSInterface(Side1CableCompon.Interfaces[j]); if (CurrentInterface.TypeI = itFunctional) and (CurrentInterface.Side = ConnectInerfSide1) then begin if ((CurrentInterface.IsBusy = biTrue) or (CurrentInterface.BusyPositions.Count > 0)) then begin for k := 0 to CurrentInterface.BusyPositions.Count - 1 do begin InterfacePosition := TSCSInterfPosition(CurrentInterface.BusyPositions[k]); if (((InterfacePosition.FromPos + currNPP) <= (i+1)) and ((InterfacePosition.ToPos + currNPP) >= (i+1))) then begin CanSeekCable := False; ConnectedPosFound := True; InterfacePosition := InterfacePosition.GetConnectedPos; if InterfacePosition <> nil then begin if InterfacePosition.InterfOwner.ComponentOwner.isLine = biFalse then TCableWayCompon(CableWay[i]).FirstCompon := InterfacePosition.InterfOwner.ComponentOwner; end else TCableWayCompon(CableWay[i]).FirstCompon := nil; break; end; end; if ConnectedPosFound then Break; //// BREAK //// end else currNPP := currNpp + CurrentInterface.Kolvo; if (currNPP > (i+1)) then begin CanSeekCable := False; Break; //// BREAK ////; end; end; {if (CanSeekCable) and (CurrentInterface.TypeI = itFunctional) and (CurrentInterface.Side = ConnectInerfSide1) then currNPP := currNpp + CurrentInterface.Kolvo else break;} end; if not ConnectedPosFound then TCableWayCompon(CableWay[i]).CanSeekSide1 := False; end; // сторона 2 for i := 0 to CableWay.Count - 1 do begin currNPP := 0;//смещение позиции интерфейса CanSeekCable := True; ConnectedPosFound := False; for j := 0 to Side2CableCompon.Interfaces.Count - 1 do begin CurrentInterface := TSCSInterface(Side2CableCompon.Interfaces[j]); if (CurrentInterface.TypeI = itFunctional) and (CurrentInterface.Side = ConnectInterfSide2) then begin if ((CurrentInterface.IsBusy = biTrue) or (CurrentInterface.BusyPositions.Count > 0)) then begin for k := 0 to CurrentInterface.BusyPositions.Count - 1 do begin InterfacePosition := TSCSInterfPosition(CurrentInterface.BusyPositions[k]); if (((InterfacePosition.FromPos + currNPP) <= (i+1)) and ((InterfacePosition.ToPos + currNPP) >= (i+1))) then begin CanSeekCable := False; ConnectedPosFound := True; InterfacePosition := InterfacePosition.GetConnectedPos; if InterfacePosition <> nil then begin if InterfacePosition.InterfOwner.ComponentOwner.isLine = biFalse then TCableWayCompon(CableWay[i]).LastCompon := InterfacePosition.InterfOwner.ComponentOwner; end else TCableWayCompon(CableWay[i]).LastCompon := nil; break; end; end; if ConnectedPosFound then Break; //// BREAK //// end else currNPP := currNpp + CurrentInterface.Kolvo; if (currNPP > (i+1)) then begin CanSeekCable := False; Break; //// BREAK ////; end; end; {if (CanSeekCable) and (CurrentInterface.TypeI = itFunctional) and (CurrentInterface.Side = ConnectInterfSide2) then currNPP := currNpp + CurrentInterface.Kolvo else break;} end; if not ConnectedPosFound then TCableWayCompon(CableWay[i]).CanSeekSide2 := False; end; // топаем в обе стороны по каждой жиле for i := 0 to CableWay.Count - 1 do begin if TCableWayCompon(CableWay[i]).CanSeekSide1 then GetCableWayBySide(ConnectInerfSide1, i+1, i+1, Side1CableCompon, 1); if TCableWayCompon(CableWay[i]).CanSeekSide2 then GetCableWayBySide(ConnectInterfSide2, i+1, i+1, Side2CableCompon, 2); end; Result := TIntList.Create; for i := 0 to CableWay.Count - 1 do begin for j := 0 to TCableWayCompon(CableWay[i]).WayList.Count - 1 do begin currCompon := TSCSComponent(TCableWayCompon(CableWay[i]).WayList[j]); if isCableComponent(currCompon) then begin FCableCatalog := currCompon.GetFirstParentCatalog; if FCableCatalog <> nil then begin FCableFigure := GetFigureByCatalogId(FCableCatalog.SCSID); if FCableFigure <> nil then begin if checkFigureByClassName(FCableFigure, cTOrthoLine) and (Result.IndexOf(FCableFigure.Id) = -1) then Result.Add(FCableFigure.ID); end; end; end; end; end; if Result.Count = 0 then FreeAndNil(Result); FreeAndNil(Side1InterfList); FreeAndNil(Side2InterfList); for i := 0 to CableWay.Count - 1 do begin CableWayCompon := TCableWayCompon(CableWay[i]); FreeAndNil(CableWayCompon); end; FreeAndNil(CableWay); end; end; *) // Tolik 21/02/2017 -- Function GetUserObjectsQuota: Integer; var Reg: TRegistry; begin Result := 10000; Try // WinXp, Server2003 и т.п. (ниже Win7) if isWinLowThenWin7 then Result := 8000 // тут просто даже редактирование ключа реестра не сильно спасает else // Win7 и выше -- увеличение квоты в реестре где-то до 50000(на всякий) может помочь // обычно по умолчанию установлено 10000 begin Reg := TRegIniFile.Create; Reg.RootKey := HKEY_LOCAL_MACHINE; Reg.OpenKeyReadOnly('Software'); Reg.OpenKeyReadOnly('Microsoft'); Reg.OpenKeyReadOnly('Windows NT'); Reg.OpenKeyReadOnly('CurrentVersion'); Reg.OpenKeyReadOnly('Windows'); if Reg.ValueExists('USERProcessHandleQuota') then Result := Reg.ReadInteger('USERProcessHandleQuota');// квота на объекты USER в реестре ПК Reg.CloseKey; Reg.Free; end; except on E: Exception do begin Result := 10000; //Tolik 09/03/2022 -- здесь не пушаем пользователя... //addExceptionToLogEX('U_Common.GetUserObjectsQuota', E.Message); AddExceptionToLogSilent('U_Common.GetUserObjectsQuota ' + E.Message); end; end; end; function CheckUserObjQuotaReached(ObjCount: Integer): integer; // проверка превышения квоты объектов USER 1 - превышение, 2 - приближение(в пределах 500 до квоты), 3 = OK -- не превышаем var currUserObjCount: Integer; MemStat: TMemoryStatus; begin Result := 3; {MemStat.dwLength := SizeOf(MemStat); GlobalMemoryStatus(MemStat);} currUserObjCount := GetGuiResources(GetCurrentProcess, 1); // вот такая штука работает, правда, только начиная с WIN7 -- вернет общее количество объектов в системе // в данный момент //currUserObjCount := GetGuiResources(GetCurrentProcess, 4); // 0 - GDIObjs cur Proc, 1 - UserObjs cur Proc - // 3 = GDI(все), 4 = GR_USEROBJECTS_PEAK // превышение допустимой квоты на объекты типа USER OBJECTS if (currUserObjCount > GUserObjectsQuota) then begin Result := 1 end else // угроза превышения допустимой квоты на объекты типа USER OBJECTS // здесь параметр ObjCount понимать как количество SCS объектов, которые // хотим создать -- begin if (GUserObjectsQuota - (currUserObjCount + ObjCount*2)) < 500 then Result := 2; end; end; function GetQuotaMessage(Mess_Kind: Integer; Add_Mess: string): String; var CanChangeQuota: Boolean; begin Result := ''; if Mess_Kind < 3 then if GUserOBjectsQuotaLimit_Message_Counter < 3 then begin CanChangeQuota := False; if (not isWinLowThenWin7) and (GUserObjectsQuota <10001) then CanChangeQuota := True; case Mess_Kind of 1: // превышение квоты Result := Add_Mess + cMess_Quota1; 2: // угроза превышения квоты Result := Add_Mess + cMess_Quota2; end; if isWinLowThenWin7 then Result := Result + #13#10 + cMess_WinXP_QuotaAssigned else begin if CanChangeQuota then Result := Result + #13#10 + cMess_Win_CanChangeQuota else Result := Result + #13#10 + cMess_Win_CanNotChangeQuota; end; inc(GUserOBjectsQuotaLimit_Message_Counter); end; end; // юзается на проверке при копировании листа (можно ли выполнить копирование компонент листа, // чтобы не перебрать квоту на USERObjects) function CheckCanCopyComponsFromListToList: Boolean; var CurrentUserObjCount, SystenUserObjQuota: Integer; begin Result := True; CurrentUserObjCount := GetGuiResources(GetCurrentProcess, 1); SystenUserObjQuota := GetUserObjectsQuota; if SystenUserObjQuota - (CurrentUserObjCount + (GCadForm.FSCSFigures.Count*2)) < 500 then Result := False; end; // Tolik -- 21/03/2017 -- procedure SelectFigureInTree(aFigure: TFigure; aShiftState: TShiftState; var aFirstNode: Boolean; ClearSelection: Boolean = False); var Node, ParentNode: TTreeNode; FigCatalog, TopParentCatalog: TSCSCatalog; begin if aFigure.Deleted then Exit; if (aFigure.ClassName = cTOrthoLine) or (aFigure.ClassName = cTConnectorObject) then begin FigCatalog := F_ProjMan.GSCSBase.CurrProject.CurrList.GetCatalogFromReferencesBySCSID(aFigure.Id); if FigCatalog <> nil then begin if ClearSelection then F_ProjMan.Tree_Catalog.ClearSelection; Node := FigCatalog.TreeViewNode; if not Node.Selected then begin if not Node.Expanded then begin Node.Expand(True); end; if aFirstNode then begin F_ProjMan.Tree_Catalog.Select(Node, []); aFirstNode := False; end else F_ProjMan.Tree_Catalog.Select(Node, aShiftState); end; end; end; end; // -- Tolik 15/05/2017 -- procedure Select_Figures_In_Tree(aSelList: TList; aShiftState: TShiftState); var i, j: Integer; Node, ChildNode: TTreeNode; currFigure: TFigure; currCatalog: TSCSCatalog; FiguresList: TList; function CheckallLineSelected(LineConn: TConnectorObject; aLine: TOrthoLine): Boolean; var nextConn: TConnectorObject; begin Result := False; nextConn := Nil; if TConnectorObject(aLine.JoinConnector1).Id = LineConn.Id then nextConn := TConnectorObject(aLine.JoinConnector2) else if TConnectorObject(aLine.JoinConnector2).Id = LineConn.Id then nextConn := TConnectorObject(aLine.JoinConnector1); if ((nextConn <> nil) and (not nextConn.deleted)) then begin if aSelList.IndexOf(nextConn) <> - 1 then Result := True; end; if ((not Result) and (nextConn <> nil) and (not nextConn.deleted)) then begin if nextConn.JoinedConnectorsList.Count > 0 then begin nextConn := TConnectorObject(NextConn.JoinedConnectorsList[0]); if not nextConn.deleted then begin if aSelList.IndexOf(nextConn) <> -1 then Result := true; end; end; end; end; begin FiguresList := TList.Create; for i := 0 to aSelList.Count - 1 do begin currFigure := TFigure(aSelList[i]); if (not currFigure.deleted) and (currFigure.Id <> -1) then begin if checkFigureByClassNAme(currFigure, cTConnectorObject) then begin if TConnectorObject(currFigure).ConnectorType = ct_Clear then begin for j := 0 to TConnectorObject(currFigure).JoinedConnectorsList.Count - 1 do begin if aSelList.IndexOf(TConnectorObject(TConnectorObject(currFigure).JoinedConnectorsList[j])) = -1 then if FiguresList.IndexOf(TConnectorObject(TConnectorObject(currFigure).JoinedConnectorsList[j])) = -1 then FiguresList.Add(TConnectorObject(TConnectorObject(currFigure).JoinedConnectorsList[j])); end; for j := 0 to TConnectorObject(currFigure).JoinedOrthoLinesList.Count - 1 do begin if CheckAllLineSelected (TConnectorObject(currFigure), TOrthoLine(TConnectorObject(currFigure).JoinedOrthoLinesList[j])) and (FiguresList.IndexOf(TOrthoLine(TConnectorObject(currFigure).JoinedOrthoLinesList[j])) = -1) then FiguresList.Add(TOrthoLine(TConnectorObject(currFigure).JoinedOrthoLinesList[j])); end; if FiguresList.IndexOf(currFigure) = -1 then FiguresList.Add(currFigure); end else if FiguresList.IndexOf(currFigure) = -1 then FiguresList.Add(currFigure); end else if FiguresList.IndexOf(currFigure) = -1 then FiguresList.Add(currFigure); end; end; for i := 0 to FiguresList.Count - 1 do begin currFigure:= TFigure(FiguresList[i]); currCatalog := F_ProjMan.GSCSBase.CurrProject.CurrList.GetCatalogFromReferencesBySCSID(currFigure.ID); if currCatalog <> nil then begin Node := currCatalog.TreeViewNode; if node = nil then Node := F_ProjMan.FindComponOrDirInTree(currCatalog.ID, false); if Node <> nil then if not Node.Selected then F_ProjMan.Tree_Catalog.Select(Node, aShiftState); end; end; FiguresList.Free; end; // // Tolik Function GetNBConnector(aObj: TConnectorObject): TConnectorObject; var i: Integer; begin Result := nil; if aObj.ConnectorType = ct_NB then Result := aObj else begin for i := 0 to aObj.JoinedConnectorsList.Count - 1 do begin if TConnectorObject(aObj.JoinedConnectorsList[i]).ConnectorType = ct_NB then begin Result := TConnectorObject(aObj.JoinedConnectorsList[i]); break; end; end; end; end; // Tolik -- 31/05/2016 -- function GetFigureByCatalogId(CatalogId: Integer): TFigure; var i: Integer; begin Result := nil; for i := 0 to GCadForm.FSCSFigures.Count - 1 do begin if TFigure(GCadForm.FSCSFigures[i]).ID = CatalogId then begin Result := TFigure(GCadForm.FSCSFigures[i]); break; end; end; end; { -- эте перенесено вверх // вычисляет Z - координату "падения" точечного компонента на наклонную линию, // если координаты X, Y - известны Function GetCoordZ(ASnapFigure: TFigure; CoordX, CoordY: Double): Double; // Tolik 27/02/2018 Var vx, vy, vz, xx1, xx2, yy1, yy2, zz1, zz2, TempZ : Double; Begin Result := 0; //первая точка прямой xx1 := RounDX(TOrthoLine(ASnapFigure).JoinConnector1.ActualPoints[1].x,2); yy1 := RounDX(TOrthoLine(ASnapFigure).JoinConnector1.ActualPoints[1].y,2); zz1 := RounDX(TConnectorObject(TOrthoLine(ASnapFigure).JoinConnector1).ActualZOrder[1],2); //вторая точка прямой xx2 := RounDX(TOrthoLine(ASnapFigure).JoinConnector2.ActualPoints[1].x,2); yy2 := RounDX(TOrthoLine(ASnapFigure).JoinConnector2.ActualPoints[1].y,2); zz2 := RounDX(TConnectorObject(TOrthoLine(ASnapFigure).JoinConnector2).ActualZOrder[1],2); // направляющий вектор для прямой (координаты) vx := xx2 - xx1; vy := yy2 - yy1; vz := zz2 - zz1; if (vx <> 0) then begin Result := Roundx(((CoordX - xx1)/vx)*vz + zz1, 2); end else begin if (vy <> 0) then Result := RoundX(((CoordY - yy1)/vy)*vz + zz1, 2); end; End; } // оригинал закомменчен см. ниже, а тут переделано немножко совсем // (доделано -- восстановление соединения на втором конце разделяемой трассы) // ПРИВЯЗКА КОНЕКТОРА К ОРТОЛИНИИ procedure SnapConnectorToOrtholine(AConnector: TConnectorObject; ASnapLine: TOrtholine); var i, j: integer; NewDeltaX, NewDeltaY: double; AddLine: TOrthoLine; JoinedCon: TConnectorObject; ClearCon1, ClearCon2: TConnectorObject; NextConnector: TFigure; Modx, Mody, NextModx, NextMody: Double; TempDefaultNum: integer; CurrentLine: TOrthoLine; CP_Line: TDoublePoint; MustRealign: Boolean; AngleRad: double; // Koef: Double; AllLengthXY: Double; CurrLengthXY: Double; DeltaHeight: Double; JoinedConn: TConnectorObject; ObjToDisconnect: TList; GetOtherConn: TConnectorObject; //Tolik GtempListCreated: Boolean; SnapZ: Double; // высота, на которой объект попадает на трассу CadRefreshFlag: Boolean; RaiseLine: TOrthoLine; RaiseConn: TConnectorObject; JoinedComponList: TList; // Tolik SavedLineComponList, SavedPointComponList: TList; DivLineObject, JoinedPointObject: TSCSCatalog; PointCompon: TSCSComponent; NBConnector: TConnectorObject; InterfRel : TSCSIOfIRel; InterfPosition, JoinedPosition: TSCSInterfPosition; LineCompon: TSCSComponent; ALineInterFace, APointInterFace, aTempInterf: TSCSInterface; LineInterfList: TList; ConnComponList: TList; AInterfPositions1, AInterfPositions2: TSCSInterfPositions; LineComponInterFace, PointComponInterFace: TSCSInterFace; InterFaceAccordanceList: TList; APointInterfID: Integer; ConnectedInterFaces: TSCSIOfIRel; ConnectIDCompRel: Integer; TempInterfaces1, TempInterfaces2: TSCSInterfaces; InterfCount: Integer; ptrConnection: PComplect; DisJoinList: TList; JoinedLineConnectInfo, SelfLineConnectInfo: TLineComponConnectionInfo; SavedComponList, SavedLineConnectionsList: TList; ObjParams: TObjectParams; NoCopyComponentList: TList; // Tolik 26/09/2018 -- AddedLineCatalog, OldLineCatalog: TSCSCatalog; NewCompon: TSCSComponent; // // Tolik 31/03/2021 -- points: TDoublePointArr; LineClickIndex: integer; SnapLineCount, FirstSnapIndex: integer; LineForNextSnap: TOrthoLine; // //Tolik 08/08/2021 - NewConn, CreatedConn: TConnectorObject; NewPt: TDoublePoint; SnapIdx: integer; // Tolik 31/08/2021 -- Procedure CheckSaveLineConnectionsBySide(aLine: TOrthoLine; aCableCompon: TSCSComponent; aSide: Integer); var i, j, k: Integer; InterfPos: TSCSInterfPosition; Interf, ConnectedInterf: TSCSInterface; DirectConnectedComponList, ConnectedComponList: TList; JoinedCompon, ConnectedLineComponent: TSCSComponent; PointToSave: TConnectorObject; PointCatalog, LineCatalog, JoinedLineCatalog: TSCSCatalog; POintFigure, LineFigure: TFigure; CanContinue: Boolean; WayList: TList; // ComponToDeleteList: TSCSComponents; LastComponent: TSCSComponent; LastSide: Integer; isLineConnection, isPointConnection: Boolean; ComponJoinedByMultiInterface: TSCSComponent; JoinedInterface: TSCSInterface; FirstComponID: Integer; SavedPointConnection: Boolean; Procedure SaveConnectionOnPointObject(aPointObject: TConnectorObject; aPointCatalog: TSCSCatalog; aJoinedLineCompon: TSCSComponent; ConnectionSide: Integer); var i, j, k, l, m: Integer; PointJoinedLineCatalog : TSCSCatalog; PointComponent, LineComponent: TSCSComponent; LineJoinedComponList: TList; LineInterface: TSCSInterface; aCableComponInterface: TSCSInterface; begin NBConnector := APointObject; if NBConnector <> nil then begin if (aPointCatalog <> nil) then begin //if ((aPointCatalog.ComponentReferences.Count > 0) and (DivLineObject.ComponentReferences.Count > 0)) then begin InterFaceAccordanceList := TList.Create; if IsCableComponent(aJoinedLineCompon) then // так правильнее -- для всех кабелей // begin if CheckJoinedComponToComponFromObject(aJoinedLineCompon, aPointCatalog) then begin for k := 0 to aJoinedLineCompon.Interfaces.count - 1 do begin if (aJoinedLineCompon.Interfaces[k].TypeI = itFunctional) and (aJoinedLineCompon.Interfaces[k].Side = ConnectionSide) and ((aJoinedLineCompon.Interfaces[k].IsBusy = biTrue) or (aJoinedLineCompon.Interfaces[k].BusyPositions.Count > 0)) then begin SavedLineComponList := TList.Create; SavedPointComponList := TList.Create; ALineInterFace := TSCSInterFace(aJoinedLineCompon.Interfaces.Items[k]); if aCableCompon.Id = aJoinedLineCompon.id then begin if SavedLineComponList.IndexOf(ALineInterFace) = -1 then SavedLineComponList.Add(TSCSInterface(ALineInterFace)); end else begin aCableComponInterFace := aCableCompon.Interfaces[k]; if SavedLineComponList.IndexOf(aCableComponInterFace) = -1 then SavedLineComponList.Add(TSCSInterface(aCableComponInterFace)); end; APointInterfID := -1; for l := 0 to ALineInterFace.BusyPositions.Count - 1 do begin InterfPosition := ALineInterFace.BusyPositions[l]; JoinedPosition := InterfPosition.GetConnectedPos; if JoinedPosition <> nil then begin if JoinedPosition.InterfOwner <> nil then begin if SavedPointComponList.IndexOf(JoinedPosition.InterfOwner) = -1 then SavedPointComponList.Add(TSCSInterFace(JoinedPosition.InterfOwner)); end; end; end; if ((SavedLineComponList.Count > 0) and (SavedPointComponList.Count > 0)) then begin InterFaceAccordanceList.Add(SavedLineComponList); InterFaceAccordanceList.Add(SavedPointComponList); end else begin SavedLineComponList.Clear; SavedPointComponList.Clear; FreeAndNil(SavedLineComponList); FreeAndNil(SavedPointComponList); end; end; end; end; end; //end; end; if InterFaceAccordanceList.Count > 0 then begin // состояние соединения кабеля на точечном объекте SelfLineConnectInfo := TLineComponConnectionInfo.Create(True); SelfLineConnectInfo.ComponId := aCableCompon.ID;//AJoinedLineCompon.ID; //SelfLineConnectInfo.ComponSide := ConnectionSide; SelfLineConnectInfo.ComponSide := aSide; SelfLineConnectInfo.isLineConnection := False; JoinedLineConnectInfo := TLineComponConnectionInfo.Create(False); JoinedLineConnectInfo.ComponCatalogID := APointCatalog.ID; JoinedLineConnectInfo.ComponSide := 0; JoinedLineConnectInfo.ConnectedComponList := InterFaceAccordanceList; SelfLineConnectInfo.ConnectedComponList.Add(JoinedLineConnectInfo); SavedLineConnectionsList.Add(SelfLineConnectInfo); end else FreeAndNil(InterFaceAccordanceList); end; end; // сбросить соединения линейного с точечными на заданной стороне LineJoinedComponList := TList.Create; for i := 0 to aJoinedLineCompon.Interfaces.Count - 1 do begin LineInterface := TSCSInterface(aJoinedLineCompon.Interfaces[i]); if (LineInterface.TypeI = itFunctional) and (LineInterface.Side = ConnectionSide) then begin for j := 0 to LineInterface.ConnectedInterfaces.Count - 1 do if LineJoinedComponList.IndexOf(TSCSComponent(LineInterface.ConnectedInterfaces[j].ComponentOwner)) = -1 then LineJoinedComponList.Add(TSCSComponent(LineInterface.ConnectedInterfaces[j].ComponentOwner)); end; end; for i := 0 to LineJoinedComponList.Count - 1 do begin aJoinedLineCompon.DisJoinFrom(TSCSComponent(LineJoinedComponList[i])); end; FreeAndNil(LineJoinedComponList); // end; begin CanContinue := False; SelfLineConnectInfo := nil; JoinedLineConnectInfo := Nil; ConnectedComponList := TList.Create; PointToSave := nil; isLineConnection := False; isPointConnection := False; LineFigure := Nil; SavedPointConnection := False; if ((aCableCompon.JoinedComponents.count > 0) and (SavedComponList.IndexOf(aCableCompon) = -1)) then SavedComponList.Add(ACablecompon); for i := 0 to aCableCompon.Interfaces.Count - 1 do begin Interf := TSCSInterface(aCableCompon.Interfaces[i]); // ищем возможные подключения с указанной стороны if ((Interf.Side = aSide) and (Interf.TypeI = itFunctional) and ((Interf.IsBusy = biTrue) or (interf.BusyPositions.Count > 0))) then begin for j := 0 to Interf.BusyPositions.Count - 1 do begin InterfPos := TSCSInterfPosition(Interf.BusyPositions[j]); // занятая позиция интерфейса InterfPos := InterfPos.GetConnectedPos; // подключенная к ней непосредственно позиция интерфейса // присоединенного компонента JoinedCompon := InterfPos.InterfOwner.ComponentOwner; // присоединенный компонент if JoinedCompon <> nil then begin // подключен точечный компонент if JoinedCompon.IsLine = biFalse then begin // точечное соединение -- сохранить по позициям для восстановления if ConnectedComponList.IndexOf(JoinedCompon) = -1 then ConnectedComponList.Add(JoinedCompon); if PointToSave = nil then begin PointCatalog := JoinedCompon.GetFirstParentCatalog; PointToSave := TConnectorObject(GetFigurebyCatalogID(PointCatalog.SCSID)); // нашли точечный, присоединенный к кабелю -- сохраняем соединение и вываливаемся if ((PointToSave <> nil) and (CheckFigureByClassName(PointToSave, cTConnectorObject))) then begin SaveConnectionOnPointObject(PointtoSave, PointCatalog, aCableCompon, aSide); ConnectedComponList.free; exit; //// BREAK ////; end; end; end // подключен линейный компонент // линейные поинтерфейсно соединять не нужно, просто соединить кабель else if JoinedCompon.isLine = biTrue then begin if ConnectedComponlist.IndexOf(JoinedCompon) = -1 then begin ConnectedComponList.Add(JoinedCompon); isLineConnection := True; LastSide := InterfPos.InterfOwner.Side; // сторона подлючения подключенного кабеля к текущему LineCatalog := JoinedCompon.GetFirstParentCatalog; // 30/03/2018 if LineCatalog <> nil then LineFigure := GetFigurebyCatalogID(LineCatalog.SCSID); // 30/03/2018 // если соединение - линейное - сохранить его if (LineFigure <> nil) and (not SavedPointConnection) then begin // кабель поднимаемой трассы SelfLineConnectInfo := TLineComponConnectionInfo.Create(True); SelfLineConnectInfo.ComponId := aCableCompon.ID; SelfLineConnectInfo.ComponSide := aSide; // трасса и сторона соединения JoinedLineConnectInfo:= TLineComponConnectionInfo.Create(False); JoinedLineConnectInfo.ComponId := JoinedCompon.ID; if TOrthoLine(LineFigure).FIsVertical then begin if LastSide = 1 then LastSide := 2 else if LastSide = 2 then LastSide := 1; end; JoinedLineConnectInfo.ComponSide := LastSide; JoinedLineCatalog := JoinedCompon.GetFirstParentCatalog; if JoinedLineCatalog <> nil then JoinedLineConnectInfo.ComponCatalogID := JoinedLineCatalog.ID; SelfLineConnectInfo.ConnectedComponList.Add(JoinedLineConnectInfo); SavedLineConnectionsList.Add(SelfLineConnectInfo); //отключить найденный кабель нах if aCableCompon.JoinedComponents.IndexOF(JoinedCompon) <> -1 then aCableCompon.DisJoinFrom(JoinedCompon); end; end; end; end; if isLineConnection then Break; //// BREAK //// if isPointConnection then Break; //// BREAK ////; end; end; if isLineConnection then Break; //// BREAK //// if isPointConnection then Break; //// BREAK ////; end; // если мультиинтерфейс - отключить все подключенные на нем( остальные кабели) // и загнать их в список подключенных компонент для восстановления, if aCableCompon.JoinedComponents.Count > 0 then begin for i := 0 to aCableCompon.Interfaces.count - 1 do begin Interf := TSCSInterface(aCableCompon.Interfaces[i]); if ((Interf.TypeI = itFunctional) and (Interf.Side = aSide) and (Interf.Multiple = biTrue) and (Interf.ConnectedInterfaces.Count > 1)) then begin if aCableCompon.JoinedComponents.Count > 0 then begin While Interf.ConnectedInterfaces.Count > 0 do begin JoinedInterface := TSCSInterface(Interf.ConnectedInterfaces[0]); ComponJoinedByMultiInterface := JoinedInterface.ComponentOwner; if ComponJoinedByMultiInterface <> nil then begin if (ComponJoinedByMultiInterface.IsLine = biTrue) then begin ConnectedComponList.Add(ComponJoinedByMultiInterface); // если было сохранение линейного соединения -- добавить в список сохранения подключенный кабель if SelfLineConnectInfo <> nil then begin FirstComponID := TLineComponConnectionInfo(SelfLineConnectInfo.ConnectedComponList[0]).ComponId; // на всякий if ComponJoinedByMultiInterface.ID <> FirstComponID then begin JoinedLineConnectInfo := TLineComponConnectionInfo.Create(False); JoinedLineConnectInfo.ComponId := ComponJoinedByMultiInterface.ID; JoinedLineConnectInfo.ComponSide := JoinedInterface.Side; SelfLineConnectInfo.ConnectedComponList.Add(JoinedLineConnectInfo); end; end; end; // отключить (если уже есть в списке или точечный компонент) aCableCompon.DisJoinFrom(ComponJoinedByMultiInterface); end; end; end; end; end; end; ConnectedComponList.Clear; FreeAndNil(ConnectedcomponList); GCadForm.PCad.Refresh; end; Procedure CheckDisJoinLineComponBySide(aLineCompon: TSCSComponent; ASide: Integer); var i, j: Integer; Interf: TSCSInterface; InterfPos: TSCSInterfPosition; JoinedComponList: TList; begin JoinedComponList := TList.Create; for i := 0 to aLineCompon.Interfaces.Count - 1 do begin Interf := TSCSInterface(aLineCompon.Interfaces[i]); if ((Interf.TypeI = itFunctional) and (Interf.Side = aSide)) then begin for j := 0 to Interf.BusyPositions.Count - 1 do begin InterfPos := TSCSInterfPosition(Interf.BusyPositions[j]); InterfPos := InterfPos.GetConnectedPos; if InterfPos <> nil then begin if JoinedComponList.IndexOf(InterfPos.InterfOwner.ComponentOwner) = -1 then JoinedComponList.Add(InterfPos.InterfOwner.ComponentOwner); end; end; end; end; for i := 0 to JoinedComponList.Count - 1 do aLineCompon.DisJoinFrom(TSCSComponent(JoinedComponList[i])); FreeAndNil(JoinedComponList); end; Procedure ConnectCableComponents(ACompon1, ACompon2: TSCSComponent); var LineCatalog1, LineCatalog2 : TSCSCatalog; SelfSide, JoinSide : integer; Line1, Line2: TOrthoLine; function CheckCanJoinOnConnectors(aConn1, aConn2: TConnectorObject): Boolean; begin Result := False; // если на одном точечном if (aConn1.JoinedConnectorsList.Count > 0) and (TConnectorObject(aConn1.JoinedConnectorsList[0]).JoinedConnectorsList.IndexOf(aConn2) <> -1) then Result := True else // или это один и тот же коннектор if aConn1.ID = aConn2.ID then Result := True; end; begin LineCatalog1 := ACompon1.GetFirstParentCatalog; LineCatalog2 := ACompon2.GetFirstParentCatalog; if ((LineCatalog1 <> nil) and (LineCatalog2 <> nil)) then begin Line1 := TOrthoLine(GetFigureByCatalogId(LineCatalog1.SCSId)); Line2 := TOrthoLine(GetFigureByCatalogId(LineCatalog2.SCSId)); if ((Line1 <> nil) and (Line2 <> nil)) then begin SelfSide := 0; JoinSide := 0; if (ACompon1 <> nil) and (ACompon2 <> nil) then begin if CheckCanJoinOnConnectors(TConnectorObject(Line1.JoinConnector1), TConnectorObject(Line2.JoinConnector1)) then ACompon1.JoinTo(ACompon2, 1, 1) else if CheckCanJoinOnConnectors(TConnectorObject(Line1.JoinConnector1), TConnectorObject(Line2.JoinConnector2)) then ACompon1.JoinTo(ACompon2, 1, 2) else if CheckCanJoinOnConnectors(TConnectorObject(Line1.JoinConnector2), TConnectorObject(Line2.JoinConnector1)) then ACompon1.JoinTo(ACompon2, 2, 1) else if CheckCanJoinOnConnectors(TConnectorObject(Line1.JoinConnector2), TConnectorObject(Line2.JoinConnector2)) then ACompon1.JoinTo(ACompon2, 2, 2); end; end; end; end; Procedure RestoreLineConnectionsBySide(aLine: TOrthoLine; ACableCompon: TSCSComponent; aSide: Integer); var i, j, k, l, m: Integer; TargetLine, TargetPointFigure: TFigure; WayList: TList; SelfConnector, TargetConn: TConnectorObject; TargetCatalog: TSCSCatalog; IdNewCompon: Integer; TargetCompon, NewCompon, FirstCompon, NextCompon: TSCSComponent; PassWayList: Boolean; // прокладывать кабель на вертикали/райзы ComponJoinedByMultiInterFace: TSCSComponent; CanRestoreConnection: Boolean; DisJoinSide: Integer; DisJoinComponList: TList; SideConnectionDropped: Boolean; Function GetInterfaceForConnection(AInterf: TSCSInterFace; WasConnectedCable, isConnectedCable: TSCSComponent; aPointObject: TConnectorObject): TSCSInterFace; var i, j, k: Integer; LineCompon: TSCSComponent; LineFigure: TOrthoLine; LineCatalog: TSCSCatalog; SourceLineCatalog, DestLineCatalog: TSCSCatalog; ConnectionSide : Integer; TmpInterfPos: TSCSInterfPosition; begin Result := nil; LineCatalog := Nil; ConnectionSide := 0; LineCompon := isConnectedCable;//AInterf.ComponentOwner; if LineCompon <> nil then begin LineCatalog := LineCompon.GetFirstParentCatalog; if LineCatalog <> nil then begin LineFigure := TOrthoLine(GetFigurebyCatalogID(LineCatalog.SCSID)); if LineFigure <> nil then begin if (TConnectorObject(LineFigure.JoinConnector1).JoinedConnectorsList.IndexOf(aPointObject) <> -1) or (TConnectorObject(LineFigure.JoinConnector1).ID = aPointObject.ID) then ConnectionSide := 1 else if (TConnectorObject(LineFigure.JoinConnector2).JoinedConnectorsList.IndexOf(aPointObject) <> -1) or (TConnectorObject(LineFigure.JoinConnector2).ID = aPointObject.ID) then ConnectionSide := 2; for j := 0 to LineCompon.Interfaces.Count - 1 do begin if TSCSInterface(LineCompon.Interfaces[j]).TypeI = itFunctional then if TSCSInterface(LineCompon.Interfaces[j]).Npp = AInterf.Npp then // вторая сторона идин х занята уже ...(если не обрыв кабеля) if TSCSInterface(LineCompon.Interfaces[j]).Side = ConnectionSide then if ((TSCSInterface(LineCompon.Interfaces[j]).IsBusy = biFalse) or (TSCSInterface(LineCompon.Interfaces[j]).BusyPositions.Count = 0)) then begin Result := TSCSInterface(LineCompon.Interfaces[j]); break; end; end; end; end; end; end; Function DefineIDComponRel(ALineCompon, APointCompon: TSCSComponent): Integer; var TopCatalog: TSCSCatalog; begin Result := -1; begin TopCatalog := aLineCompon.GetTopParentCatalog; if TopCatalog <> nil then if TopCatalog is TSCSProject then Result := TSCSProject(TopCatalog).GenIDByGeneratorIndex(giComponentRelationID, 1); end; //if IDComponRel = -1 then //IDComponRel := TF_Main(ActiveForm).AppendToComponRel(Self.ID, AComponent.ID, 1, AConnectType); end; begin WayList := nil; SelfLineConnectInfo := Nil; SelfConnector := nil; TargetConn := Nil; PassWayList := True; DisJoinComponList := nil; CanRestoreConnection := True; SideConnectionDropped := False; While CanRestoreconnection do begin CanRestoreConnection := False; for i := 0 to SavedLineConnectionsList.Count - 1 do begin if ((TLineComponConnectionInfo(SavedLineConnectionsList[i]).ComponId = ACableCompon.ID) and (TLineComponConnectionInfo(SavedLineConnectionsList[i]).ComponSide = aSide)) then begin SelfLineConnectInfo := TLineComponConnectionInfo(SavedLineConnectionsList[i]); CanRestoreConnection := True; Break; //// BREAK ////; end; end; if SelfLineConnectInfo <> nil then begin if not SideConnectionDropped then begin CheckDisJoinLineComponBySide(ACableCompon, aSide); SideConnectionDropped := True; end; if SelfLineConnectInfo.ComponSide = 1 then SelfConnector := TConnectorObject(aLine.JoinConnector1) else if SelfLineConnectInfo.ComponSide = 2 then SelfConnector := TConnectorObject(aLine.JoinConnector2); if SelfConnector <> nil then begin // for i := 0 to SelfLineConnectInfo.ConnectedComponList.Count - 1 do begin FirstCompon := F_ProjMan.GSCSBase.CurrProject.CurrList.GetComponentFromReferences(SelfLineConnectInfo.ComponId); JoinedLineConnectInfo := TLineComponConnectionInfo(SelfLineConnectInfo.ConnectedComponList[0]); TargetCompon := nil; if SelfLineConnectInfo.isLineConnection then TargetCompon := F_ProjMan.GSCSBase.CurrProject.CurrList.GetComponentFromReferences(JoinedLineConnectInfo.ComponId); if FirstCompon <> nil then begin // произошло разделение вертикали if TargetCompon = nil then begin TargetCatalog := F_ProjMan.GSCSBase.CurrProject.CurrList.GetCatalogFromReferences(JoinedLineConnectInfo.ComponCatalogID); end else if TargetCompon <> nil then TargetCatalog := TargetCompon.GetFirstParentCatalog; // линейное соединение (кабель -- кабель) if TargetCatalog <> nil then begin TargetLine := GetFigureByCatalogID(TargetCatalog.SCSID); if TargetLine <> nil then begin TargetConn := Nil; if CheckFigureByClassName(TargetLine, cTOrthoLine) then begin // линейноне подключение if JoinedLineConnectInfo.ComponSide = 1 then TargetConn := TConnectorObject(TOrthoLine(TargetLine).JoinConnector1) else if JoinedLineConnectInfo.ComponSide = 2 then TargetConn := TConnectorObject(TOrthoLine(TargetLine).JoinConnector2); end else if CheckFigureByClassName(TargetLine, CTConnectorObject) then begin // точечное подключение TargetPointfigure := TargetLine; if JoinedLineConnectInfo.ComponSide = 0 then begin TargetConn := TConnectorObject(TargetLine); end; end; if TargetConn <> nil then begin // если произошло разделение вертикали - найти коннектор от высоты подъема WayList := GetAllTraceInCAD(TFigure(SelfConnector), TFigure(TargetConn)); if WayList <> nil then begin // прокладка кабеля for j := 0 to WayList.Count - 1 do begin TargetLine := TFigure(WayList[j]); if CheckFigureByClassName(TargetLine, CTOrthoLine) then begin TargetCatalog := F_ProjMan.GSCSBase.CurrProject.CurrList.GetCatalogFromReferencesBySCSID(TargetLine.ID); if TargetCatalog <> nil then begin NewCompon := Nil; // вкинуть кабель на трассу NewCompon := CopyComponentToPMSCSObject(ACableCompon, TargetCatalog, False); // рассоединить добавленный кабель от всего, к чему подключился автоматом if NewCompon <> nil then NewCompon.DisJoinFromAll(false).Free; end; end; end; end; end; end; // FirstCompon := TargetCompon; // соединить кабели if WayList <> nil then begin if WayList.Count > 0 then begin //FirstCompon := aCableCompon; for j := 0 to WayList.count - 1 do begin TargetLine := TFigure(WayList[j]); if CheckFigureByClassName(TargetLine, cTOrthoLine) then begin TargetCatalog := F_ProjMan.GSCSBase.CurrProject.CurrList.GetCatalogFromReferencesBySCSID(TargetLine.ID); if TargetCatalog <> nil then begin NewCompon := TargetCatalog.LastAddedComponent; if NewCompon <> nil then begin if FirstCompon.JoinedComponents.IndexOf(NewCompon) = -1 then ConnectCableComponents(FirstCompon, NewCompon); // если на мультиинтерфейсе if ((j = 0) and (SelfLineConnectInfo.ConnectedComponList.Count > 1)) then begin for k := 1 to SelfLineConnectInfo.ConnectedComponList.Count - 1 do begin ComponJoinedByMultiInterFace := F_ProjMan.GSCSBase.CurrProject.CurrList.GetComponentFromReferences(TLineComponConnectionInfo(SelfLineConnectInfo.ConnectedComponList[k]).ComponId); if ComponJoinedByMultiInterFace <> nil then begin if NewCompon.JoinedComponents.IndexOf(ComponJoinedByMultiInterFace) = -1 then ConnectCableComponents(NewCompon, ComponJoinedByMultiInterFace); end; end; end; FirstCompon := NewCompon; NewCompon := Nil; end; end; end; end; // конечное соединение //NewCompon := aCableCompon;//F_ProjMan.GSCSBase.CurrProject.CurrList.GetComponentFromReferences(JoinedLineConnectInfo.ComponId); if SelfLineConnectInfo.isLineConnection then begin NewCompon := F_ProjMan.GSCSBase.CurrProject.CurrList.GetComponentFromReferences(JoinedLineConnectInfo.ComponId); if ((NewCompon <> nil) and (FirstCompon.JoinedComponents.IndexOf(NewCompon) = -1)) then ConnectCableComponents(FirstCompon, NewCompon); end else begin if not SelfLineConnectInfo.isLineConnection then begin // Restore Connection // восстановить состояние соединения кабеля с точечными компонентами NewCompon := FirstCompon; // если коннектор упал на точечный объект, то кабель мог автоматом соединиться с // компонентами точечного, поэтому нужно их расконнектить до восстановления соединения TargetCatalog := NewCompon.GetFirstParentCatalog; if TargetCatalog <> nil then begin TargetLine := GetFigureByCatalogId(TargetCatalog.SCSID); if TargetLine <> nil then begin DisJoinSide := 0; if TConnectorObject(TOrthoLine(TargetLine).JoinConnector1).JoinedConnectorsList.IndexOf(TConnectorObject(TargetPointFigure)) <> -1 then DisJoinSide := 1 else if TConnectorObject(TOrthoLine(TargetLine).JoinConnector2).JoinedConnectorsList.IndexOf(TConnectorObject(TargetPointFigure)) <> -1 then DisJoinSide := 2; if DisJoinSide <> 0 then begin DisJoinComponList := TList.Create; for i := 0 to NewCompon.Interfaces.Count - 1 do begin if (NewCompon.Interfaces[i].TypeI = itFunctional) and (NewCompon.Interfaces[i].Side = DisJoinSide) then begin for j := 0 to NewCompon.Interfaces[i].ConnectedInterfaces.Count - 1 do begin if (TSCSInterface(NewCompon.Interfaces[i].ConnectedInterfaces[j]).ComponentOwner <> nil) and (DisJoinComponList.IndexOf(TSCSInterface(NewCompon.Interfaces[i].ConnectedInterfaces[j]).ComponentOwner) = -1) then DisJoinComponList.Add(TSCSInterface(NewCompon.Interfaces[i].ConnectedInterfaces[j]).ComponentOwner); end; end; end; for i := 0 to DisJoinComponList.Count - 1 do begin NewCompon.DisJoinFrom(TSCSComponent(DisJoinComponList[i])); end; end; FreeAndNil(DisJoinComponList); end; end; FirstCompon := F_ProjMan.GSCSBase.CurrProject.CurrList.GetComponentFromReferences(SelfLineConnectInfo.ComponId); InterFaceAccordanceList := JoinedLineConnectInfo.ConnectedComponList; if ((InterFaceAccordanceList <> nil) and (InterFaceAccordanceList.Count > 0)) then begin i := 0; While (i <= (InterFaceAccordanceList.Count - 1)) do begin SavedLineComponList := TList(InterFaceAccordanceList[i]); SavedPointComponList := TList(InterFaceAccordanceList[i + 1]); for j := 0 to SavedLineComponList.Count - 1 do begin aTempInterf := TSCSInterface(SavedLineComponList[j]); ALineInterFace := GetInterfaceForConnection(aTempInterf, FirstCompon, NewCompon, TConnectorObject(TargetPointFigure)); if ALineInterFace <> nil then begin LineCompon := ALineInterFace.ComponentOwner; for k := 0 to SavedPointComponList.Count - 1 do begin APointInterFace := TSCSInterface(SavedPointComponList[k]); PointCompon := APointInterFace.ComponentOwner; AInterfPositions1 := ALineInterFace.GetEmptyPositions; AInterfPositions2 := APointInterFace.GetEmptyPositions; // уравнять количество позиций для соединения if AInterfPositions1.Positions.Count > AInterfPositions2.Positions.Count then begin While AInterfPositions1.Positions.Count <> AInterfPositions2.Positions.Count do begin l := AInterfPositions1.Positions.Count - 1; AInterfPositions1.Positions.Delete(l); end; AInterfPositions1.DefineKolvo; end else if AInterfPositions2.Positions.Count > AInterfPositions1.Positions.Count then begin While AInterfPositions2.Positions.Count <> AInterfPositions1.Positions.Count do begin l := AInterfPositions2.Positions.Count - 1; AInterfPositions2.Positions.Delete(l); end; AInterfPositions2.DefineKolvo; end; ConnectIDCompRel := DefineIDComponRel(LineCompon, PointCompon); // До того как соединить интерфейсы, нужно соединить сами компоненты if LineCompon.JoinedComponents.IndexOf(PointCompon) = -1 then begin TempInterfaces1 := TSCSInterfaces.Create(false); TempInterfaces2 := TSCSInterfaces.Create(false); if TF_Main(LineCompon.ActiveForm).F_ChoiceConnectSide.JoinWithDefineSides(LineCompon, PointCompon, false, TempInterfaces1, TempInterfaces2, true).CanConnect then; FreeAndNil(TempInterfaces1); FreeAndNil(TempInterfaces2); end; if LineCompon.JoinedComponents.IndexOf(PointCompon) <> -1 then begin ptrConnection := LineCompon.GetConnectionByConnected(PointCompon); if ptrConnection <> nil then begin TempInterfaces1 := TSCSInterfaces.Create(false); TempInterfaces2 := TSCSInterfaces.Create(false); TempInterfaces1.Add(ALineInterFace); TempInterfaces2.Add(APointInterFace); InterfCount := AInterfPositions1.Kolvo; if InterfCount > AInterfPositions2.Kolvo then InterfCount := AInterfPositions2.Kolvo; TF_Main(LineCompon.ActiveForm).ConnectInterfacesWithAccordance(ALineInterFace, APointInterFace, InterfCount, InterfCount, ptrConnection.ID, cntUnion, AInterfPositions1, AInterfPositions2, true, TempInterfaces1, TempInterfaces2); TF_Main(LineCompon.ActiveForm).F_ChoiceConnectSide.OnAfterJoinCompons(LineCompon, PointCompon, -1, -1); end; end; end; end; end; SavedLineComponList.Clear; SavedPointComponList.Clear; FreeAndNil(SavedLineComponList); FreeAndNil(SavedPointComponList); Inc(i,2); end; end; if InterFaceAccordanceList <> nil then begin InterFaceAccordanceList.clear; FreeAndNil(InterFaceAccordanceList); end; end; end; end else begin //NewCompon := aCableCompon;// F_ProjMan.GSCSBase.CurrProject.CurrList.GetComponentFromReferences(JoinedLineConnectInfo.ComponId); NewCompon := F_ProjMan.GSCSBase.CurrProject.CurrList.GetComponentFromReferences(JoinedLineConnectInfo.ComponId); if NewCompon <> nil then if FirstCompon.JoinedComponents.IndexOf(NewCompon) = -1 then ConnectCableComponents(FirstCompon, NewCompon); // если на мультиинтерфейсе if SelfLineConnectInfo.ConnectedComponList.Count > 1 then begin for k := 1 to SelfLineConnectInfo.ConnectedComponList.Count - 1 do begin ComponJoinedByMultiInterFace := F_ProjMan.GSCSBase.CurrProject.CurrList.GetComponentFromReferences(TLineComponConnectionInfo(SelfLineConnectInfo.ConnectedComponList[k]).ComponId); if ComponJoinedByMultiInterFace <> nil then begin if NewCompon.JoinedComponents.IndexOf(ComponJoinedByMultiInterFace) = -1 then ConnectCableComponents(NewCompon, ComponJoinedByMultiInterFace); end; end; end; end; WayList.Clear; FreeAndNil(WayList); end else begin // если соединение линейное if SelfLineConnectInfo.isLineConnection then begin // NewCompon := aCableCompon;//F_ProjMan.GSCSBase.CurrProject.CurrList.GetComponentFromReferences(JoinedLineConnectInfo.ComponId); NewCompon := F_ProjMan.GSCSBase.CurrProject.CurrList.GetComponentFromReferences(JoinedLineConnectInfo.ComponId); if NewCompon <> nil then if FirstCompon.JoinedComponents.IndexOf(NewCompon) = - 1 then ConnectCableComponents(FirstCompon, NewCompon); // если на мультиинтерфейсе if SelfLineConnectInfo.ConnectedComponList.Count > 1 then begin for k := 1 to SelfLineConnectInfo.ConnectedComponList.Count - 1 do begin ComponJoinedByMultiInterFace := F_ProjMan.GSCSBase.CurrProject.CurrList.GetComponentFromReferences(TLineComponConnectionInfo(SelfLineConnectInfo.ConnectedComponList[k]).ComponId); if ComponJoinedByMultiInterFace <> nil then begin if NewCompon.JoinedComponents.IndexOf(ComponJoinedByMultiInterFace) = -1 then ConnectCableComponents(NewCompon, ComponJoinedByMultiInterFace); end; end; end; end // если кабель был присобачен к компонентам точечного объекта - соединить как было else begin end; // end; end else begin if not SelfLineConnectInfo.isLineConnection then begin TargetPointFigure := TConnectorObject(GetFigureByCatalogId(JoinedLineConnectInfo.ComponId)); if TargetPointFigure <> nil then begin // если чистый коннектор и на нем объект -- получить его if (TConnectorObject(TargetPointFigure).ConnectorType = ct_clear) and (TConnectorObject(TargetPointFigure).JoinedConnectorsList.Count > 0) then TargetPointFigure := TFigure(TConnectorObject(TargetPointFigure).JoinedConnectorsList[0]); WayList := GetAllTraceInCAD(TFigure(SelfConnector), TFigure(TargetPointFigure)); if WayList <> nil then begin // прокладка кабеля (только на райз или на вертикали) for j := 0 to WayList.Count - 1 do begin TargetLine := TFigure(WayList[j]); if CheckFigureByClassName(TargetLine, CTOrthoLine) then begin if ((TOrthoLine(TargetLine).FIsVertical) or (TOrthoLine(TargetLine).FIsRaiseUpDown)) then begin TargetCatalog := F_ProjMan.GSCSBase.CurrProject.CurrList.GetCatalogFromReferencesBySCSID(TargetLine.ID); if TargetCatalog <> nil then begin NewCompon := Nil; // вкинуть кабель на трассу NewCompon := CopyComponentToPMSCSObject(ACableCompon, TargetCatalog, False); // рассоединить добавленный кабель от всего, к чему подключился автоматом if NewCompon <> nil then NewCompon.DisJoinFromAll(false).Free; end; end; end; end; // выполнить кабельное соединение по пути следования for j := 0 to WayList.count - 1 do begin TargetLine := TFigure(WayList[j]); if CheckFigureByClassName(TargetLine, cTOrthoLine) then begin if TOrthoLine(TargetLine).FIsVertical or TOrthoLine(TargetLine).FIsRaiseUpDown then begin TargetCatalog := F_ProjMan.GSCSBase.CurrProject.CurrList.GetCatalogFromReferencesBySCSID(TargetLine.ID); if TargetCatalog <> nil then begin NewCompon := TargetCatalog.LastAddedComponent; if NewCompon <> nil then begin if FirstCompon.JoinedComponents.IndexOf(NewCompon) = -1 then ConnectCableComponents(FirstCompon, NewCompon); // если на мультиинтерфейсе if ((j = 0) and (SelfLineConnectInfo.ConnectedComponList.Count > 1)) then begin for k := 1 to SelfLineConnectInfo.ConnectedComponList.Count - 1 do begin ComponJoinedByMultiInterFace := F_ProjMan.GSCSBase.CurrProject.CurrList.GetComponentFromReferences(TLineComponConnectionInfo(SelfLineConnectInfo.ConnectedComponList[k]).ComponId); if ComponJoinedByMultiInterFace <> nil then begin if NewCompon.JoinedComponents.IndexOf(ComponJoinedByMultiInterFace) = -1 then ConnectCableComponents(NewCompon, ComponJoinedByMultiInterFace); end; end; end; FirstCompon := NewCompon; NewCompon := Nil; end; end; end; end; end; end; // Restore Connection // восстановить состояние соединения кабеля с точечными компонентами NewCompon := FirstCompon; FirstCompon := F_ProjMan.GSCSBase.CurrProject.CurrList.GetComponentFromReferences(SelfLineConnectInfo.ComponId); InterFaceAccordanceList := JoinedLineConnectInfo.ConnectedComponList; if ((InterFaceAccordanceList <> nil) and (InterFaceAccordanceList.Count > 0)) then begin i := 0; While (i <= (InterFaceAccordanceList.Count - 1)) do begin SavedLineComponList := TList(InterFaceAccordanceList[i]); SavedPointComponList := TList(InterFaceAccordanceList[i + 1]); for j := 0 to SavedLineComponList.Count - 1 do begin aTempInterf := TSCSInterface(SavedLineComponList[j]); ALineInterFace := GetInterfaceForConnection(aTempInterf, FirstCompon, NewCompon, TConnectorObject(TargetPointFigure)); LineCompon := ALineInterFace.ComponentOwner; if ALineInterFace <> nil then begin for k := 0 to SavedPointComponList.Count - 1 do begin APointInterFace := TSCSInterface(SavedPointComponList[k]); PointCompon := APointInterFace.ComponentOwner; AInterfPositions1 := ALineInterFace.GetEmptyPositions; AInterfPositions2 := APointInterFace.GetEmptyPositions; // уравнять количество позиций для соединения if AInterfPositions1.Positions.Count > AInterfPositions2.Positions.Count then begin While AInterfPositions1.Positions.Count <> AInterfPositions2.Positions.Count do begin l := AInterfPositions1.Positions.Count - 1; AInterfPositions1.Positions.Delete(l); end; AInterfPositions1.DefineKolvo; end else if AInterfPositions2.Positions.Count > AInterfPositions1.Positions.Count then begin While AInterfPositions2.Positions.Count <> AInterfPositions1.Positions.Count do begin l := AInterfPositions2.Positions.Count - 1; AInterfPositions2.Positions.Delete(l); end; AInterfPositions2.DefineKolvo; end; ConnectIDCompRel := DefineIDComponRel(LineCompon, PointCompon); // До того как соединить интерфейсы, нужно соединить сами компоненты if LineCompon.JoinedComponents.IndexOf(PointCompon) = -1 then begin TempInterfaces1 := TSCSInterfaces.Create(false); TempInterfaces2 := TSCSInterfaces.Create(false); if TF_Main(LineCompon.ActiveForm).F_ChoiceConnectSide.JoinWithDefineSides(LineCompon, PointCompon, false, TempInterfaces1, TempInterfaces2, true).CanConnect then; FreeAndNil(TempInterfaces1); FreeAndNil(TempInterfaces2); end; if LineCompon.JoinedComponents.IndexOf(PointCompon) <> -1 then begin ptrConnection := LineCompon.GetConnectionByConnected(PointCompon); if ptrConnection <> nil then begin TempInterfaces1 := TSCSInterfaces.Create(false); TempInterfaces2 := TSCSInterfaces.Create(false); TempInterfaces1.Add(ALineInterFace); TempInterfaces2.Add(APointInterFace); InterfCount := AInterfPositions1.Kolvo; if InterfCount > AInterfPositions2.Kolvo then InterfCount := AInterfPositions2.Kolvo; TF_Main(LineCompon.ActiveForm).ConnectInterfacesWithAccordance(ALineInterFace, APointInterFace, InterfCount, InterfCount, ptrConnection.ID, cntUnion, AInterfPositions1, AInterfPositions2, true, TempInterfaces1, TempInterfaces2); TF_Main(LineCompon.ActiveForm).F_ChoiceConnectSide.OnAfterJoinCompons(LineCompon, PointCompon, -1, -1); end; end; end; end; end; SavedLineComponList.Clear; SavedPointComponList.Clear; FreeAndNil(SavedLineComponList); FreeAndNil(SavedPointComponList); Inc(i,2); end; end; if InterFaceAccordanceList <> nil then begin InterFaceAccordanceList.clear; FreeAndNil(InterFaceAccordanceList); end; end; end; end; end; end; end; SavedLineConnectionsList.Remove(SelfLineConnectInfo); FreeAndNil(SelfLineConnectInfo); end; end; end; // // отсоединить компоненты трассы на втором коннекторе от всего, что там есть Procedure DisJoinOnSide2(aLine: TOrthoLine); var i, j, k: Integer; LineCatalog, JoinedCatalog: TSCSCatalog; FigList, JoinedCatalogList, JoinedComponList: TList; JoinedLine: TOrthoLine; TraceCompon, JoinedCompon: TSCSComponent; NB_Connector, JoinedConnector: TConnectorObject; begin LineCatalog := F_ProjMan.GSCSBase.CurrProject.CurrList.GetCatalogFromReferencesBySCSID(aLine.Id); if LineCatalog = nil then exit; //JoinedComponList := TList.Create; JoinedCatalogList := TList.Create; //определить подключения на второй стороне if Assigned(aLine.JoinConnector2) then begin for i := 0 to TConnectorObject(aLine.JoinConnector2).JoinedOrthoLinesList.Count - 1 do begin JoinedLine := TOrthoLine(TConnectorObject(aLine.JoinConnector2).JoinedOrthoLinesList[i]); if JoinedLine <> nil then if not JoinedLine.deleted then JoinedCatalog := F_ProjMan.GSCSBase.CurrProject.CurrList.GetCatalogFromReferencesBySCSID(JoinedLine.ID); if JoinedCatalog <> nil then if JoinedCatalogList.IndexOf(JoinedCatalog) = -1 then JoinedCatalogList.Add(JoinedCatalog); end; if TConnectorObject(aLine.JoinConnector2).JoinedConnectorsList.Count > 0 then begin NB_Connector := TConnectorObject(TConnectorObject(aLine.JoinConnector2).JoinedConnectorsList[0]); if Nb_Connector <> nil then if not NB_Connector.Deleted then begin // Point Compons JoinedCatalog := F_ProjMan.GSCSBase.CurrProject.CurrList.GetCatalogFromReferencesBySCSID(NB_Connector.ID); if JoinedCatalog <> nil then begin if JoinedCatalogList.IndexOf(JoinedCatalog) = -1 then JoinedCatalogList.Add(JoinedCatalog); end; // LineCompons for i := 0 to NB_Connector.JoinedConnectorsList.Count - 1 do begin JoinedConnector := TconnectorObject(NB_Connector.JoinedConnectorsList[i]); if JoinedConnector.ID <> aLine.JoinConnector2.ID then begin for j := 0 to JoinedConnector.JoinedOrtholinesList.Count - 1 do begin JoinedLine := TOrthoLine(TConnectorObject(aLine.JoinConnector2).JoinedOrthoLinesList[j]); if JoinedLine <> nil then if not JoinedLine.deleted then JoinedCatalog := F_ProjMan.GSCSBase.CurrProject.CurrList.GetCatalogFromReferencesBySCSID(JoinedLine.ID); if JoinedCatalog <> nil then if JoinedCatalogList.IndexOf(JoinedCatalog) = -1 then JoinedCatalogList.Add(JoinedCatalog); end; end; end end; end; end; for i := 0 to LineCatalog.ComponentReferences.Count - 1 do begin TraceCompon := TSCSComponent(LineCatalog.ComponentReferences[i]); for j := 0 to JoinedCatalogList.Count - 1 do begin JoinedCatalog := TSCSCatalog(JoinedCatalogList[j]); for k := 0 to JoinedCatalog.ComponentReferences.Count - 1 do begin JoinedCompon := TSCSComponent(JoinedCatalog.ComponentReferences[k]); if TraceCompon.JoinedComponents.IndexOf(JoinedCompon) <> -1 then TraceCompon.DisJoinFrom(JoinedCompon); end; end; end; JoinedCatalogList.Free; // Tolik 14/05/2018 -- end; Procedure ReconnConnectors; var i: Integer; Nb_Conn: TConnectorObject; JoinedLine: TOrthoLine; NewJConn, OldJConn, RaiseConn: TConnectorObject; begin NewJConn := TConnectorObject(AddLine.JoinConnector2); OldJConn := TConnectorObject(ASnapLine.JoinConnector2); NewJConn.FConnRaiseType := OldJConn.FConnRaiseType; NewJConn.FObjectFromRaise := OldJConn.FObjectFromRaise; OldJConn.FConnRaiseType := crt_None; OldJConn.FObjectFromRaise := nil; if TConnectorObject(aSnapLine.JoinConnector2).JoinedConnectorsList.Count > 0 then begin Nb_Conn := TConnectorObject(TConnectorObject(aSnapLine.JoinConnector2).JoinedConnectorsList[0]); if not NB_Conn.Deleted then begin TConnectorObject(aSnapLine.JoinConnector2).JoinedConnectorsList.Remove(NB_Conn); NB_Conn.JoinedConnectorsList.Remove(TConnectorObject(aSnapLine.JoinConnector2)); Nb_Conn.JoinedConnectorsList.Add(TConnectorObject(AddLine.JoinConnector2)); TConnectorObject(AddLine.JoinConnector2).JoinedConnectorsList.Insert(0, NB_Conn); end; end; for i := (TConnectorObject(ASnapLine.JoinConnector2).JoinedOrtholinesList.Count - 1) downto 0 do begin JoinedLine := TOrthoLine(TConnectorObject(aSnapLine.JoinConnector2).JoinedOrtholinesList[i]); if JoinedLine.ID <> aSnapLine.ID then begin if not JoinedLine.Deleted then begin TConnectorObject(ASnapLine.JoinConnector2).JoinedOrtholinesList.Remove(JoinedLine); if JoinedLine.JoinConnector1.ID = ASnapLine.JoinConnector2.ID then JoinedLine.SetJConnector1(AddLine.JoinConnector2, True) else if JoinedLine.JoinConnector2.ID = ASnapLine.JoinConnector2.ID then JoinedLine.SetJConnector2(AddLine.JoinConnector2, True); if JoinedLine.FIsRaiseUpDown then begin if JoinedLine.FObjectFromRaisedLine = OldJConn then JoinedLine.FObjectFromRaisedLine := NewJConn; if JoinedLine.JoinConnector1.ID = NewJConn.ID then RaiseConn := TConnectorObject(JoinedLine.JoinConnector2) else RaiseConn := TConnectorObject(JoinedLine.JoinConnector1); if RaiseConn.FObjectFromRaise <> nil then if RaiseConn.FObjectFromRaise.ID = OldJConn.ID then RaiseConn.FObjectFromRaise := NewJConn; end; end; end; end; end; // Tolik 31/03/2021 -- function GetResultSnapLine(aIndex: integer; aLine: TOrthoLine): TOrthoLine; begin Result := nil; if CompareValue(ALine.Ap1.y, aLine.Ap2.y) = 0 then // вдоль Х begin if (CompareValue(aLine.Ap1.x, TOrthoLine(GCadForm.PCad.TraceFigure).ActualPoints[aIndex].x) = -1) and (CompareValue(aLine.Ap2.x, TOrthoLine(GCadForm.PCad.TraceFigure).ActualPoints[aIndex].x) = 1) then Result := aLine; end else if CompareValue(ALine.Ap1.x, aLine.Ap2.x) = 0 then // вдоль У begin if (CompareValue(aLine.Ap1.y, TOrthoLine(GCadForm.PCad.TraceFigure).ActualPoints[aIndex].y) = -1) and (CompareValue(aLine.Ap2.y, TOrthoLine(GCadForm.PCad.TraceFigure).ActualPoints[aIndex].y) = 1) then Result := aLine; end else // косая begin if (CompareValue(aLine.Ap1.x, TOrthoLine(GCadForm.PCad.TraceFigure).ActualPoints[aIndex].x) = -1) and (CompareValue(aLine.Ap2.x, TOrthoLine(GCadForm.PCad.TraceFigure).ActualPoints[aIndex].x) = 1) and (CompareValue(aLine.Ap1.y, TOrthoLine(GCadForm.PCad.TraceFigure).ActualPoints[aIndex].y) = -1) and (CompareValue(aLine.Ap2.y, TOrthoLine(GCadForm.PCad.TraceFigure).ActualPoints[aIndex].y) = 1) then Result := aLine; end; end; // begin // на всякий if AConnector = nil then exit else if AConnector.Deleted then exit else if AConnector.ConnectorType = ct_Nb then exit; ObjToDisconnect := nil; CadRefreshFlag := GCanRefreshCad; GCanRefreshCad := False; NoCopyComponentList := nil; // Tolik 26/09/2018 -- AddedLineCatalog := nil; // Tolik 26/09/2018 -- //Tolik 31/08/2021 -- SnapIdx := -1; if Assigned(GSnapFiguresList) then SnapIdx := GSnapFiguresList.IndexOf(ASnapLine.JoinConnector2); // try GtempListCreated := False; // Tolik 09/07/2019 -- //if (IsSpecialTraceFigure(ASnapLine)) or (ASnapLine.FIsVertical) then if ((ASnapLine.FisRaiseUpDown) or (ASnapLine.FIsVertical)) then begin GCanRefreshCad := CadRefreshFlag; exit; end; GetOtherConn := nil; //#From Oleg# // Tolik 34/03/2021 -- if GCadForm.PCad.TraceFigure <> nil then begin if GCadForm.pCad.TraceFigure is TOrthoLine then begin SnapLineCount := 0; LineClickIndex := -1; for i := 0 to GSnapFiguresList.Count - 1 do begin if GSnapFiguresList[i] <> nil then begin if TFigure(GSnapFiguresList[i]).Id = aSnapLine.Id then begin Inc(SnapLineCount); if LineClickIndex = -1 then LineClickIndex := i; end; end; end; end; end; //Tolik 08/08/2021 -- NewPt.x := AConnector.Ap1.x; NewPt.y := AConnector.Ap1.y; NewPt.z := AConnector.Ap1.z; PointToLineByAngle(ASnapLine.Ap1,ASnapLine.Ap2, NewPt); AConnector.ActualPoints[1] := NewPt; if CompareValue(ASnapLine.ActualZOrder[1], ASnapLine.ActualZOrder[2]) <> 0 then AConnector.ActualZOrder[1] := GetCoordZ(ASnapLine, AConnector.Ap1.X, AConnector.Ap1.Y); NewPt.z := AConnector.Ap1.z; {CreatedConn := DivideLineSimple(ASnapLine, @NewPt); AConnector := SnapConnectorToConnector(AConnector, CreatedConn); exit;} // SavedLineConnectionsList := TList.Create; SavedComponList := TList.Create; // получить лист с присоединенными объектами стороны 2 JoinedConn := TConnectorObject(ASnapLine.JoinConnector2); ObjToDisconnect := TList.Create; if JoinedConn.JoinedConnectorsList.Count > 0 then ObjToDisconnect.Add(JoinedConn.JoinedConnectorsList[0]) else begin for i := 0 to JoinedConn.JoinedOrtholinesList.Count - 1 do if TOrthoLine(JoinedConn.JoinedOrtholinesList[i]) <> ASnapLine then ObjToDisconnect.Add(JoinedConn.JoinedOrtholinesList[i]); end; //Tolik 08/08/2021 -- if isPointinLine(ASnapLine.ActualPoints[1], ASnapLine.ActualPoints[2], AConnector.Ap1, 0, 0.1) then begin end; // Tolik -- попытаться сохранить состояние соединения до ... // если был точечный -- сохраняем на точечном begin DivLineObject := F_ProjMan.GSCSBase.CurrProject.CurrList.GetCatalogFromReferencesBySCSID(ASnapLine.Id); if DivLineObject <> nil then begin for i := 0 to DivLineObject.ComponentReferences.Count - 1 do begin LineCompon := TSCSComponent(DivLineObject.ComponentReferences[i]); if IsCableComponent(LineCompon) then CheckSaveLineConnectionsBySide(ASnapLine, LineCompon, 2); end; end; end; DisJoinOnSide2(aSnapLine); // отсоединить кабели разделяемой трассы на второй стороне DeltaHeight := ASnapLine.ActualZOrder[2] - ASnapLine.ActualZOrder[1]; AllLengthXY := SQRT(SQR(ASnapLine.ActualPoints[1].x - ASnapLine.ActualPoints[2].x) + SQR(ASnapLine.ActualPoints[1].y - ASnapLine.ActualPoints[2].y)); // выравнивать линию? AngleRad := GetLineAngle(ASnapLine.ActualPoints[1], ASnapLine.ActualPoints[2]); if GCadForm.PCad.SnapToGrids then begin if (AngleRad = 0) or (AngleRad = 90) or (AngleRad = 180) or (AngleRad = 270) or (AngleRad = 360) then MustRealign := true else MustRealign := false; end else MustRealign := false; NextConnector := ASnapLine.JoinConnector2; if ASnapLine.ActualPoints[1].x = ASnapLine.ActualPoints[2].x then begin NewDeltaY := 0; NewDeltaX := ASnapLine.ActualPoints[1].x - AConnector.ActualPoints[1].x; AConnector.ActualPoints[1] := DoublePoint(AConnector.ActualPoints[1].x + NewDeltaX, AConnector.ActualPoints[1].y); end else if ASnapLine.ActualPoints[1].y = ASnapLine.ActualPoints[2].y then begin NewDeltaX := 0; NewDeltaY := ASnapLine.ActualPoints[1].y - AConnector.ActualPoints[1].y; AConnector.ActualPoints[1] := DoublePoint(AConnector.ActualPoints[1].x, AConnector.ActualPoints[1].y + NewDeltaY); end else begin NewDeltaX := 0; NewDeltaY := 0; AConnector.ActualPoints[1] := DoublePoint(AConnector.ActualPoints[1].x + NewDeltaX, AConnector.ActualPoints[1].y + NewDeltaY); end; // вычисление точек модификации Modx := AConnector.ActualPoints[1].x; Mody := AConnector.ActualPoints[1].y; //Tolik -- 27/02/2018 -- if CompareValue(TConnectorObject(ASnapLine.JoinConnector1).ActualzOrder[1], TConnectorObject(ASnapLine.JoinConnector2).ActualZOrder[1]) = 0 then SnapZ := TConnectorObject(ASnapLine.JoinConnector1).ActualzOrder[1] else // если линая наклонная - вычислить высоту разделения линии SnapZ := GetCoordZ(ASnapLine, AConnector.ap1.x, AConnector.ap1.y); AddLine := TOrthoLine.Create(Modx, Mody, Snapz, ASnapLine.JoinConnector2.ap1.x, ASnapLine.JoinConnector2.ap1.y, TConnectorObject(ASnapLine.JoinConnector2).ActualZOrder[1], 1,ord(psSolid), clBlack, 0, ASnapLine.LayerHandle, mydsNormal, GCadForm.PCad); // Tolik 20/03/2020 -- если идет разделение линии, то, если в настройках Када выставлено не соблюдать // правила для типов линий, надо содрать свойства с той линии, которую делим...а то некирасиво.... if not GCadForm.FKeepLineTypesRules then begin AddLine.FTraceColor := ASnapLine.FTraceColor; AddLine.FTraceStyle := ASnapLine.FTraceStyle; AddLine.FTraceWidth := ASnapLine.FTraceWidth; end; // GCadForm.PCad.AddCustomFigure (GLN(ASnapLine.LayerHandle), AddLine, false); ClearCon2 := TConnectorObject.Create(ASnapLine.JoinConnector2.ap1.x, ASnapLine.JoinConnector2.ap1.y, TConnectorObject(ASnapLine.JoinConnector2).ActualZOrder[1], ASnapLine.LayerHandle, mydsNormal, GCadForm.PCad); ClearCon2.ConnectorType := ct_Clear; GCadForm.PCad.AddCustomFigure (GLN(ASnapLine.LayerHandle), ClearCon2, False); ClearCon2.Name := cCadClasses_Mes12; SetNewObjectNameInPM(ClearCon2.ID, ClearCon2.Name); ObjParams := GetFigureParams(ClearCon2.ID); ClearCon2.Name := ObjParams.Name; ClearCon2.FIndex := ObjParams.MarkID; AddLine.SetJConnector2(TFigure(ClearCon2)); if SnapIdx <> -1 then begin GSnapFiguresList.Delete(SnapIdx); if GSnapFiguresList.Count < SnapIdx then GSnapFiguresList.Add(ClearCon2) else GSnapFiguresList.Insert(SnapIdx, ClearCon2); end; ReconnConnectors; //оторвать второй коннектор разделяемой трассы от всего, к чему присоединен и переключить соединения на коннектор созданной трассы // При соединении конектора с линией, создается 2 линии // переназначение связей линии к которой присоединились новому коннектору ASnapLine.ActualPoints[2] := DoublePoint(Modx, Mody); ASnapLine.ActualZOrder[2] := SnapZ; TConnectorObject(ASnapLine.JoinConnector2).ActualPoints[1] := DoublePoint(Modx, Mody); TConnectorObject(ASnapLine.JoinConnector2).ActualZOrder[1] := SnapZ; //SnapConnectorToConnector(TConnectorObject(AddLine.JoinConnector1), TConnectorObject(ASnapLine.JoinConnector2)); //ConnectCableCompons(ASnapLine, AddLine); AddLine.SetJConnector1(ASnapLine.JoinConnector2); // пересчитать длину первой трассы, которая "ужимается" ASnapLine.CalculLength := ASnapLine.LengthCalc; ASnapLine.LineLength := ASnapLine.CalculLength; ASnapLine.ReCreateCaptionsGroup(true, false, nil, -1,-1); if Not ASnapLine.FNotRecalcLength then SetLineFigureLengthInPM(ASnapLine.ID, ASnapLine.LineLength); // если не на одной высоте - создать и приконнектить райз //Tolik 06/08/2021 -- оставить просто снап, все остальное сделается там... {if CompareValue(SnapZ, AConnector.ActualZOrder[1]) = 0 then AConnector := SnapConnectorToConnector(AConnector, TConnectorObject(AddLine.JoinConnector1)) else begin CreateRaiseOnConnector(AConnector, SnapZ); RaiseLine := nil; for j := 0 to AConnector.JoinedOrtholinesList.Count - 1 do begin if TOrthoLine(AConnector.JoinedOrtholinesList[j]).FIsRaiseUpDown then begin RaiseLine := TOrthoLine(AConnector.JoinedOrtholinesList[j]); break; end; end; if RaiseLine <> nil then begin RaiseConn := Nil; if CompareValue(SnapZ, TConnectorObject(RaiseLine.JoinConnector1).ActualZOrder[1]) = 0 then RaiseConn := tconnectorObject(RaiseLine.JoinConnector1) else if CompareValue(SnapZ, TConnectorObject(RaiseLine.JoinConnector2).ActualZOrder[1]) = 0 then RaiseConn := tconnectorObject(RaiseLine.JoinConnector2); if RaiseConn <> nil then RaiseConn := SnapConnectorToConnector(RaiseConn, TConnectorObject(ASnapLine.JoinConnector2)); end; end; } //AConnector := SnapConnectorToConnector(AConnector, TConnectorObject(AddLine.JoinConnector1)); AConnector := CheckingSnapConnectorToConnector(AConnector, TConnectorObject(AddLine.JoinConnector1)); // // отсоединить разделяемую трассу на втором конце (компоненты) DisJoinOnSide2(ASnapLine); //попытаться восстановить состояние соединений на втором конце (как было до... ) DivLineObject := F_ProjMan.GSCSBase.CurrProject.CurrList.GetCatalogFromReferencesBySCSID(ASnapLine.ID); if DivLineObject <> nil then begin for i := 0 to DivLineObject.ComponentReferences.Count - 1 do begin LineCompon := TSCSComponent(DivLineObject.ComponentReferences[i]); if IsCableComponent(LineCompon) then RestoreLineConnectionsBySide(ASnapLine, LineCompon, 2); end; end; FreeAndNil(SavedLineConnectionsList); FreeAndNil(SavedComponList); // Протокол GCadForm.mProtocol.Lines.Add(cEndPoints_Mes1 + AConnector.Name + cCommon_Mes1 + ASnapLine.Name + '"'); // Tolik 15/07/2019 //except // on E: Exception do addExceptionToLogEx('U_Common.SnapPointObjectToOrtholine', E.Message); //end; AddedLineCatalog := F_ProjMan.GSCSBase.CurrProject.CurrList.GetCatalogFromReferencesBySCSID(AddLine.ID); // Tolik 26/09/2018 -- OldLineCatalog := F_ProjMan.GSCSBase.CurrProject.CurrList.GetCatalogFromReferencesBySCSID(ASnapLine.ID); // Tolik 26/09/2018 -- if AddedLineCatalog <> nil then if OldLineCatalog <> nil then if AddedLineCatalog.ComponentReferences.Count > 0 then begin NoCopyComponentList := TList.Create; for i := 0 to AddedLineCatalog.ComponentReferences.Count - 1 do begin NewCompon := AddedLineCatalog.ComponentReferences[i]; for j := 0 to NewCompon.JoinedComponents.Count - 1 do begin if OldLineCatalog.ComponentReferences.IndexOf(NewCompon.JoinedComponents[j]) <> -1 then if NoCopyComponentList.IndexOf(NewCompon.JoinedComponents[j]) = -1 then NoCopyComponentList.Add(NewCompon.JoinedComponents[j]); end; end; end; if AddLine.JoinConnector1 = AConnector then begin GetOtherConn := TConnectorObject(AddLine.JoinConnector2); if GetOtherConn.JoinedConnectorsList.Count > 0 then GetOtherConn := TConnectorObject(GetOtherConn.JoinedConnectorsList[0]); end; if AddLine.JoinConnector2 = AConnector then begin GetOtherConn := TConnectorObject(AddLine.JoinConnector1); if GetOtherConn.JoinedConnectorsList.Count > 0 then GetOtherConn := TConnectorObject(GetOtherConn.JoinedConnectorsList[0]); end; AutoConnectOverDivideLine(AConnector, GetOtherConn, ASnapLine, AddLine, NoCopyComponentList); //AutoConnectOverDivideLine(GetOtherConn, AConnector, AddLine); // !!! // Tolik 15/07/2019 except on E: Exception do addExceptionToLogEx('U_Common.SnapPointObjectToOrtholine', E.Message); end; // if NoCopyComponentList <> nil then NoCopyComponentList.free; GCanRefreshCad := CadRefreshFlag; if not AConnector.Deleted then begin if AConnector.JoinedConnectorsList.Count > 0 then begin //Tolik 03/08/2021 -- //TConnectorObject(AConnector.JoinedConnectorsList[0]).MoveP(0.1, 0.1, False); //TConnectorObject(AConnector.JoinedConnectorsList[0]).MoveP(-0.1, -0.1, False); TConnectorObject(AConnector.JoinedConnectorsList[0]).MoveP(0.1, 0.1, False, False); TConnectorObject(AConnector.JoinedConnectorsList[0]).MoveP(-0.1, -0.1, False, False); // end else begin //Tolik 03/08/2021 - - //AConnector.MoveP(0.1, 0.1, False); //AConnector.MoveP(-0.1, -0.1, False); AConnector.MoveP(0.1, 0.1, False, False); AConnector.MoveP(-0.1, -0.1, False, False); // end end; // if ObjToDisconnect <> nil then // Tolik 22/01/2021 -- FreeAndNil(ObjToDisconnect); //Tolik 31/03/2021 -- if SnapLineCount > 1 then begin for i := LineClickIndex to GSnapFiguresList.Count - 1 do begin if GSnapFiguresList[i] <> nil then begin if TFigure(GSnapFiguresList[i]) is TOrthoLine then begin if TOrthoLine(GSnapFiguresList[i]).Id = ASnapLine.ID then begin LineForNextSnap := GetResultSnapLine(i + 1, ASnapLine); if LineForNextSnap = nil then LineForNextSnap := GetResultSnapLine(i + 1, AddLine); if LineForNextSnap = nil then LineForNextSnap := ASnapLine; GSnapFiguresList[i] := LineForNextSnap; end; end; end; end; end; //Tolik 09/08/2021 -- ASnapLine.ReCreateDrawFigureBlock; // GCadForm.PCad.Refresh; end; (* // ПРИВЯЗКА КОНЕКТОРА К ОРТОЛИНИИ procedure SnapConnectorToOrtholine(AConnector: TConnectorObject; ASnapLine: TOrtholine); var i, j: integer; NewDeltaX, NewDeltaY: double; AddLine: TOrthoLine; NextConnector: TConnectorObject; Modx, Mody, Modz, NextModx, NextMody, NextModz: Double; TempFigure: TFigure; TempDefaultNum: integer; CurrentLine: TOrthoLine; SplitFigure: TOrthoLine; CP_Line: TDoublePoint; AngleRad: Double; SnapLine: TOrthoLine; // Koef: Double; DeltaHeight: Double; AllLengthXY: Double; CurrLengthXY: Double; MustRealign: Boolean; JoinedConn: TConnectorObject; SplitFiguresList: TList; ObjToDisconnect: TList; GetOtherConn: TConnectorObject; // Tolik InterfPos : TSCSInterfPosition; Interf: TSCSInterface; InterfConn: TSCSInterfPosConnection; // begin try GetOtherConn := nil; //#From Oleg# // получить лист с присоединенными объектами стороны 2 JoinedConn := TConnectorObject(ASnapLine.JoinConnector2); ObjToDisconnect := TList.Create; if JoinedConn.JoinedConnectorsList.Count > 0 then ObjToDisconnect.Add(JoinedConn.JoinedConnectorsList[0]) else begin for i := 0 to JoinedConn.JoinedOrtholinesList.Count - 1 do if TOrthoLine(JoinedConn.JoinedOrtholinesList[i]) <> ASnapLine then ObjToDisconnect.Add(JoinedConn.JoinedOrtholinesList[i]); end; {--------------------------------------------------------------} DeltaHeight := ASnapLine.ActualZOrder[2] - ASnapLine.ActualZOrder[1]; AllLengthXY := SQRT(SQR(ASnapLine.ActualPoints[1].x - ASnapLine.ActualPoints[2].x) + SQR(ASnapLine.ActualPoints[1].y - ASnapLine.ActualPoints[2].y)); AngleRad := GetLineAngle(ASnapLine.ActualPoints[1], ASnapLine.ActualPoints[2]); if GCadForm.PCad.SnapToGrids then begin if (AngleRad = 0) or (AngleRad = 90) or (AngleRad = 180) or (AngleRad = 270) or (AngleRad = 360) then MustRealign := true else MustRealign := false; end else MustRealign := false; SplitFiguresList := TList.Create; NextConnector := TConnectorObject(ASnapLine.JoinConnector2); if ASnapLine.ActualPoints[1].x = ASnapLine.ActualPoints[2].x then begin NewDeltaY := 0; NewDeltaX := ASnapLine.ActualPoints[1].x - AConnector.ActualPoints[1].x; AConnector.ActualPoints[1] := DoublePoint(AConnector.ActualPoints[1].x + NewDeltaX, AConnector.ActualPoints[1].y); end else if ASnapLine.ActualPoints[1].y = ASnapLine.ActualPoints[2].y then begin NewDeltaX := 0; NewDeltaY := ASnapLine.ActualPoints[1].y - AConnector.ActualPoints[1].y; AConnector.ActualPoints[1] := DoublePoint(AConnector.ActualPoints[1].x, AConnector.ActualPoints[1].y + NewDeltaY); end else begin NewDeltaX := 0; NewDeltaY := 0; AConnector.ActualPoints[1] := DoublePoint(AConnector.ActualPoints[1].x + NewDeltaX, AConnector.ActualPoints[1].y + NewDeltaY); end; AConnector.DrawFigure.move(NewDeltaX, NewDeltaY); if AConnector.CaptionsGroup <> nil then AConnector.CaptionsGroup.Move(NewDeltaX, NewDeltaY); for i := 0 to AConnector.JoinedOrtholinesList.Count - 1 do begin if AConnector = TOrthoLine(AConnector.JoinedOrtholinesList[i]).JoinConnector1 then begin TOrthoLine(AConnector.JoinedOrtholinesList[i]).ActualPoints[1] := DoublePoint( TOrthoLine(AConnector.JoinedOrtholinesList[i]).ActualPoints[1].x + NewDeltaX, TOrthoLine(AConnector.JoinedOrtholinesList[i]).ActualPoints[1].y + NewDeltaY); end; if AConnector = TOrthoLine(AConnector.JoinedOrtholinesList[i]).JoinConnector2 then begin TOrthoLine(AConnector.JoinedOrtholinesList[i]).ActualPoints[2] := DoublePoint( TOrthoLine(AConnector.JoinedOrtholinesList[i]).ActualPoints[2].x + NewDeltaX, TOrthoLine(AConnector.JoinedOrtholinesList[i]).ActualPoints[2].y + NewDeltaY); end; end; // вычисление точек модификации Modx := (AConnector.ActualPoints[1].x + AConnector.ActualPoints[2].x) / 2; Mody := (AConnector.ActualPoints[1].y + AConnector.ActualPoints[2].y) / 2; Modz := AConnector.ActualZOrder[1]; NextModx := (NextConnector.ActualPoints[1].x + NextConnector.ActualPoints[2].x) / 2; NextMody := (NextConnector.ActualPoints[1].y + NextConnector.ActualPoints[2].y) / 2; NextModz := NextConnector.ActualZOrder[1]; // При соединении конектора с линией, создается 2 линии // переназначение связей линии к которой присоединились новому коннектору ASnapLine.ActualPoints[2] := DoublePoint(Modx, Mody); ASnapLine.ActualZOrder[1] := Modz; ASnapLine.SetJConnector2(AConnector); TConnectorObject(NextConnector).JoinedOrtholinesList.Remove(ASnapLine); // добавить новую ортолинию TempDefaultNum := GDefaultNum; GDefaultNum := ASnapLine.FCount; GDefaultGap := ASnapLine.FGap; AddLine := TOrthoLine.Create(Modx, Mody, Modz, NextModx, NextMody, NextModz, 1,ord(psSolid), clBlack, 0, ASnapLine.LayerHandle, mydsNormal, GCadForm.PCad); GCadForm.PCad.AddCustomFigure (GLN(ASnapLine.LayerHandle), AddLine, false); GDefaultNum := TempDefaultNum; // присвоить связи новой ортолинии AddLine.SetJConnector1(AConnector); AddLine.SetJConnector2(NextConnector); // при сдвоении линий удалить FigureSnap SplitFigure := Nil; CurrLengthXY := SQRT(SQR(ASnapLine.ActualPoints[1].x - ASnapLine.ActualPoints[2].x) + SQR(ASnapLine.ActualPoints[1].y - ASnapLine.ActualPoints[2].y)); Koef := CurrLengthXY / AllLengthXY; AConnector.ActualZOrder[1] := ASnapLine.ActualZOrder[1] + DeltaHeight; ASnapLine.ActualZOrder[2] := AConnector.ActualZOrder[1]; AddLine.ActualZOrder[1] := AConnector.ActualZOrder[1]; // перерасчет длины новой линии ASnapLine.CalculLength := ASnapLine.LengthCalc; ASnapLine.LineLength := ASnapLine.CalculLength; ASnapLine.UpdateLengthTextBox(false, true); SetLineFigureLengthInPM(ASnapLine.ID, ASnapLine.LineLength); // передвинуть TextBoxesGroup if ASnapLine.CaptionsGroup <> nil then begin CP_Line.x := (ASnapLine.ActualPoints[1].x + ASnapLine.ActualPoints[2].x) / 2; CP_Line.y := (ASnapLine.ActualPoints[1].y + ASnapLine.ActualPoints[2].y) / 2; ASnapLine.CaptionsGroup.Move(CP_Line.x - ASnapLine.CaptionsGroup.CenterPoint.x, CP_Line.y - ASnapLine.CaptionsGroup.CenterPoint.y); end; // перерасчет длины созданной линии AddLine.CalculLength := AddLine.LengthCalc; AddLine.LineLength := AddLine.CalculLength; AddLine.UpdateLengthTextBox(false, false); SetLineFigureLengthInPM(AddLine.ID, AddLine.LineLength); // передвинуть TextBoxesGroup if AddLine.CaptionsGroup <> nil then begin CP_Line.x := (AddLine.ActualPoints[1].x + AddLine.ActualPoints[2].x) / 2; CP_Line.y := (AddLine.ActualPoints[1].y + AddLine.ActualPoints[2].y) / 2; AddLine.CaptionsGroup.Move(CP_Line.x - AddLine.CaptionsGroup.CenterPoint.x, CP_Line.y - AddLine.CaptionsGroup.CenterPoint.y); end; GFigureSnap := Nil; // выровнять линии if MustRealign then begin ReAlignObject(AConnector); ReAlignLine(ASnapLine); ReAlignLine(AddLine); end; SetConnBringToFront(AConnector); if SplitFiguresList <> nil then FreeAndNil(SplitFiguresList); ReCalcZCoordSnapObjects(AConnector); // Протокол GCadForm.mProtocol.Lines.Add(cEndPoints_Mes1 + AConnector.Name + cCommon_Mes1 + ASnapLine.Name + '"'); // продолжить трассу на новый отрезок if AddLine.JoinConnector1 = AConnector then begin GetOtherConn := TConnectorObject(AddLine.JoinConnector2); if GetOtherConn.JoinedConnectorsList.Count > 0 then GetOtherConn := TConnectorObject(GetOtherConn.JoinedConnectorsList[0]); end; if AddLine.JoinConnector2 = AConnector then begin GetOtherConn := TConnectorObject(AddLine.JoinConnector1); if GetOtherConn.JoinedConnectorsList.Count > 0 then GetOtherConn := TConnectorObject(GetOtherConn.JoinedConnectorsList[0]); end; AutoConnectOverDivideLine(AConnector, GetOtherConn, ASnapLine, AddLine); //AutoConnectOverDivideLine(GetOtherConn, AConnector, AddLine); // !!! AddLine.FTraceColor := ASnapLine.FTraceColor; AddLine.FTraceStyle := ASnapLine.FTraceStyle; AddLine.FTraceWidth := ASnapLine.FTraceWidth; AddLine.FLineType := ASnapLine.FLineType; AddLine.FDrawFigurePercent := ASnapLine.FDrawFigurePercent; AddLine.BlockStep := ASnapLine.BlockStep; AddLine.DrawFigureH := 0; AddLine.CaptionsGroupH := 0; ASnapLine.DrawFigureH := 0; ASnapLine.CaptionsGroupH := 0; ASnapLine.ReCreateCaptionsGroup(false, false); ASnapLine.ReCreateNotesGroup; ASnapLine.ReCreateDrawFigureBlock; AddLine.ReCreateCaptionsGroup(false, false); AddLine.ReCreateNotesGroup; AddLine.ReCreateDrawFigureBlock; if ObjToDisconnect <> nil then FreeAndNil(ObjToDisconnect); AddLine.FTraceColor := ASnapLine.FTraceColor; AddLine.FTraceStyle := ASnapLine.FTraceStyle; AddLine.FTraceWidth := ASnapLine.FTraceWidth; AddLine.FLineType := ASnapLine.FLineType; AddLine.FDrawFigurePercent := ASnapLine.FDrawFigurePercent; RefreshCAD(GCadForm.PCad); except on E: Exception do addExceptionToLogEx('U_Common.SnapConnectorToOrtholine', E.Message); end; end; *) // Tolik 17/05/2016 -- // выполнено с учетом восстановления состояния соединения кабелей на втором конце разделяемой вертикали //(поинтерфейсно и пожильно с точечными компонентами) // старая закомменчена - смотри ниже Function DefineIDComponRel(ALineCompon, APointCompon: TSCSComponent): Integer; var TopCatalog: TSCSCatalog; begin Result := -1; begin TopCatalog := aLineCompon.GetTopParentCatalog; if TopCatalog <> nil then if TopCatalog is TSCSProject then Result := TSCSProject(TopCatalog).GenIDByGeneratorIndex(giComponentRelationID, 1); end; //if IDComponRel = -1 then //IDComponRel := TF_Main(ActiveForm).AppendToComponRel(Self.ID, AComponent.ID, 1, AConnectType); end; Function GetInterfaceForConnection(AInterf: TSCSInterFace; ASnapLine, AddLine: TOrthoLine): TSCSInterFace; var i, j, k: Integer; LineCompon: TSCSComponent; SourceLineCatalog, DestLineCatalog: TSCSCatalog; ConnectionSide : Integer; TmpInterfPos: TSCSInterfPosition; begin Result := nil; LineCompon := AInterf.ComponentOwner; if LineCompon <> nil then begin SourceLineCatalog := F_ProjMan.GSCSBase.CurrProject.CurrList.GetCatalogFromReferencesBySCSID(ASnapLine.ID); if SourceLineCatalog <> nil then begin for i := 0 to SourceLineCatalog.ComponentReferences.Count - 1 do begin if (TSCSComponent(SourceLineCatalog.ComponentReferences[i]).ID = LineCompon.ID) then begin DestLineCatalog := F_ProjMan.GSCSBase.CurrProject.CurrList.GetCatalogFromReferencesBySCSID(AddLine.ID); if DestLineCatalog <> nil then begin if i <= (DestLineCatalog.ComponentReferences.Count - 1) then begin LineCompon := DestLineCatalog.ComponentReferences[i]; if LineCompon <> nil then begin // Difining ConnectionSide { for j := 0 to LineCompon.Interfaces.Count - 1 do begin ConnectionSide := 2; if TSCSInterface(LineCompon.Interfaces[j]).TypeI = itFunctional then if TSCSInterface(LineCompon.Interfaces[j]).BusyPositions.Count > 0 then begin for k := 0 to TSCSInterface(LineCompon.Interfaces[j]).BusyPositions.Count - 1 do begin TmpInterfPos := TSCSInterface(LineCompon.Interfaces[j]).BusyPositions[k]; TmpInterfPos := TmpInterfPos.GetConnectedPos; if TSCSComponent(TmpInterfPos.InterfOwner.ComponentOwner).IsLine = biTrue then begin if TmpInterfPos.InterfOwner.Side = 2 then ConnectionSide := 1; break; end; end; end; end;} for j := 0 to LineCompon.Interfaces.Count - 1 do begin if TSCSInterface(LineCompon.Interfaces[j]).TypeI = itFunctional then if TSCSInterface(LineCompon.Interfaces[j]).Npp = AInterf.Npp then // if TSCSInterface(LineCompon.Interfaces[j]).Side = 2 then if ((TSCSInterface(LineCompon.Interfaces[j]).IsBusy = biFalse) or (TSCSInterface(LineCompon.Interfaces[j]).BusyPositions.Count = 0)) then begin Result := TSCSInterface(LineCompon.Interfaces[j]); break; end; end; end; end; end; Break; //// BREAK ////; end; end; end; end; end; procedure SnapConnectorToVertical(AConnector: TConnectorObject; ASnapLine: TOrtholine; aOnObjectHeight: Boolean = False;CanSaveConnections: Boolean = True); var i, j, k, l, m: integer; AddLine: TOrthoLine; NextConnector: TConnectorObject; Modx, Mody, Modz, NextModx, NextMody, NextModz: Double; TempDefaultNum: integer; CP_Line: TDoublePoint; // DeltaPos: Double; JoinedConn: TConnectorObject; ObjToDisconnect: TList; GetOtherConn: TConnectorObject; ObjParams: TObjectParams; // Tolik -- 17/05/2016-- SavedLineComponList, SavedPointComponList: TList; DivLineObject, JoinedPointObject: TSCSCatalog; PointCompon: TSCSComponent; NBConnector: TConnectorObject; InterfRel : TSCSIOfIRel; InterfPosition, JoinedPosition: TSCSInterfPosition; LineCompon: TSCSComponent; ALineInterFace, APointInterFace, aTempInterf: TSCSInterface; LineInterfList: TList; ConnComponList: TList; AInterfPositions1, AInterfPositions2: TSCSInterfPositions; LineComponInterFace, PointComponInterFace: TSCSInterFace; InterFaceAccordanceList: TList; APointInterfID: Integer; ConnectedInterFaces: TSCSIOfIRel; ConnectIDCompRel: Integer; TempInterfaces1, TempInterfaces2: TSCSInterfaces; InterfCount: Integer; ptrConnection: PComplect; DisJoinList: TList; NewConn: TConnectorObject; CanContinue: Boolean; JoinedComponent: TSCSComponent; SelfLineConnectInfo, JoinedLineConnectInfo: TLineComponConnectionInfo; SavedLineConnectionsList: TList; ComponToDeleteList: TSCSComponents; SavedComponList: TList; deltax, deltay: Double; NB_Conn, CreatedConn: TConnectorObject; Procedure CheckSaveLineConnectionsBySide(aLine: TOrthoLine; aCableCompon: TSCSComponent; aSide: Integer); var i, j, k: Integer; InterfPos: TSCSInterfPosition; Interf, ConnectedInterf: TSCSInterface; DirectConnectedComponList, ConnectedComponList: TList; JoinedCompon, ConnectedLineComponent: TSCSComponent; PointToSave: TConnectorObject; PointCatalog, LineCatalog, JoinedLineCatalog: TSCSCatalog; POintFigure, LineFigure: TFigure; CanContinue: Boolean; WayList: TList; // ComponToDeleteList: TSCSComponents; LastComponent: TSCSComponent; LastSide: Integer; isLineConnection, isPointConnection: Boolean; ComponJoinedByMultiInterface: TSCSComponent; JoinedInterface: TSCSInterface; FirstComponID: Integer; SavedPointConnection: Boolean; Procedure SaveConnectionOnPointObject(aPointObject: TConnectorObject; aPointCatalog: TSCSCatalog; aJoinedLineCompon: TSCSComponent; ConnectionSide: Integer); var i, j, k, l, m: Integer; PointJoinedLineCatalog : TSCSCatalog; PointComponent, LineComponent: TSCSComponent; LineJoinedComponList: TList; LineInterface: TSCSInterface; aCableComponInterface: TSCSInterface; begin NBConnector := APointObject; if NBConnector <> nil then begin //JoinedPointObject := F_ProjMan.GSCSBase.CurrProject.CurrList.GetCatalogFromReferencesBySCSID(NBConnector.Id); // DivLineObject := F_ProjMan.GSCSBase.CurrProject.CurrList.GetCatalogFromReferencesBySCSID(ASnapLine.Id); //DivLineObject := aJoinedLineCompon.GetFirstParentCatalog; //if (aPointCatalog <> nil) and (DivLineObject <> nil) then if (aPointCatalog <> nil) then begin //if ((aPointCatalog.ComponentReferences.Count > 0) and (DivLineObject.ComponentReferences.Count > 0)) then begin InterFaceAccordanceList := TList.Create; //LineInterfList := TList.Create; //for j := 0 to DivLineObject.ComponentReferences.Count - 1 do //begin //LineCompon := DivLineObject.ComponentReferences[j]; // 14/05/2016 // if LineCompon.ComponentType.SysName = ctsnCable then if IsCableComponent(aJoinedLineCompon) then // так правильнее -- для всех кабелей // begin if CheckJoinedComponToComponFromObject(aJoinedLineCompon, aPointCatalog) then begin for k := 0 to aJoinedLineCompon.Interfaces.count - 1 do begin if (aJoinedLineCompon.Interfaces[k].TypeI = itFunctional) and (aJoinedLineCompon.Interfaces[k].Side = ConnectionSide) and ((aJoinedLineCompon.Interfaces[k].IsBusy = biTrue) or (aJoinedLineCompon.Interfaces[k].BusyPositions.Count > 0)) then begin SavedLineComponList := TList.Create; SavedPointComponList := TList.Create; ALineInterFace := TSCSInterFace(aJoinedLineCompon.Interfaces.Items[k]); { if SavedLineComponList.IndexOf(LineCompon.Interfaces.Items[k]) = -1 then SavedLineComponList.Add(TSCSInterFace(LineCompon.Interfaces.Items[k]));} if aCableCompon.Id = aJoinedLineCompon.id then begin if SavedLineComponList.IndexOf(ALineInterFace) = -1 then SavedLineComponList.Add(TSCSInterface(ALineInterFace)); end else begin aCableComponInterFace := aCableCompon.Interfaces[k]; if SavedLineComponList.IndexOf(aCableComponInterFace) = -1 then SavedLineComponList.Add(TSCSInterface(aCableComponInterFace)); // aTempInterf := TSCSInterface(SavedLineComponList[l]); end; APointInterfID := -1; for l := 0 to ALineInterFace.BusyPositions.Count - 1 do begin InterfPosition := ALineInterFace.BusyPositions[l]; JoinedPosition := InterfPosition.GetConnectedPos; if JoinedPosition <> nil then begin if JoinedPosition.InterfOwner <> nil then begin if SavedPointComponList.IndexOf(JoinedPosition.InterfOwner) = -1 then SavedPointComponList.Add(TSCSInterFace(JoinedPosition.InterfOwner)); end; end; end; if ((SavedLineComponList.Count > 0) and (SavedPointComponList.Count > 0)) then begin InterFaceAccordanceList.Add(SavedLineComponList); InterFaceAccordanceList.Add(SavedPointComponList); end else begin SavedLineComponList.Clear; SavedPointComponList.Clear; FreeAndNil(SavedLineComponList); FreeAndNil(SavedPointComponList); end; end; end; end; end; //end; end; if InterFaceAccordanceList.Count > 0 then begin // состояние соединения кабеля на точечном объекте SelfLineConnectInfo := TLineComponConnectionInfo.Create(True); SelfLineConnectInfo.ComponId := aCableCompon.ID;//AJoinedLineCompon.ID; //SelfLineConnectInfo.ComponSide := ConnectionSide; SelfLineConnectInfo.ComponSide := aSide; SelfLineConnectInfo.isLineConnection := False; JoinedLineConnectInfo := TLineComponConnectionInfo.Create(False); JoinedLineConnectInfo.ComponCatalogID := APointCatalog.ID; JoinedLineConnectInfo.ComponSide := 0; JoinedLineConnectInfo.ConnectedComponList := InterFaceAccordanceList; SelfLineConnectInfo.ConnectedComponList.Add(JoinedLineConnectInfo); SavedLineConnectionsList.Add(SelfLineConnectInfo); end else FreeAndNil(InterFaceAccordanceList); end; end; // сбросить соединения линейного с точечными на заданной стороне LineJoinedComponList := TList.Create; for i := 0 to aJoinedLineCompon.Interfaces.Count - 1 do begin LineInterface := TSCSInterface(aJoinedLineCompon.Interfaces[i]); if (LineInterface.TypeI = itFunctional) and (LineInterface.Side = ConnectionSide) then begin for j := 0 to LineInterface.ConnectedInterfaces.Count - 1 do if LineJoinedComponList.IndexOf(TSCSComponent(LineInterface.ConnectedInterfaces[j].ComponentOwner)) = -1 then LineJoinedComponList.Add(TSCSComponent(LineInterface.ConnectedInterfaces[j].ComponentOwner)); end; end; for i := 0 to LineJoinedComponList.Count - 1 do begin aJoinedLineCompon.DisJoinFrom(TSCSComponent(LineJoinedComponList[i])); end; FreeAndNil(LineJoinedComponList); // end; function GetLastConnectedComponent(ALastCompon: TSCSComponent; SelfSide: integer): TSCSComponent; var i, j, k: Integer; //LineFigure: Tfigure; LineCatalog: TSCSCatalog; LastComponinterface: TSCSInterface; InterfPos: TSCSInterfPosition; LineFound, PointFound: Boolean; ConnectedCompon: TSCSComponent; LastLine: TOrthoLine; SavedPosSide: Integer; LastLineCompon: TSCSComponent; JoinedPointObject: TConnectorObject; JoinedPointCatalog: TSCSCatalog; begin Result := nil; LineFound := False; PointFound := False; CanContinue := False; LastLineCompon := ALastCompon; LineCatalog := ALastCompon.GetFirstParentCatalog; if LineCatalog <> nil then begin LastLine := TOrthoLine(GetFigureByCatalogId(LineCatalog.SCSID)); if LastLine <> nil then begin if (not LastLine.FIsVertical) and (not LastLine.FIsRaiseUpDown) then begin if ConnectedComponList.IndexOf(ALastCompon) = -1 then ConnectedComponList.Add(ALastCompon) else exit; Exit; end; end; end; for i := 0 to ALastCompon.Interfaces.Count - 1 do begin LastComponinterface := TSCSInterface(ALastCompon.Interfaces[i]); if ((LastComponinterface.TypeI = itFunctional) and (LastComponinterface.Side <> SelfSide)) then begin if ((LastComponinterface.IsBusy = biTrue) or (LastComponinterface.BusyPositions.Count > 0)) then begin for j := 0 to LastComponinterface.BusyPositions.Count - 1 do begin InterfPos := TSCSInterfPosition(LastComponinterface.BusyPositions[j]); InterfPos := InterfPos.GetConnectedPos; if InterfPos <> nil then begin ConnectedCompon := TSCSComponent(InterfPos.InterfOwner.ComponentOwner); if ConnectedCompon.IsLine = biTrue then begin LastLineCompon := ConnectedCompon; if ConnectedComponList.IndexOf(ConnectedCompon) = -1 then begin SavedPosSide := InterfPos.InterfOwner.Side; // сторона подключения LineCatalog := ConnectedCompon.GetFirstParentCatalog; if LineCatalog <> nil then begin LineFigure := GetFigureByCatalogId(LineCatalog.SCSID); if LineFigure <> nil then begin if TOrthoLine(LineFigure).FIsVertical or TOrthoLine(LineFigure).FIsRaiseUpDown then begin if ComponToDeleteList.IndexOf(ConnectedCompon) = -1 then ComponToDeleteList.Add(ConnectedCompon); if ConnectedComponlist.IndexOf(Connectedcompon) = -1 then ConnectedComponList.Add(ConnectedCompon); ALastCompon.DisJoinFrom(ConnectedCompon); Result := GetLastConnectedComponent(ConnectedCompon, SavedPosSide); if Result = Nil then begin if SavedPosSide = 1 then LastSide := 2 else if SavedPosSide = 2 then LastSide := 1; end; end else // если сходим с вертикали -- приехали begin Result := ConnectedCompon; //Result := nil; // LineFigure := nil; // сброс для множественных подключений на том же уровне при наличии мультиинтерфейса if ConnectedComponList.IndexOf(ConnectedCompon) = -1 then ConnectedComponList.Add(ConnectedCompon); {if SavedPosSide = 1 then LastSide := 2 else if SavedPosSide = 2 then LastSide := 1;} LastSide := SavedPosSide; exit; end; end; end; end; end else begin if ConnectedCompon.isLine = biFalse then begin SavedPosSide := LastComponInterface.Side; LastSide := SavedPosSide; JoinedPointCatalog := ConnectedCompon.GetFirstParentCatalog; if JoinedPointCatalog <> nil then begin JoinedPointObject := TConnectorObject(GetFigureByCatalogId(JoinedPointCatalog.SCSID)); if JoinedPointObject <> nil then begin SaveConnectionOnPointObject(JoinedPointObject, JoinedPointCatalog, aLastCompon, LastSide); SavedPointConnection := True; isPointConnection := True; end; Result := nil; Exit; end; end; end; end; end; end; end; end; end; begin CanContinue := False; SelfLineConnectInfo := nil; JoinedLineConnectInfo := Nil; ConnectedComponList := TList.Create; PointToSave := nil; isLineConnection := False; isPointConnection := False; LineFigure := Nil; SavedPointConnection := False; // ComponToDeleteList := TSCSComponents.Create(False); if ((aCableCompon.JoinedComponents.count > 0) and (SavedComponList.IndexOf(aCableCompon) = -1)) then SavedComponList.Add(ACablecompon); for i := 0 to aCableCompon.Interfaces.Count - 1 do begin Interf := TSCSInterface(aCableCompon.Interfaces[i]); // ищем возможные подключения с указанной стороны if ((Interf.Side = aSide) and (Interf.TypeI = itFunctional) and ((Interf.IsBusy = biTrue) or (interf.BusyPositions.Count > 0))) then begin for j := 0 to Interf.BusyPositions.Count - 1 do begin InterfPos := TSCSInterfPosition(Interf.BusyPositions[j]); // занятая позиция интерфейса InterfPos := InterfPos.GetConnectedPos; // подключенная к ней непосредственно позиция интерфейса // присоединенного компонента JoinedCompon := InterfPos.InterfOwner.ComponentOwner; // присоединенный компонент if JoinedCompon <> nil then begin // подключен точечный компонент if JoinedCompon.IsLine = biFalse then begin // точечное соединение -- сохранить по позициям для восстановления if ConnectedComponList.IndexOf(JoinedCompon) = -1 then ConnectedComponList.Add(JoinedCompon); if PointToSave = nil then begin PointCatalog := JoinedCompon.GetFirstParentCatalog; PointToSave := TConnectorObject(GetFigurebyCatalogID(PointCatalog.SCSID)); // нашли точечный, присоединенный к кабелю -- сохраняем соединение и вываливаемся if ((PointToSave <> nil) and (CheckFigureByClassName(PointToSave, cTConnectorObject))) then begin SaveConnectionOnPointObject(PointtoSave, PointCatalog, aCableCompon, aSide); exit; //// BREAK ////; end; end; end // подключен линейный компонент // линейные поинтерфейсно соединять не нужно, просто соединить кабель else if JoinedCompon.isLine = biTrue then begin if ConnectedComponlist.IndexOf(JoinedCompon) = -1 then begin ConnectedComponList.Add(JoinedCompon); isLineConnection := True; LastSide := InterfPos.InterfOwner.Side; // сторона подлючения подключенного кабеля к текущему //если подключен линейный - ищем конечную точку восстановления JoinedLineCatalog := JoinedCompon.GetFirstParentCatalog; if JoinedLineCatalog <> nil then begin LineFigure := GetFigureByCatalogId(JoinedLineCatalog.SCSID); if LineFigure <> nil then begin if (TOrthoLine(LineFigure).FIsVertical or TOrthoLine(LineFigure).FIsRaiseUpDown) then begin // список на удаление if (ComponToDeleteList.IndexOf(JoinedCompon) = -1) then ComponToDeleteList.Add(JoinedCompon); // получить последний кусок кабеля aCableCompon.DisJoinFrom(JoinedCompon); JoinedCompon := GetLastConnectedComponent(JoinedCompon, LastSide); end; // если последняя фигура -- вертикаль и дальше обрыв if (JoinedCompon = nil) and (not SavedPointConnection) then begin if ConnectedComponList.Count > 0 then begin JoinedCOmpon := TSCSComponent(ConnectedComponList[ConnectedComponList.Count - 1]); JoinedLineCatalog := JoinedCompon.GetFirstParentCatalog; LineFigure := GetFigureByCatalogId(JoinedLineCatalog.SCSID); end; end; end; end; // если соединение - линейное - сохранить его if (LineFigure <> nil) and (not SavedPointConnection) then begin // кабель поднимаемой трассы SelfLineConnectInfo := TLineComponConnectionInfo.Create(True); SelfLineConnectInfo.ComponId := aCableCompon.ID; SelfLineConnectInfo.ComponSide := aSide; // трасса и сторона соединения JoinedLineConnectInfo:= TLineComponConnectionInfo.Create(False); JoinedLineConnectInfo.ComponId := JoinedCompon.ID; if TOrthoLine(LineFigure).FIsVertical then begin if LastSide = 1 then LastSide := 2 else if LastSide = 2 then LastSide := 1; end; JoinedLineConnectInfo.ComponSide := LastSide; JoinedLineCatalog := JoinedCompon.GetFirstParentCatalog; if JoinedLineCatalog <> nil then JoinedLineConnectInfo.ComponCatalogID := JoinedLineCatalog.ID; SelfLineConnectInfo.ConnectedComponList.Add(JoinedLineConnectInfo); SavedLineConnectionsList.Add(SelfLineConnectInfo); //отключить найденный кабель нах if aCableCompon.JoinedComponents.IndexOF(JoinedCompon) <> -1 then aCableCompon.DisJoinFrom(JoinedCompon); end; end; end; end; if isLineConnection then Break; //// BREAK //// if isPointConnection then Break; //// BREAK ////; end; end; if isLineConnection then Break; //// BREAK //// if isPointConnection then Break; //// BREAK ////; end; // если мультиинтерфейс - отключить все подключенные на нем( остальные кабели) // и загнать их в список подключенных компонент для восстановления, if aCableCompon.JoinedComponents.Count > 0 then begin for i := 0 to aCableCompon.Interfaces.count - 1 do begin Interf := TSCSInterface(aCableCompon.Interfaces[i]); if ((Interf.TypeI = itFunctional) and (Interf.Side = aSide) and (Interf.Multiple = biTrue) and (Interf.ConnectedInterfaces.Count > 1)) then begin if aCableCompon.JoinedComponents.Count > 0 then begin While Interf.ConnectedInterfaces.Count > 0 do begin JoinedInterface := TSCSInterface(Interf.ConnectedInterfaces[0]); ComponJoinedByMultiInterface := JoinedInterface.ComponentOwner; if ComponJoinedByMultiInterface <> nil then begin if (ComponJoinedByMultiInterface.IsLine = biTrue) then begin ConnectedComponList.Add(ComponJoinedByMultiInterface); // если было сохранение линейного соединения -- добавить в список сохранения подключенный кабель if SelfLineConnectInfo <> nil then begin FirstComponID := TLineComponConnectionInfo(SelfLineConnectInfo.ConnectedComponList[0]).ComponId; // на всякий if ComponJoinedByMultiInterface.ID <> FirstComponID then begin JoinedLineConnectInfo := TLineComponConnectionInfo.Create(False); JoinedLineConnectInfo.ComponId := ComponJoinedByMultiInterface.ID; JoinedLineConnectInfo.ComponSide := JoinedInterface.Side; SelfLineConnectInfo.ConnectedComponList.Add(JoinedLineConnectInfo); end; end; end; // отключить (если уже есть в списке или точечный компонент) aCableCompon.DisJoinFrom(ComponJoinedByMultiInterface); end; end; end; end; end; end; // удалить кабель по пути прохождения if ComponToDeleteList.Count > 0 then begin F_ProjMan.DelComponentsFromList(F_ProjMan.GSCSBase.CurrProject.CurrList, ComponToDeleteList, False, biNone, false, nil); ComponToDeleteList.Clear; end; //FreeAndNil(ComponToDeleteList); ConnectedComponList.Clear; FreeAndNil(ConnectedcomponList); GCadForm.PCad.Refresh; end; Procedure CheckDisJoinLineComponBySide(aLineCompon: TSCSComponent; ASide: Integer); var i, j: Integer; Interf: TSCSInterface; InterfPos: TSCSInterfPosition; JoinedComponList: TList; begin JoinedComponList := TList.Create; for i := 0 to aLineCompon.Interfaces.Count - 1 do begin Interf := TSCSInterface(aLineCompon.Interfaces[i]); if ((Interf.TypeI = itFunctional) and (Interf.Side = aSide)) then begin for j := 0 to Interf.BusyPositions.Count - 1 do begin InterfPos := TSCSInterfPosition(Interf.BusyPositions[j]); InterfPos := InterfPos.GetConnectedPos; if InterfPos <> nil then begin if JoinedComponList.IndexOf(InterfPos.InterfOwner.ComponentOwner) = -1 then JoinedComponList.Add(InterfPos.InterfOwner.ComponentOwner); end; end; end; end; for i := 0 to JoinedComponList.Count - 1 do aLineCompon.DisJoinFrom(TSCSComponent(JoinedComponList[i])); FreeAndNil(JoinedComponList); end; Procedure ConnectCableComponents(ACompon1, ACompon2: TSCSComponent); var LineCatalog1, LineCatalog2 : TSCSCatalog; SelfSide, JoinSide : integer; Line1, Line2: TOrthoLine; function CheckCanJoinOnConnectors(aConn1, aConn2: TConnectorObject): Boolean; begin Result := False; // если на одном точечном if (aConn1.JoinedConnectorsList.Count > 0) and (TConnectorObject(aConn1.JoinedConnectorsList[0]).JoinedConnectorsList.IndexOf(aConn2) <> -1) then Result := True else // или это один и тот же коннектор if aConn1.ID = aConn2.ID then Result := True; end; begin LineCatalog1 := ACompon1.GetFirstParentCatalog; LineCatalog2 := ACompon2.GetFirstParentCatalog; if ((LineCatalog1 <> nil) and (LineCatalog2 <> nil)) then begin Line1 := TOrthoLine(GetFigureByCatalogId(LineCatalog1.SCSId)); Line2 := TOrthoLine(GetFigureByCatalogId(LineCatalog2.SCSId)); if ((Line1 <> nil) and (Line2 <> nil)) then begin SelfSide := 0; JoinSide := 0; if (ACompon1 <> nil) and (ACompon2 <> nil) then begin if CheckCanJoinOnConnectors(TConnectorObject(Line1.JoinConnector1), TConnectorObject(Line2.JoinConnector1)) then ACompon1.JoinTo(ACompon2, 1, 1) else if CheckCanJoinOnConnectors(TConnectorObject(Line1.JoinConnector1), TConnectorObject(Line2.JoinConnector2)) then ACompon1.JoinTo(ACompon2, 1, 2) else if CheckCanJoinOnConnectors(TConnectorObject(Line1.JoinConnector2), TConnectorObject(Line2.JoinConnector1)) then ACompon1.JoinTo(ACompon2, 2, 1) else if CheckCanJoinOnConnectors(TConnectorObject(Line1.JoinConnector2), TConnectorObject(Line2.JoinConnector2)) then ACompon1.JoinTo(ACompon2, 2, 2); end; end; end; end; Procedure RestoreLineConnectionsBySide(aLine: TOrthoLine; ACableCompon: TSCSComponent; aSide: Integer); var i, j, k, l, m: Integer; TargetLine, TargetPointFigure: TFigure; WayList: TList; SelfConnector, TargetConn: TConnectorObject; TargetCatalog: TSCSCatalog; IdNewCompon: Integer; TargetCompon, NewCompon, FirstCompon, NextCompon: TSCSComponent; PassWayList: Boolean; // прокладывать кабель на вертикали/райзы ComponJoinedByMultiInterFace: TSCSComponent; CanRestoreConnection: Boolean; DisJoinSide: Integer; DisJoinComponList: TList; SideConnectionDropped: Boolean; Function GetInterfaceForConnection(AInterf: TSCSInterFace; WasConnectedCable, isConnectedCable: TSCSComponent; aPointObject: TConnectorObject): TSCSInterFace; var i, j, k: Integer; LineCompon: TSCSComponent; LineFigure: TOrthoLine; LineCatalog: TSCSCatalog; SourceLineCatalog, DestLineCatalog: TSCSCatalog; ConnectionSide : Integer; TmpInterfPos: TSCSInterfPosition; begin Result := nil; LineCatalog := Nil; ConnectionSide := 0; LineCompon := isConnectedCable;//AInterf.ComponentOwner; if LineCompon <> nil then begin LineCatalog := LineCompon.GetFirstParentCatalog; if LineCatalog <> nil then begin LineFigure := TOrthoLine(GetFigurebyCatalogID(LineCatalog.SCSID)); if LineFigure <> nil then begin if (TConnectorObject(LineFigure.JoinConnector1).JoinedConnectorsList.IndexOf(aPointObject) <> -1) or (TConnectorObject(LineFigure.JoinConnector1).ID = aPointObject.ID) then ConnectionSide := 1 else if (TConnectorObject(LineFigure.JoinConnector2).JoinedConnectorsList.IndexOf(aPointObject) <> -1) or (TConnectorObject(LineFigure.JoinConnector2).ID = aPointObject.ID) then ConnectionSide := 2; for j := 0 to LineCompon.Interfaces.Count - 1 do begin if TSCSInterface(LineCompon.Interfaces[j]).TypeI = itFunctional then if TSCSInterface(LineCompon.Interfaces[j]).Npp = AInterf.Npp then // вторая сторона идин х занята уже ...(если не обрыв кабеля) if TSCSInterface(LineCompon.Interfaces[j]).Side = ConnectionSide then if ((TSCSInterface(LineCompon.Interfaces[j]).IsBusy = biFalse) or (TSCSInterface(LineCompon.Interfaces[j]).BusyPositions.Count = 0)) then begin Result := TSCSInterface(LineCompon.Interfaces[j]); break; end; end; end; end; {SourceLineCatalog := F_ProjMan.GSCSBase.CurrProject.CurrList.GetCatalogFromReferencesBySCSID(ALine.ID); if SourceLineCatalog <> nil then begin for i := 0 to SourceLineCatalog.ComponentReferences.Count - 1 do begin if (TSCSComponent(SourceLineCatalog.ComponentReferences[i]).ID = LineCompon.ID) then begin DestLineCatalog := F_ProjMan.GSCSBase.CurrProject.CurrList.GetCatalogFromReferencesBySCSID(AddLine.ID); if DestLineCatalog <> nil then begin if i <= (DestLineCatalog.ComponentReferences.Count - 1) then begin LineCompon := DestLineCatalog.ComponentReferences[i]; if LineCompon <> nil then begin // Difining ConnectionSide { for j := 0 to LineCompon.Interfaces.Count - 1 do begin ConnectionSide := 2; if TSCSInterface(LineCompon.Interfaces[j]).TypeI = itFunctional then if TSCSInterface(LineCompon.Interfaces[j]).BusyPositions.Count > 0 then begin for k := 0 to TSCSInterface(LineCompon.Interfaces[j]).BusyPositions.Count - 1 do begin TmpInterfPos := TSCSInterface(LineCompon.Interfaces[j]).BusyPositions[k]; TmpInterfPos := TmpInterfPos.GetConnectedPos; if TSCSComponent(TmpInterfPos.InterfOwner.ComponentOwner).IsLine = biTrue then begin if TmpInterfPos.InterfOwner.Side = 2 then ConnectionSide := 1; break; end; end; end; end;} { end; end; end; Break; //// BREAK ////; end; end; end; } end; end; Function DefineIDComponRel(ALineCompon, APointCompon: TSCSComponent): Integer; var TopCatalog: TSCSCatalog; begin Result := -1; begin TopCatalog := aLineCompon.GetTopParentCatalog; if TopCatalog <> nil then if TopCatalog is TSCSProject then Result := TSCSProject(TopCatalog).GenIDByGeneratorIndex(giComponentRelationID, 1); end; //if IDComponRel = -1 then //IDComponRel := TF_Main(ActiveForm).AppendToComponRel(Self.ID, AComponent.ID, 1, AConnectType); end; begin WayList := nil; SelfLineConnectInfo := Nil; SelfConnector := nil; TargetConn := Nil; PassWayList := True; DisJoinComponList := nil; CanRestoreConnection := True; SideConnectionDropped := False; While CanRestoreconnection do begin CanRestoreConnection := False; for i := 0 to SavedLineConnectionsList.Count - 1 do begin if ((TLineComponConnectionInfo(SavedLineConnectionsList[i]).ComponId = ACableCompon.ID) and (TLineComponConnectionInfo(SavedLineConnectionsList[i]).ComponSide = aSide)) then begin SelfLineConnectInfo := TLineComponConnectionInfo(SavedLineConnectionsList[i]); CanRestoreConnection := True; Break; //// BREAK ////; end; end; if SelfLineConnectInfo <> nil then begin if not SideConnectionDropped then begin CheckDisJoinLineComponBySide(ACableCompon, aSide); SideConnectionDropped := True; end; if SelfLineConnectInfo.ComponSide = 1 then SelfConnector := TConnectorObject(aLine.JoinConnector1) else if SelfLineConnectInfo.ComponSide = 2 then SelfConnector := TConnectorObject(aLine.JoinConnector2); if SelfConnector <> nil then begin // for i := 0 to SelfLineConnectInfo.ConnectedComponList.Count - 1 do begin FirstCompon := F_ProjMan.GSCSBase.CurrProject.CurrList.GetComponentFromReferences(SelfLineConnectInfo.ComponId); JoinedLineConnectInfo := TLineComponConnectionInfo(SelfLineConnectInfo.ConnectedComponList[0]); TargetCompon := nil; if SelfLineConnectInfo.isLineConnection then TargetCompon := F_ProjMan.GSCSBase.CurrProject.CurrList.GetComponentFromReferences(JoinedLineConnectInfo.ComponId); if FirstCompon <> nil then begin // произошло разделение вертикали if TargetCompon = nil then begin TargetCatalog := F_ProjMan.GSCSBase.CurrProject.CurrList.GetCatalogFromReferences(JoinedLineConnectInfo.ComponCatalogID); end else if TargetCompon <> nil then TargetCatalog := TargetCompon.GetFirstParentCatalog; // линейное соединение (кабель -- кабель) { if TargetCompon.IsLine = biTrue then begin TargetCatalog := TargetCompon.GetFirstParentCatalog;} if TargetCatalog <> nil then begin TargetLine := GetFigureByCatalogID(TargetCatalog.SCSID); if TargetLine <> nil then begin TargetConn := Nil; if CheckFigureByClassName(TargetLine, cTOrthoLine) then begin // линейноне подключение if JoinedLineConnectInfo.ComponSide = 1 then TargetConn := TConnectorObject(TOrthoLine(TargetLine).JoinConnector1) else if JoinedLineConnectInfo.ComponSide = 2 then TargetConn := TConnectorObject(TOrthoLine(TargetLine).JoinConnector2); end else if CheckFigureByClassName(TargetLine, CTConnectorObject) then begin // точечное подключение TargetPointfigure := TargetLine; if JoinedLineConnectInfo.ComponSide = 0 then begin TargetConn := TConnectorObject(TargetLine); end; end; if TargetConn <> nil then begin // если произошло разделение вертикали - найти коннектор от высоты подъема WayList := GetAllTraceInCAD(TFigure(SelfConnector), TFigure(TargetConn)); if WayList <> nil then begin // удалить невертикали и нерайзы из пути for j := (WayList.Count - 1) downto 0 do begin if CheckFigureByClassName(TFigure(WayList[j]), cTOrthoLine) then begin if ((not TOrthoLine(WayList[j]).FIsVertical) and (not TOrthoLine(WayList[j]).FIsRaiseUpDown)) then WayList.Delete(j); end {else WayList.Delete(j);} end; // прокладка кабеля (только на райз или на вертикали) for j := 0 to WayList.Count - 1 do begin TargetLine := TFigure(WayList[j]); if CheckFigureByClassName(TargetLine, CTOrthoLine) then begin if ((TOrthoLine(TargetLine).FIsVertical) or (TOrthoLine(TargetLine).FIsRaiseUpDown)) then begin TargetCatalog := F_ProjMan.GSCSBase.CurrProject.CurrList.GetCatalogFromReferencesBySCSID(TargetLine.ID); if TargetCatalog <> nil then begin NewCompon := Nil; // вкинуть кабель на трассу NewCompon := CopyComponentToPMSCSObject(ACableCompon, TargetCatalog, False); // рассоединить добавленный кабель от всего, к чему подключился автоматом if NewCompon <> nil then NewCompon.DisJoinFromAll(false).free; end; end; end; end; end; end; end; // FirstCompon := TargetCompon; // соединить кабели if WayList <> nil then begin if WayList.Count > 0 then begin //FirstCompon := aCableCompon; for j := 0 to WayList.count - 1 do begin TargetLine := TFigure(WayList[j]); if CheckFigureByClassName(TargetLine, cTOrthoLine) then begin if TOrthoLine(TargetLine).FIsVertical or TOrthoLine(TargetLine).FIsRaiseUpDown then begin TargetCatalog := F_ProjMan.GSCSBase.CurrProject.CurrList.GetCatalogFromReferencesBySCSID(TargetLine.ID); if TargetCatalog <> nil then begin NewCompon := TargetCatalog.LastAddedComponent; if NewCompon <> nil then begin if FirstCompon.JoinedComponents.IndexOf(NewCompon) = -1 then ConnectCableComponents(FirstCompon, NewCompon); // если на мультиинтерфейсе if ((j = 0) and (SelfLineConnectInfo.ConnectedComponList.Count > 1)) then begin for k := 1 to SelfLineConnectInfo.ConnectedComponList.Count - 1 do begin ComponJoinedByMultiInterFace := F_ProjMan.GSCSBase.CurrProject.CurrList.GetComponentFromReferences(TLineComponConnectionInfo(SelfLineConnectInfo.ConnectedComponList[k]).ComponId); if ComponJoinedByMultiInterFace <> nil then begin if NewCompon.JoinedComponents.IndexOf(ComponJoinedByMultiInterFace) = -1 then ConnectCableComponents(NewCompon, ComponJoinedByMultiInterFace); end; end; end; FirstCompon := NewCompon; NewCompon := Nil; end; end; end else begin //NewCompon := aCableCompon;//F_ProjMan.GSCSBase.CurrProject.CurrList.GetComponentFromReferences(JoinedLineConnectInfo.ComponId); NewCompon := F_ProjMan.GSCSBase.CurrProject.CurrList.GetComponentFromReferences(JoinedLineConnectInfo.ComponId); if NewCompon <> nil then begin if FirstCompon.JoinedComponents.IndexOf(NewCompon) = -1 then ConnectCableComponents(FirstCompon, NewCompon); // если на мультиинтерфейсе if SelfLineConnectInfo.ConnectedComponList.Count > 1 then begin for k := 1 to SelfLineConnectInfo.ConnectedComponList.Count - 1 do begin ComponJoinedByMultiInterFace := F_ProjMan.GSCSBase.CurrProject.CurrList.GetComponentFromReferences(TLineComponConnectionInfo(SelfLineConnectInfo.ConnectedComponList[k]).ComponId); if ComponJoinedByMultiInterFace <> nil then begin if NewCompon.JoinedComponents.IndexOf(ComponJoinedByMultiInterFace) = -1 then ConnectCableComponents(NewCompon, ComponJoinedByMultiInterFace); end; end; end; end; break; end; end; end; // конечное соединение //NewCompon := aCableCompon;//F_ProjMan.GSCSBase.CurrProject.CurrList.GetComponentFromReferences(JoinedLineConnectInfo.ComponId); if SelfLineConnectInfo.isLineConnection then begin NewCompon := F_ProjMan.GSCSBase.CurrProject.CurrList.GetComponentFromReferences(JoinedLineConnectInfo.ComponId); if ((NewCompon <> nil) and (FirstCompon.JoinedComponents.IndexOf(NewCompon) = -1)) then ConnectCableComponents(FirstCompon, NewCompon); end else begin if not SelfLineConnectInfo.isLineConnection then begin // Restore Connection // восстановить состояние соединения кабеля с точечными компонентами NewCompon := FirstCompon; // если коннектор упал на точечный объект, то кабель мог автоматом соединиться с // компонентами точечного, поэтому нужно их расконнектить до восстановления соединения TargetCatalog := NewCompon.GetFirstParentCatalog; if TargetCatalog <> nil then begin TargetLine := GetFigureByCatalogId(TargetCatalog.SCSID); if TargetLine <> nil then begin DisJoinSide := 0; if TConnectorObject(TOrthoLine(TargetLine).JoinConnector1).JoinedConnectorsList.IndexOf(TConnectorObject(TargetPointFigure)) <> -1 then DisJoinSide := 1 else if TConnectorObject(TOrthoLine(TargetLine).JoinConnector2).JoinedConnectorsList.IndexOf(TConnectorObject(TargetPointFigure)) <> -1 then DisJoinSide := 2; if DisJoinSide <> 0 then begin DisJoinComponList := TList.Create; for i := 0 to NewCompon.Interfaces.Count - 1 do begin if (NewCompon.Interfaces[i].TypeI = itFunctional) and (NewCompon.Interfaces[i].Side = DisJoinSide) then begin for j := 0 to NewCompon.Interfaces[i].ConnectedInterfaces.Count - 1 do begin if (TSCSInterface(NewCompon.Interfaces[i].ConnectedInterfaces[j]).ComponentOwner <> nil) and (DisJoinComponList.IndexOf(TSCSInterface(NewCompon.Interfaces[i].ConnectedInterfaces[j]).ComponentOwner) = -1) then DisJoinComponList.Add(TSCSInterface(NewCompon.Interfaces[i].ConnectedInterfaces[j]).ComponentOwner); end; end; end; for i := 0 to DisJoinComponList.Count - 1 do begin NewCompon.DisJoinFrom(TSCSComponent(DisJoinComponList[i])); end; end; FreeAndNil(DisJoinComponList); end; end; FirstCompon := F_ProjMan.GSCSBase.CurrProject.CurrList.GetComponentFromReferences(SelfLineConnectInfo.ComponId); InterFaceAccordanceList := JoinedLineConnectInfo.ConnectedComponList; if ((InterFaceAccordanceList <> nil) and (InterFaceAccordanceList.Count > 0)) then begin i := 0; While (i <= (InterFaceAccordanceList.Count - 1)) do begin SavedLineComponList := TList(InterFaceAccordanceList[i]); SavedPointComponList := TList(InterFaceAccordanceList[i + 1]); for j := 0 to SavedLineComponList.Count - 1 do begin aTempInterf := TSCSInterface(SavedLineComponList[j]); ALineInterFace := GetInterfaceForConnection(aTempInterf, FirstCompon, NewCompon, TConnectorObject(TargetPointFigure)); if ALineInterFace <> nil then begin LineCompon := ALineInterFace.ComponentOwner; for k := 0 to SavedPointComponList.Count - 1 do begin APointInterFace := TSCSInterface(SavedPointComponList[k]); PointCompon := APointInterFace.ComponentOwner; AInterfPositions1 := ALineInterFace.GetEmptyPositions; AInterfPositions2 := APointInterFace.GetEmptyPositions; // уравнять количество позиций для соединения if AInterfPositions1.Positions.Count > AInterfPositions2.Positions.Count then begin While AInterfPositions1.Positions.Count <> AInterfPositions2.Positions.Count do begin l := AInterfPositions1.Positions.Count - 1; AInterfPositions1.Positions.Delete(l); end; AInterfPositions1.DefineKolvo; end else if AInterfPositions2.Positions.Count > AInterfPositions1.Positions.Count then begin While AInterfPositions2.Positions.Count <> AInterfPositions1.Positions.Count do begin l := AInterfPositions2.Positions.Count - 1; AInterfPositions2.Positions.Delete(l); end; AInterfPositions2.DefineKolvo; end; ConnectIDCompRel := DefineIDComponRel(LineCompon, PointCompon); // До того как соединить интерфейсы, нужно соединить сами компоненты if LineCompon.JoinedComponents.IndexOf(PointCompon) = -1 then begin TempInterfaces1 := TSCSInterfaces.Create(false); TempInterfaces2 := TSCSInterfaces.Create(false); if TF_Main(LineCompon.ActiveForm).F_ChoiceConnectSide.JoinWithDefineSides(LineCompon, PointCompon, false, TempInterfaces1, TempInterfaces2, true).CanConnect then; FreeAndNil(TempInterfaces1); FreeAndNil(TempInterfaces2); end; if LineCompon.JoinedComponents.IndexOf(PointCompon) <> -1 then begin ptrConnection := LineCompon.GetConnectionByConnected(PointCompon); if ptrConnection <> nil then begin TempInterfaces1 := TSCSInterfaces.Create(false); TempInterfaces2 := TSCSInterfaces.Create(false); TempInterfaces1.Add(ALineInterFace); TempInterfaces2.Add(APointInterFace); InterfCount := AInterfPositions1.Kolvo; if InterfCount > AInterfPositions2.Kolvo then InterfCount := AInterfPositions2.Kolvo; TF_Main(LineCompon.ActiveForm).ConnectInterfacesWithAccordance(ALineInterFace, APointInterFace, InterfCount, InterfCount, ptrConnection.ID, cntUnion, AInterfPositions1, AInterfPositions2, true, TempInterfaces1, TempInterfaces2); TF_Main(LineCompon.ActiveForm).F_ChoiceConnectSide.OnAfterJoinCompons(LineCompon, PointCompon, -1, -1); end; end; end; end; end; SavedLineComponList.Clear; SavedPointComponList.Clear; FreeAndNil(SavedLineComponList); FreeAndNil(SavedPointComponList); Inc(i,2); end; end; if InterFaceAccordanceList <> nil then begin InterFaceAccordanceList.clear; FreeAndNil(InterFaceAccordanceList); end; end; end; end else begin //NewCompon := aCableCompon;// F_ProjMan.GSCSBase.CurrProject.CurrList.GetComponentFromReferences(JoinedLineConnectInfo.ComponId); NewCompon := F_ProjMan.GSCSBase.CurrProject.CurrList.GetComponentFromReferences(JoinedLineConnectInfo.ComponId); if NewCompon <> nil then if FirstCompon.JoinedComponents.IndexOf(NewCompon) = -1 then ConnectCableComponents(FirstCompon, NewCompon); // если на мультиинтерфейсе if SelfLineConnectInfo.ConnectedComponList.Count > 1 then begin for k := 1 to SelfLineConnectInfo.ConnectedComponList.Count - 1 do begin ComponJoinedByMultiInterFace := F_ProjMan.GSCSBase.CurrProject.CurrList.GetComponentFromReferences(TLineComponConnectionInfo(SelfLineConnectInfo.ConnectedComponList[k]).ComponId); if ComponJoinedByMultiInterFace <> nil then begin if NewCompon.JoinedComponents.IndexOf(ComponJoinedByMultiInterFace) = -1 then ConnectCableComponents(NewCompon, ComponJoinedByMultiInterFace); end; end; end; end; WayList.Clear; FreeAndNil(WayList); end else begin // если соединение линейное if SelfLineConnectInfo.isLineConnection then begin // NewCompon := aCableCompon;//F_ProjMan.GSCSBase.CurrProject.CurrList.GetComponentFromReferences(JoinedLineConnectInfo.ComponId); NewCompon := F_ProjMan.GSCSBase.CurrProject.CurrList.GetComponentFromReferences(JoinedLineConnectInfo.ComponId); if NewCompon <> nil then if FirstCompon.JoinedComponents.IndexOf(NewCompon) = - 1 then ConnectCableComponents(FirstCompon, NewCompon); // если на мультиинтерфейсе if SelfLineConnectInfo.ConnectedComponList.Count > 1 then begin for k := 1 to SelfLineConnectInfo.ConnectedComponList.Count - 1 do begin ComponJoinedByMultiInterFace := F_ProjMan.GSCSBase.CurrProject.CurrList.GetComponentFromReferences(TLineComponConnectionInfo(SelfLineConnectInfo.ConnectedComponList[k]).ComponId); if ComponJoinedByMultiInterFace <> nil then begin if NewCompon.JoinedComponents.IndexOf(ComponJoinedByMultiInterFace) = -1 then ConnectCableComponents(NewCompon, ComponJoinedByMultiInterFace); end; end; end; end // если кабель был присобачен к компонентам точечного объекта - соединить как было else begin end; // end; end else begin if not SelfLineConnectInfo.isLineConnection then begin TargetPointFigure := TConnectorObject(GetFigureByCatalogId(JoinedLineConnectInfo.ComponId)); if TargetPointFigure <> nil then begin // если чистый коннектор и на нем объект -- получить его if (TConnectorObject(TargetPointFigure).ConnectorType = ct_clear) and (TConnectorObject(TargetPointFigure).JoinedConnectorsList.Count > 0) then TargetPointFigure := TFigure(TConnectorObject(TargetPointFigure).JoinedConnectorsList[0]); WayList := GetAllTraceInCAD(TFigure(SelfConnector), TFigure(TargetPointFigure)); if WayList <> nil then begin // прокладка кабеля (только на райз или на вертикали) for j := 0 to WayList.Count - 1 do begin TargetLine := TFigure(WayList[j]); if CheckFigureByClassName(TargetLine, CTOrthoLine) then begin if ((TOrthoLine(TargetLine).FIsVertical) or (TOrthoLine(TargetLine).FIsRaiseUpDown)) then begin TargetCatalog := F_ProjMan.GSCSBase.CurrProject.CurrList.GetCatalogFromReferencesBySCSID(TargetLine.ID); if TargetCatalog <> nil then begin NewCompon := Nil; // вкинуть кабель на трассу NewCompon := CopyComponentToPMSCSObject(ACableCompon, TargetCatalog, False); // рассоединить добавленный кабель от всего, к чему подключился автоматом if NewCompon <> nil then NewCompon.DisJoinFromAll(false).free; end; end; end; end; // выполнить кабельное соединение по пути следования for j := 0 to WayList.count - 1 do begin TargetLine := TFigure(WayList[j]); if CheckFigureByClassName(TargetLine, cTOrthoLine) then begin if TOrthoLine(TargetLine).FIsVertical or TOrthoLine(TargetLine).FIsRaiseUpDown then begin TargetCatalog := F_ProjMan.GSCSBase.CurrProject.CurrList.GetCatalogFromReferencesBySCSID(TargetLine.ID); if TargetCatalog <> nil then begin NewCompon := TargetCatalog.LastAddedComponent; if NewCompon <> nil then begin if FirstCompon.JoinedComponents.IndexOf(NewCompon) = -1 then ConnectCableComponents(FirstCompon, NewCompon); // если на мультиинтерфейсе if ((j = 0) and (SelfLineConnectInfo.ConnectedComponList.Count > 1)) then begin for k := 1 to SelfLineConnectInfo.ConnectedComponList.Count - 1 do begin ComponJoinedByMultiInterFace := F_ProjMan.GSCSBase.CurrProject.CurrList.GetComponentFromReferences(TLineComponConnectionInfo(SelfLineConnectInfo.ConnectedComponList[k]).ComponId); if ComponJoinedByMultiInterFace <> nil then begin if NewCompon.JoinedComponents.IndexOf(ComponJoinedByMultiInterFace) = -1 then ConnectCableComponents(NewCompon, ComponJoinedByMultiInterFace); end; end; end; FirstCompon := NewCompon; NewCompon := Nil; end; end; end; end; end; end; // Restore Connection // восстановить состояние соединения кабеля с точечными компонентами NewCompon := FirstCompon; FirstCompon := F_ProjMan.GSCSBase.CurrProject.CurrList.GetComponentFromReferences(SelfLineConnectInfo.ComponId); InterFaceAccordanceList := JoinedLineConnectInfo.ConnectedComponList; if ((InterFaceAccordanceList <> nil) and (InterFaceAccordanceList.Count > 0)) then begin i := 0; While (i <= (InterFaceAccordanceList.Count - 1)) do begin SavedLineComponList := TList(InterFaceAccordanceList[i]); SavedPointComponList := TList(InterFaceAccordanceList[i + 1]); for j := 0 to SavedLineComponList.Count - 1 do begin aTempInterf := TSCSInterface(SavedLineComponList[j]); ALineInterFace := GetInterfaceForConnection(aTempInterf, FirstCompon, NewCompon, TConnectorObject(TargetPointFigure)); LineCompon := ALineInterFace.ComponentOwner; if ALineInterFace <> nil then begin for k := 0 to SavedPointComponList.Count - 1 do begin APointInterFace := TSCSInterface(SavedPointComponList[k]); PointCompon := APointInterFace.ComponentOwner; AInterfPositions1 := ALineInterFace.GetEmptyPositions; AInterfPositions2 := APointInterFace.GetEmptyPositions; // уравнять количество позиций для соединения if AInterfPositions1.Positions.Count > AInterfPositions2.Positions.Count then begin While AInterfPositions1.Positions.Count <> AInterfPositions2.Positions.Count do begin l := AInterfPositions1.Positions.Count - 1; AInterfPositions1.Positions.Delete(l); end; AInterfPositions1.DefineKolvo; end else if AInterfPositions2.Positions.Count > AInterfPositions1.Positions.Count then begin While AInterfPositions2.Positions.Count <> AInterfPositions1.Positions.Count do begin l := AInterfPositions2.Positions.Count - 1; AInterfPositions2.Positions.Delete(l); end; AInterfPositions2.DefineKolvo; end; ConnectIDCompRel := DefineIDComponRel(LineCompon, PointCompon); // До того как соединить интерфейсы, нужно соединить сами компоненты if LineCompon.JoinedComponents.IndexOf(PointCompon) = -1 then begin TempInterfaces1 := TSCSInterfaces.Create(false); TempInterfaces2 := TSCSInterfaces.Create(false); if TF_Main(LineCompon.ActiveForm).F_ChoiceConnectSide.JoinWithDefineSides(LineCompon, PointCompon, false, TempInterfaces1, TempInterfaces2, true).CanConnect then; FreeAndNil(TempInterfaces1); FreeAndNil(TempInterfaces2); end; if LineCompon.JoinedComponents.IndexOf(PointCompon) <> -1 then begin ptrConnection := LineCompon.GetConnectionByConnected(PointCompon); if ptrConnection <> nil then begin TempInterfaces1 := TSCSInterfaces.Create(false); TempInterfaces2 := TSCSInterfaces.Create(false); TempInterfaces1.Add(ALineInterFace); TempInterfaces2.Add(APointInterFace); InterfCount := AInterfPositions1.Kolvo; if InterfCount > AInterfPositions2.Kolvo then InterfCount := AInterfPositions2.Kolvo; TF_Main(LineCompon.ActiveForm).ConnectInterfacesWithAccordance(ALineInterFace, APointInterFace, InterfCount, InterfCount, ptrConnection.ID, cntUnion, AInterfPositions1, AInterfPositions2, true, TempInterfaces1, TempInterfaces2); TF_Main(LineCompon.ActiveForm).F_ChoiceConnectSide.OnAfterJoinCompons(LineCompon, PointCompon, -1, -1); end; end; end; end; end; SavedLineComponList.Clear; SavedPointComponList.Clear; FreeAndNil(SavedLineComponList); FreeAndNil(SavedPointComponList); Inc(i,2); end; end; if InterFaceAccordanceList <> nil then begin InterFaceAccordanceList.clear; FreeAndNil(InterFaceAccordanceList); end; end; end; end; end; end; end; SavedLineConnectionsList.Remove(SelfLineConnectInfo); FreeAndNil(SelfLineConnectInfo); end; end; end; Function CanNotSnapConnToVLine: Boolean; var i, j: Integer; NB_Conn, JoinedConn: TConnectorObject; JoinedLine: TOrthoLine; begin Result := False; if AConnector.JoinedConnectorsList.Count = 0 then begin for i := 0 to AConnector.JoinedOrthoLinesList.Count - 1 do begin JoinedLine := TOrthoLine(AConnector.JoinedOrthoLinesList[i]); if (JoinedLine.FisVertical or JoinedLine.FisRaiseUpDown) then begin GCadForm.mProtocol.Lines.Add(cCadClasses_Mes11_7); Result := True; break; end; end; end else begin NB_Conn := TConnectorObject(AConnector.JoinedconnectorsList[0]); for i := 0 to NB_Conn.JoinedConnectorsList.Count - 1 do begin JoinedConn := TConnectorObject(NB_Conn.JoinedConnectorsList[i]); for j := 0 to JoinedConn.JoinedOrthoLinesList.Count - 1 do begin JoinedLine := TOrthoLine(Joinedconn.JoinedOrthoLinesList[j]); if (JoinedLine.FisVertical or JoinedLine.FisRaiseUpDown) then begin GCadForm.mProtocol.Lines.Add(cCadClasses_Mes11_7); Result := True; break; end; end; if Result then break; end; end; end; // begin if CanNotSnapConnToVLine then exit; NB_Conn := nil; CreatedConn := Nil; ObjToDisconnect := nil; try GetOtherConn := nil; //#From Oleg# SavedLineConnectionsList := TList.Create; SavedComponList := TList.Create; // Tolik 19/11/2019 -- if AConnector.ConnectorType = ct_Clear then // если есть присоединенный точечный, то на нем должно быть 2 коннектора от присоединенных трасс!!!! if AConnector.JoinedConnectorsList.Count > 0 then begin NB_Conn := TConnectorObject(AConnector.JoinedConnectorsList[0]); CreatedConn := TConnectorObject.Create(AConnector.ap1.x, AConnector.ap1.y, AConnector.ActualZOrder[1], AConnector.LayerHandle, mydsNormal, GCadForm.PCad); CreatedConn.ConnectorType := ct_Clear; GCadForm.PCad.AddCustomFigure (GLN(AConnector.LayerHandle), CreatedConn, False); CreatedConn.Name := cCadClasses_Mes12; ObjParams := GetFigureParams(CreateDConn.ID); CreatedConn.Name := ObjParams.Name; CreatedConn.FIndex := ObjParams.MarkID; NB_Conn.JoinedConnectorsList.Add(CreatedConn); CreatedConn.JoinedConnectorsList.Add(NB_Conn) end; ComponToDeleteList := TSCSComponents.Create(False); deltax := ASnapLine.ActualPoints[1].x - AConnector.ActualPoints[1].x; deltay := ASnapLine.ActualPoints[1].y - AConnector.ActualPoints[1].y; if ((deltax <> 0) or (deltay <> 0)) then AConnector.MoveConnector(deltax, deltay, false, true); // получить лист с присоединенными объектами стороны 2 JoinedConn := TConnectorObject(ASnapLine.JoinConnector2); ObjToDisconnect := TList.Create; if JoinedConn.JoinedConnectorsList.Count > 0 then ObjToDisconnect.Add(JoinedConn.JoinedConnectorsList[0]) else begin for i := 0 to JoinedConn.JoinedOrtholinesList.Count - 1 do if TOrthoLine(JoinedConn.JoinedOrtholinesList[i]) <> ASnapLine then ObjToDisconnect.Add(JoinedConn.JoinedOrtholinesList[i]); end; // Tolik -- попытаться сохранить состояние соединения до ... // если был точечный -- сохраняем на точечном if CanSaveConnections then begin DivLineObject := F_ProjMan.GSCSBase.CurrProject.CurrList.GetCatalogFromReferencesBySCSID(ASnapLine.Id); if DivLineObject <> nil then begin for i := 0 to DivLineObject.ComponentReferences.Count - 1 do begin LineCompon := TSCSComponent(DivLineObject.ComponentReferences[i]); if IsCableComponent(LineCompon) then CheckSaveLineConnectionsBySide(ASnapLine, LineCompon, 2); end; end; end; // {--------------------------------------------------------------} if aOnObjectHeight then DeltaPos := AConnector.ActualZOrder[1] else begin if (ASnapLine.ActualZOrder[2] > AConnector.ActualZOrder[1]) and (ASnapLine.ActualZOrder[1] < AConnector.ActualZOrder[1]) then DeltaPos := AConnector.ActualZOrder[1] else DeltaPos := (ASnapLine.ActualZOrder[1] + ASnapLine.ActualZOrder[2]) / 2; end; //Tolik 06/10/2021 -- //NextConnector := TConnectorObject(ASnapLine.JoinConnector2); if CompareValue(TConnectorObject(ASnapLine.JoinConnector2).ActualZOrder[1], aConnector.ActualZOrder[1]) = 1 then NextConnector := TConnectorObject(ASnapLine.JoinConnector2) else NextConnector := TConnectorObject(ASnapLine.JoinConnector1); // // вычисление точек модификации Modx := AConnector.ActualPoints[1].x; Mody := AConnector.ActualPoints[1].y; Modz := AConnector.ActualZOrder[1]; NextModx := NextConnector.ActualPoints[1].x; NextMody := NextConnector.ActualPoints[1].y; NextModz := NextConnector.ActualZOrder[1]; // При соединении конектора с линией, создается 2 линии // переназначение связей линии к которой присоединились новому коннектору //Tolik 06/10/2021 -- //ASnapLine.ActualPoints[2] := DoublePoint(Modx, Mody); //ASnapLine.ActualZOrder[1] := Modz; ASnapLine.ActualPoints[2] := DoublePoint(Modx, Mody); ASnapLine.ActualPoints[1] := DoublePoint(Modx, Mody); if ASnapLine.JoinConnector1.Id = NextConnector.ID then begin ASnapLine.SetJConnector1(AConnector); //ASnapLine.ActualPoints[2] := DoublePoint(Modx, Mody); //ASnapLine.ActualZOrder[1] := Modz; end else begin ASnapLine.SetJConnector2(AConnector); //ASnapLine.ActualPoints[2] := DoublePoint(Modx, Mody); //ASnapLine.ActualZOrder[1] := Modz; end; // //Tolik 06/10/2021 -- //ASnapLine.SetJConnector2(AConnector); TConnectorObject(NextConnector).JoinedOrtholinesList.Remove(ASnapLine); // добавить новую ортолинию TempDefaultNum := GDefaultNum; GDefaultNum := ASnapLine.FCount; GDefaultGap := ASnapLine.FGap; AddLine := TOrthoLine.Create(Modx, Mody, Modz, NextModx, NextMody, NextModz, 1,ord(psSolid), clBlack, 0, ASnapLine.LayerHandle, mydsNormal, GCadForm.PCad); GCadForm.PCad.AddCustomFigure (GLN(ASnapLine.LayerHandle), AddLine, false); AddLine.Name := cCadClasses_Mes32; SetNewObjectNameInPM(AddLine.ID, AddLine.Name); ObjParams := GetFigureParams(AddLine.ID); AddLine.Name := ObjParams.Name; AddLine.FIndex := ObjParams.MarkID; AddLine.FIsVertical := True; GDefaultNum := TempDefaultNum; if CreatedConn = nil then AddLine.SetJConnector1(AConnector) else AddLine.SetJConnector1(CreatedConn); AddLine.SetJConnector2(NextConnector); //Tolik 06/10/2021 -- //AConnector.ActualZOrder[1] := DeltaPos; //ASnapLine.ActualZOrder[2] := AConnector.ActualZOrder[1]; AddLine.ActualZOrder[1] := AConnector.ActualZOrder[1]; // перерасчет длины новой линии ASnapLine.CalculLength := ASnapLine.LengthCalc; ASnapLine.LineLength := ASnapLine.CalculLength; ASnapLine.UpdateLengthTextBox(false, true); SetLineFigureLengthInPM(ASnapLine.ID, ASnapLine.LineLength); // передвинуть TextBoxesGroup if ASnapLine.CaptionsGroup <> nil then begin CP_Line.x := (ASnapLine.ActualPoints[1].x + ASnapLine.ActualPoints[2].x) / 2; CP_Line.y := (ASnapLine.ActualPoints[1].y + ASnapLine.ActualPoints[2].y) / 2; ASnapLine.CaptionsGroup.Move(CP_Line.x - ASnapLine.CaptionsGroup.CenterPoint.x, CP_Line.y - ASnapLine.CaptionsGroup.CenterPoint.y); end; // перерасчет длины созданной линии AddLine.CalculLength := AddLine.LengthCalc; AddLine.LineLength := AddLine.CalculLength; AddLine.UpdateLengthTextBox(false, false); SetLineFigureLengthInPM(AddLine.ID, AddLine.LineLength); // передвинуть TextBoxesGroup if AddLine.CaptionsGroup <> nil then begin CP_Line.x := (AddLine.ActualPoints[1].x + AddLine.ActualPoints[2].x) / 2; CP_Line.y := (AddLine.ActualPoints[1].y + AddLine.ActualPoints[2].y) / 2; AddLine.CaptionsGroup.Move(CP_Line.x - AddLine.CaptionsGroup.CenterPoint.x, CP_Line.y - AddLine.CaptionsGroup.CenterPoint.y); end; GFigureSnap := Nil; // выровнять линии ReAlignObject(AConnector); ReAlignLine(ASnapLine); ReAlignLine(AddLine); SetConnBringToFront(AConnector); ReCalcZCoordSnapObjects(AConnector); // Протокол GCadForm.mProtocol.Lines.Add(cEndPoints_Mes1 + AConnector.Name + cCommon_Mes1 + ASnapLine.Name + '"'); // продолжить трассу на новый отрезок if CreatedConn = nil then begin if AddLine.JoinConnector1 = AConnector then begin GetOtherConn := TConnectorObject(AddLine.JoinConnector2); if GetOtherConn.JoinedConnectorsList.Count > 0 then GetOtherConn := TConnectorObject(GetOtherConn.JoinedConnectorsList[0]); end; if AddLine.JoinConnector2 = AConnector then begin GetOtherConn := TConnectorObject(AddLine.JoinConnector1); if GetOtherConn.JoinedConnectorsList.Count > 0 then GetOtherConn := TConnectorObject(GetOtherConn.JoinedConnectorsList[0]); end; end else begin if AddLine.JoinConnector1 = CreatedConn then begin GetOtherConn := TConnectorObject(AddLine.JoinConnector2); if GetOtherConn.JoinedConnectorsList.Count > 0 then GetOtherConn := TConnectorObject(GetOtherConn.JoinedConnectorsList[0]); end; if AddLine.JoinConnector2 = CreatedConn then begin GetOtherConn := TConnectorObject(AddLine.JoinConnector1); if GetOtherConn.JoinedConnectorsList.Count > 0 then GetOtherConn := TConnectorObject(GetOtherConn.JoinedConnectorsList[0]); end; end; // Tolik 30/08/2016 -- if not aOnObjectHeight then AutoConnectOverDivideLine(AConnector, GetOtherConn, ASnapLine, AddLine); //AutoConnectOverDivideLine(GetOtherConn, AConnector, AddLine); // !!! AddLine.FTraceColor := ASnapLine.FTraceColor; AddLine.FTraceStyle := ASnapLine.FTraceStyle; AddLine.FTraceWidth := ASnapLine.FTraceWidth; AddLine.FLineType := ASnapLine.FLineType; AddLine.FDrawFigurePercent := ASnapLine.FDrawFigurePercent; AddLine.BlockStep := ASnapLine.BlockStep; AddLine.DrawFigureH := 0; AddLine.CaptionsGroupH := 0; ASnapLine.DrawFigureH := 0; ASnapLine.CaptionsGroupH := 0; ASnapLine.ReCreateCaptionsGroup(false, false); ASnapLine.ReCreateNotesGroup; ASnapLine.ReCreateDrawFigureBlock; AddLine.ReCreateCaptionsGroup(false, false); AddLine.ReCreateNotesGroup; AddLine.ReCreateDrawFigureBlock; AddLine.ShowCaptions := False; AddLine.ShowNotes := False; AddLine.IsShowBlock := False; AddLine.FIsVertical := True; if ObjToDisconnect <> nil then FreeAndNil(ObjToDisconnect); AddLine.FTraceColor := ASnapLine.FTraceColor; AddLine.FTraceStyle := ASnapLine.FTraceStyle; AddLine.FTraceWidth := ASnapLine.FTraceWidth; AddLine.FLineType := ASnapLine.FLineType; AddLine.FDrawFigurePercent := ASnapLine.FDrawFigurePercent; if CanSaveConnections then begin //Tolik -- восстановить соединение кабелей как было //Сбросить соединения кабелей с точечными объектами на втором конце старой трассы перед восстановлением состояния подключения DivLineObject := F_ProjMan.GSCSBase.CurrProject.CurrList.GetCatalogFromReferencesBySCSID(ASnapLine.Id); if DivLineObject <> nil then begin for i := 0 to DivLineObject.ComponentReferences.Count - 1 do begin LineCompon := DivLineObject.ComponentReferences[i]; //14/05/2016 -- //if LineCompon.ComponentType.SysName = ctsnCable then if IsCableComponent(LineCompon) then begin CanContinue := True; While CanContinue do begin CanContinue := False; for j := 0 to LineCompon.Interfaces.Count - 1 do begin if (TSCSInterface(LineCompon.Interfaces[j]).TypeI = itFunctional) and (TSCSInterface(LineCompon.Interfaces[j]).Side = 2) then begin for k := 0 to TSCSInterface(LineCompon.Interfaces[j]).BusyPositions.Count - 1 do begin InterfPosition := TSCSInterface(LineCompon.Interfaces[j]).BusyPositions[k]; JoinedPosition := InterfPosition.GetConnectedPos; if (JoinedPosition <> nil) and (JoinedPosition.InterfOwner <> nil) and (JoinedPosition.InterfOwner.ComponentOwner <> nil) then begin JoinedComponent := TSCSComponent(JoinedPosition.InterfOwner.ComponentOwner); CanContinue := True; LineCompon.DisJoinFrom(JoinedComponent); break; end; end; if CanContinue then break; end; end; end; end; end; end; // Restore Connection //DivLineObject := F_ProjMan.GSCSBase.CurrProject.CurrList.GetCatalogFromReferencesBySCSID(ASnapLine.Id); if DivLineObject <> nil then begin for i := 0 to DivLineObject.ComponentReferences.Count - 1 do begin LineCompon := TSCSComponent(DivLineObject.ComponentReferences[i]); if IsCableComponent(LineCompon) then RestoreLineConnectionsBySide(ASnapLine, LineCompon, 2); end; end; end; FreeAndNil(SavedLineConnectionsList); FreeAndNil(ComponToDeleteList); FreeAndNil(SavedComponList); { if InterFaceAccordanceList <> nil then begin InterFaceAccordanceList.clear; FreeAndNil(InterFaceAccordanceList); end; } //Tolik 11/11/2021 AutoConnectOverDivideLine(AConnector, GetOtherConn, ASnapLine, AddLine, nil); //AutoConnectOverDivideLine(GetOtherConn, AConnector, AddLine); // RefreshCAD(GCadForm.PCad); except on E: Exception do AddExceptionToLogEx('U_Common.SnapConnectorToVertical', E.Message); end; end; (* procedure SnapConnectorToVertical(AConnector: TConnectorObject; ASnapLine: TOrtholine; aOnObjectHeight: Boolean = False); var i, j, k, l, m: integer; AddLine: TOrthoLine; NextConnector: TConnectorObject; Modx, Mody, Modz, NextModx, NextMody, NextModz: Double; TempDefaultNum: integer; CP_Line: TDoublePoint; // DeltaPos: Double; JoinedConn: TConnectorObject; ObjToDisconnect: TList; GetOtherConn: TConnectorObject; ObjParams: TObjectParams; // Tolik -- 17/05/2016-- SavedLineComponList, SavedPointComponList: TList; DivLineObject, JoinedPointObject: TSCSCatalog; PointCompon: TSCSComponent; NBConnector: TConnectorObject; InterfRel : TSCSIOfIRel; InterfPosition, JoinedPosition: TSCSInterfPosition; LineCompon: TSCSComponent; ALineInterFace, APointInterFace, aTempInterf: TSCSInterface; LineInterfList: TList; ConnComponList: TList; AInterfPositions1, AInterfPositions2: TSCSInterfPositions; LineComponInterFace, PointComponInterFace: TSCSInterFace; InterFaceAccordanceList: TList; APointInterfID: Integer; ConnectedInterFaces: TSCSIOfIRel; ConnectIDCompRel: Integer; TempInterfaces1, TempInterfaces2: TSCSInterfaces; InterfCount: Integer; ptrConnection: PComplect; DisJoinList: TList; NewConn: TConnectorObject; Function GetNBConnector(aObj: TConnectorObject): TConnectorObject; var i: Integer; begin Result := nil; if aObj.ConnectorType = ct_NB then Result := aObj else begin for i := 0 to aObj.JoinedConnectorsList.Count - 1 do begin if TConnectorObject(aObj.JoinedConnectorsList[i]).ConnectorType = ct_NB then begin Result := TConnectorObject(aObj.JoinedConnectorsList[i]); break; end; end; end; end; Function GetInterfaceForConnection(AInterf: TSCSInterFace): TSCSInterFace; var i, j, k: Integer; LineCompon: TSCSComponent; SourceLineCatalog, DestLineCatalog: TSCSCatalog; ConnectionSide : Integer; TmpInterfPos: TSCSInterfPosition; begin Result := nil; LineCompon := AInterf.ComponentOwner; if LineCompon <> nil then begin SourceLineCatalog := F_ProjMan.GSCSBase.CurrProject.CurrList.GetCatalogFromReferencesBySCSID(ASnapLine.ID); if SourceLineCatalog <> nil then begin for i := 0 to SourceLineCatalog.ComponentReferences.Count - 1 do begin if (TSCSComponent(SourceLineCatalog.ComponentReferences[i]).ID = LineCompon.ID) then begin DestLineCatalog := F_ProjMan.GSCSBase.CurrProject.CurrList.GetCatalogFromReferencesBySCSID(AddLine.ID); if DestLineCatalog <> nil then begin if i <= (DestLineCatalog.ComponentReferences.Count - 1) then begin LineCompon := DestLineCatalog.ComponentReferences[i]; if LineCompon <> nil then begin // Difining ConnectionSide { for j := 0 to LineCompon.Interfaces.Count - 1 do begin ConnectionSide := 2; if TSCSInterface(LineCompon.Interfaces[j]).TypeI = itFunctional then if TSCSInterface(LineCompon.Interfaces[j]).BusyPositions.Count > 0 then begin for k := 0 to TSCSInterface(LineCompon.Interfaces[j]).BusyPositions.Count - 1 do begin TmpInterfPos := TSCSInterface(LineCompon.Interfaces[j]).BusyPositions[k]; TmpInterfPos := TmpInterfPos.GetConnectedPos; if TSCSComponent(TmpInterfPos.InterfOwner.ComponentOwner).IsLine = biTrue then begin if TmpInterfPos.InterfOwner.Side = 2 then ConnectionSide := 1; break; end; end; end; end;} for j := 0 to LineCompon.Interfaces.Count - 1 do begin if TSCSInterface(LineCompon.Interfaces[j]).TypeI = itFunctional then if TSCSInterface(LineCompon.Interfaces[j]).Npp = AInterf.Npp then // if TSCSInterface(LineCompon.Interfaces[j]).Side = 2 then if ((TSCSInterface(LineCompon.Interfaces[j]).IsBusy = biFalse) or (TSCSInterface(LineCompon.Interfaces[j]).BusyPositions.Count = 0)) then begin Result := TSCSInterface(LineCompon.Interfaces[j]); break; end; end; end; end; end; Break; //// BREAK ////; end; end; end; end; end; Function DefineIDComponRel(ALineCompon, APointCompon: TSCSComponent): Integer; var TopCatalog: TSCSCatalog; begin Result := -1; begin TopCatalog := aLineCompon.GetTopParentCatalog; if TopCatalog <> nil then if TopCatalog is TSCSProject then Result := TSCSProject(TopCatalog).GenIDByGeneratorIndex(giComponentRelationID, 1); end; //if IDComponRel = -1 then //IDComponRel := TF_Main(ActiveForm).AppendToComponRel(Self.ID, AComponent.ID, 1, AConnectType); end; // begin try GetOtherConn := nil; //#From Oleg# AConnector.MoveConnector(ASnapLine.ActualPoints[1].x - AConnector.ActualPoints[1].x, ASnapLine.ActualPoints[1].y - AConnector.ActualPoints[1].y, false, true); // получить лист с присоединенными объектами стороны 2 JoinedConn := TConnectorObject(ASnapLine.JoinConnector2); ObjToDisconnect := TList.Create; if JoinedConn.JoinedConnectorsList.Count > 0 then ObjToDisconnect.Add(JoinedConn.JoinedConnectorsList[0]) else begin for i := 0 to JoinedConn.JoinedOrtholinesList.Count - 1 do if TOrthoLine(JoinedConn.JoinedOrtholinesList[i]) <> ASnapLine then ObjToDisconnect.Add(JoinedConn.JoinedOrtholinesList[i]); end; // Tolik -- попытаться сохранить состояние соединения до ... if (ObjToDisConnect.Count = 1) and (CheckFigurebyClassName(TFigure(ObjToDisConnect[0]), cTConnectorObject)) then begin NBConnector := GetNBConnector(JoinedConn); if NBConnector <> nil then begin JoinedPointObject := F_ProjMan.GSCSBase.CurrProject.CurrList.GetCatalogFromReferencesBySCSID(NBConnector.Id); DivLineObject := F_ProjMan.GSCSBase.CurrProject.CurrList.GetCatalogFromReferencesBySCSID(ASnapLine.Id); if (JoinedPointObject <> nil) and (DivLineObject <> nil) then begin if ((JoinedPointObject.ComponentReferences.Count > 0) and (DivLineObject.ComponentReferences.Count > 0)) then begin InterFaceAccordanceList := TList.Create; LineInterfList := TList.Create; for j := 0 to DivLineObject.ComponentReferences.Count - 1 do begin LineCompon := DivLineObject.ComponentReferences[j]; // 14/05/2016 // if LineCompon.ComponentType.SysName = ctsnCable then if IsCableComponent(LineCompon) then // так правильнее -- для всех кабелей // begin if CheckJoinedComponToComponFromObject(LineCompon, JoinedPointObject) then begin for k := 0 to LineCompon.Interfaces.count - 1 do begin if (LineCompon.Interfaces[k].TypeI = itFunctional) and (LineCompon.Interfaces[k].Side = 2) and ((LineCompon.Interfaces[k].IsBusy = biTrue) or (LineCompon.Interfaces[k].BusyPositions.Count > 0)) then begin SavedLineComponList := TList.Create; SavedPointComponList := TList.Create; ALineInterFace := LineCompon.Interfaces.Items[k]; { if SavedLineComponList.IndexOf(LineCompon.Interfaces[k]) = -1 then SavedLineComponList.Add(TSCSInterFace(LineCompon.Interfaces[k]));} if SavedLineComponList.IndexOf(ALineInterFace) = -1 then SavedLineComponList.Add(TObject(ALineInterFace)); l := SavedLineComponList.IndexOf(ALineInterFace); aTempInterf := TSCSInterface(SavedLineComponList[l]); APointInterfID := -1; for l := 0 to ALineInterFace.BusyPositions.Count - 1 do begin InterfPosition := ALineInterFace.BusyPositions[l]; JoinedPosition := InterfPosition.GetConnectedPos; if JoinedPosition <> nil then begin if JoinedPosition.InterfOwner <> nil then begin if SavedPointComponList.IndexOf(JoinedPosition.InterfOwner) = -1 then SavedPointComponList.Add(TSCSInterFace(JoinedPosition.InterfOwner)); end; end; end; if ((SavedLineComponList.Count > 0) and (SavedPointComponList.Count > 0)) then begin InterFaceAccordanceList.Add(SavedLineComponList); InterFaceAccordanceList.Add(SavedPointComponList); end else begin SavedLineComponList.Clear; SavedPointComponList.Clear; FreeAndNil(SavedLineComponList); FreeAndNil(SavedPointComponList); end; end; end; end; end; end; end; end; end; end; // {--------------------------------------------------------------} if aOnObjectHeight then DeltaPos := AConnector.ActualZOrder[1] else begin if (ASnapLine.ActualZOrder[2] > AConnector.ActualZOrder[1]) and (ASnapLine.ActualZOrder[1] < AConnector.ActualZOrder[1]) then DeltaPos := AConnector.ActualZOrder[1] else DeltaPos := (ASnapLine.ActualZOrder[1] + ASnapLine.ActualZOrder[2]) / 2; end; NextConnector := TConnectorObject(ASnapLine.JoinConnector2); // вычисление точек модификации Modx := AConnector.ActualPoints[1].x; Mody := AConnector.ActualPoints[1].y; Modz := AConnector.ActualZOrder[1]; NextModx := NextConnector.ActualPoints[1].x; NextMody := NextConnector.ActualPoints[1].y; NextModz := NextConnector.ActualZOrder[1]; // При соединении конектора с линией, создается 2 линии // переназначение связей линии к которой присоединились новому коннектору ASnapLine.ActualPoints[2] := DoublePoint(Modx, Mody); ASnapLine.ActualZOrder[1] := Modz; ASnapLine.SetJConnector2(AConnector); TConnectorObject(NextConnector).JoinedOrtholinesList.Remove(ASnapLine); // добавить новую ортолинию TempDefaultNum := GDefaultNum; GDefaultNum := ASnapLine.FCount; GDefaultGap := ASnapLine.FGap; AddLine := TOrthoLine.Create(Modx, Mody, Modz, NextModx, NextMody, NextModz, 1,ord(psSolid), clBlack, 0, ASnapLine.LayerHandle, mydsNormal, GCadForm.PCad); GCadForm.PCad.AddCustomFigure (GLN(ASnapLine.LayerHandle), AddLine, false); AddLine.Name := cCadClasses_Mes32; SetNewObjectNameInPM(AddLine.ID, AddLine.Name); ObjParams := GetFigureParams(AddLine.ID); AddLine.Name := ObjParams.Name; AddLine.FIndex := ObjParams.MarkID; AddLine.FIsVertical := True; GDefaultNum := TempDefaultNum; AddLine.SetJConnector1(AConnector); AddLine.SetJConnector2(NextConnector); AConnector.ActualZOrder[1] := DeltaPos; ASnapLine.ActualZOrder[2] := AConnector.ActualZOrder[1]; AddLine.ActualZOrder[1] := AConnector.ActualZOrder[1]; // перерасчет длины новой линии ASnapLine.CalculLength := ASnapLine.LengthCalc; ASnapLine.LineLength := ASnapLine.CalculLength; ASnapLine.UpdateLengthTextBox(false, true); SetLineFigureLengthInPM(ASnapLine.ID, ASnapLine.LineLength); // передвинуть TextBoxesGroup if ASnapLine.CaptionsGroup <> nil then begin CP_Line.x := (ASnapLine.ActualPoints[1].x + ASnapLine.ActualPoints[2].x) / 2; CP_Line.y := (ASnapLine.ActualPoints[1].y + ASnapLine.ActualPoints[2].y) / 2; ASnapLine.CaptionsGroup.Move(CP_Line.x - ASnapLine.CaptionsGroup.CenterPoint.x, CP_Line.y - ASnapLine.CaptionsGroup.CenterPoint.y); end; // перерасчет длины созданной линии AddLine.CalculLength := AddLine.LengthCalc; AddLine.LineLength := AddLine.CalculLength; AddLine.UpdateLengthTextBox(false, false); SetLineFigureLengthInPM(AddLine.ID, AddLine.LineLength); // передвинуть TextBoxesGroup if AddLine.CaptionsGroup <> nil then begin CP_Line.x := (AddLine.ActualPoints[1].x + AddLine.ActualPoints[2].x) / 2; CP_Line.y := (AddLine.ActualPoints[1].y + AddLine.ActualPoints[2].y) / 2; AddLine.CaptionsGroup.Move(CP_Line.x - AddLine.CaptionsGroup.CenterPoint.x, CP_Line.y - AddLine.CaptionsGroup.CenterPoint.y); end; GFigureSnap := Nil; // выровнять линии ReAlignObject(AConnector); ReAlignLine(ASnapLine); ReAlignLine(AddLine); SetConnBringToFront(AConnector); ReCalcZCoordSnapObjects(AConnector); // Протокол GCadForm.mProtocol.Lines.Add(cEndPoints_Mes1 + AConnector.Name + cCommon_Mes1 + ASnapLine.Name + '"'); // продолжить трассу на новый отрезок if AddLine.JoinConnector1 = AConnector then begin GetOtherConn := TConnectorObject(AddLine.JoinConnector2); if GetOtherConn.JoinedConnectorsList.Count > 0 then GetOtherConn := TConnectorObject(GetOtherConn.JoinedConnectorsList[0]); end; if AddLine.JoinConnector2 = AConnector then begin GetOtherConn := TConnectorObject(AddLine.JoinConnector1); if GetOtherConn.JoinedConnectorsList.Count > 0 then GetOtherConn := TConnectorObject(GetOtherConn.JoinedConnectorsList[0]); end; // Tolik 30/08/2016 -- if not aOnObjectHeight then AutoConnectOverDivideLine(AConnector, GetOtherConn, ASnapLine, AddLine); //AutoConnectOverDivideLine(GetOtherConn, AConnector, AddLine); // !!! AddLine.FTraceColor := ASnapLine.FTraceColor; AddLine.FTraceStyle := ASnapLine.FTraceStyle; AddLine.FTraceWidth := ASnapLine.FTraceWidth; AddLine.FLineType := ASnapLine.FLineType; AddLine.FDrawFigurePercent := ASnapLine.FDrawFigurePercent; AddLine.BlockStep := ASnapLine.BlockStep; AddLine.DrawFigureH := 0; AddLine.CaptionsGroupH := 0; ASnapLine.DrawFigureH := 0; ASnapLine.CaptionsGroupH := 0; ASnapLine.ReCreateCaptionsGroup(false, false); ASnapLine.ReCreateNotesGroup; ASnapLine.ReCreateDrawFigureBlock; AddLine.ReCreateCaptionsGroup(false, false); AddLine.ReCreateNotesGroup; AddLine.ReCreateDrawFigureBlock; AddLine.ShowCaptions := False; AddLine.ShowNotes := False; AddLine.IsShowBlock := False; AddLine.FIsVertical := True; if ObjToDisconnect <> nil then FreeAndNil(ObjToDisconnect); AddLine.FTraceColor := ASnapLine.FTraceColor; AddLine.FTraceStyle := ASnapLine.FTraceStyle; AddLine.FTraceWidth := ASnapLine.FTraceWidth; AddLine.FLineType := ASnapLine.FLineType; AddLine.FDrawFigurePercent := ASnapLine.FDrawFigurePercent; //Tolik -- восстановить соединение кабелей как было //Сбросить соединения кабелей с точечными объектами на втором конце новой трассы перед восстановлением состояния подключения DivLineObject := F_ProjMan.GSCSBase.CurrProject.CurrList.GetCatalogFromReferencesBySCSID(AddLine.Id); if DivLineObject <> nil then begin for i := 0 to DivLineObject.ComponentReferences.Count - 1 do begin LineCompon := DivLineObject.ComponentReferences[i]; //14/05/2016 -- //if LineCompon.ComponentType.SysName = ctsnCable then if IsCableComponent(LineCompon) then // begin for j := LineCompon.JoinedComponents.Count - 1 downto 0 do begin PointCompon := LineCompon.JoinedComponents[j]; if PointCompon.IsLine = biFalse then LineCompon.DisJoinFrom(PointCompon); end; end; end; end; // Restore Connection if ((InterFaceAccordanceList <> nil) and (InterFaceAccordanceList.Count > 0)) then begin i := 0; While (i <= (InterFaceAccordanceList.Count - 1)) do begin SavedLineComponList := TList(InterFaceAccordanceList[i]); SavedPointComponList := TList(InterFaceAccordanceList[i + 1]); for j := 0 to SavedLineComponList.Count - 1 do begin aTempInterf := TSCSInterface(SavedLineComponList[j]); ALineInterFace := GetInterfaceForConnection(aTempInterf); LineCompon := ALineInterFace.ComponentOwner; if ALineInterFace <> nil then begin for k := 0 to SavedPointComponList.Count - 1 do begin APointInterFace := TSCSInterface(SavedPointComponList[k]); PointCompon := APointInterFace.ComponentOwner; AInterfPositions1 := ALineInterFace.GetEmptyPositions; AInterfPositions2 := APointInterFace.GetEmptyPositions; // уравнять количество позиций для соединения if AInterfPositions1.Positions.Count > AInterfPositions2.Positions.Count then begin While AInterfPositions1.Positions.Count <> AInterfPositions2.Positions.Count do begin l := AInterfPositions1.Positions.Count - 1; AInterfPositions1.Positions.Delete(l); end; AInterfPositions1.DefineKolvo; end else if AInterfPositions2.Positions.Count > AInterfPositions1.Positions.Count then begin While AInterfPositions2.Positions.Count <> AInterfPositions1.Positions.Count do begin l := AInterfPositions2.Positions.Count - 1; AInterfPositions2.Positions.Delete(l); end; AInterfPositions2.DefineKolvo; end; ConnectIDCompRel := DefineIDComponRel(LineCompon, PointCompon); // До того как соединить интерфейсы, нужно соединить сами компоненты if LineCompon.JoinedComponents.IndexOf(PointCompon) = -1 then begin TempInterfaces1 := TSCSInterfaces.Create(false); TempInterfaces2 := TSCSInterfaces.Create(false); if TF_Main(LineCompon.ActiveForm).F_ChoiceConnectSide.JoinWithDefineSides(LineCompon, PointCompon, false, TempInterfaces1, TempInterfaces2, true).CanConnect then; FreeAndNil(TempInterfaces1); FreeAndNil(TempInterfaces2); end; if LineCompon.JoinedComponents.IndexOf(PointCompon) <> -1 then begin ptrConnection := LineCompon.GetConnectionByConnected(PointCompon); if ptrConnection <> nil then begin TempInterfaces1 := TSCSInterfaces.Create(false); TempInterfaces2 := TSCSInterfaces.Create(false); TempInterfaces1.Add(ALineInterFace); TempInterfaces2.Add(APointInterFace); InterfCount := AInterfPositions1.Kolvo; if InterfCount > AInterfPositions2.Kolvo then InterfCount := AInterfPositions2.Kolvo; TF_Main(LineCompon.ActiveForm).ConnectInterfacesWithAccordance(ALineInterFace, APointInterFace, InterfCount, InterfCount, ptrConnection.ID, cntUnion, AInterfPositions1, AInterfPositions2, true, TempInterfaces1, TempInterfaces2); TF_Main(LineCompon.ActiveForm).F_ChoiceConnectSide.OnAfterJoinCompons(LineCompon, PointCompon, -1, -1); end; end; (* ConnectedInterFaces := TF_MAIN(ALineInterFace.ActiveForm).ConnectInterfaces(ALineInterFace, APointInterFace, {ConnectIDCompRel} -1, cntUnion, AInterfPositions1, AInterfPositions2, False); TF_Main(LineCompon.ActiveForm).F_ChoiceConnectSide.OnAfterJoinCompons(LineCompon,PointCompon, -1, -1);}*) (* end; end; end; SavedLineComponList.Clear; SavedPointComponList.Clear; FreeAndNil(SavedLineComponList); FreeAndNil(SavedPointComponList); Inc(i,2); end; end; if InterFaceAccordanceList <> nil then begin InterFaceAccordanceList.clear; FreeAndNil(InterFaceAccordanceList); end; // RefreshCAD(GCadForm.PCad); except on E: Exception do AddExceptionToLogEx('U_Common.SnapConnectorToVertical', E.Message); end; end; *) // коннектор к вертикальной трассе (* procedure SnapConnectorToVertical(AConnector: TConnectorObject; ASnapLine: TOrtholine); var i, j: integer; AddLine: TOrthoLine; NextConnector: TConnectorObject; Modx, Mody, Modz, NextModx, NextMody, NextModz: Double; TempDefaultNum: integer; CP_Line: TDoublePoint; // DeltaPos: Double; JoinedConn: TConnectorObject; ObjToDisconnect: TList; GetOtherConn: TConnectorObject; ObjParams: TObjectParams; begin try GetOtherConn := nil; //#From Oleg# AConnector.MoveConnector(ASnapLine.ActualPoints[1].x - AConnector.ActualPoints[1].x, ASnapLine.ActualPoints[1].y - AConnector.ActualPoints[1].y, false, true); // получить лист с присоединенными объектами стороны 2 JoinedConn := TConnectorObject(ASnapLine.JoinConnector2); ObjToDisconnect := TList.Create; if JoinedConn.JoinedConnectorsList.Count > 0 then ObjToDisconnect.Add(JoinedConn.JoinedConnectorsList[0]) else begin for i := 0 to JoinedConn.JoinedOrtholinesList.Count - 1 do if TOrthoLine(JoinedConn.JoinedOrtholinesList[i]) <> ASnapLine then ObjToDisconnect.Add(JoinedConn.JoinedOrtholinesList[i]); end; {--------------------------------------------------------------} if (ASnapLine.ActualZOrder[2] > AConnector.ActualZOrder[1]) and (ASnapLine.ActualZOrder[1] < AConnector.ActualZOrder[1]) then DeltaPos := AConnector.ActualZOrder[1] else DeltaPos := (ASnapLine.ActualZOrder[1] + ASnapLine.ActualZOrder[2]) / 2; NextConnector := TConnectorObject(ASnapLine.JoinConnector2); // вычисление точек модификации Modx := AConnector.ActualPoints[1].x; Mody := AConnector.ActualPoints[1].y; Modz := AConnector.ActualZOrder[1]; NextModx := NextConnector.ActualPoints[1].x; NextMody := NextConnector.ActualPoints[1].y; NextModz := NextConnector.ActualZOrder[1]; // При соединении конектора с линией, создается 2 линии // переназначение связей линии к которой присоединились новому коннектору ASnapLine.ActualPoints[2] := DoublePoint(Modx, Mody); ASnapLine.ActualZOrder[1] := Modz; ASnapLine.SetJConnector2(AConnector); TConnectorObject(NextConnector).JoinedOrtholinesList.Remove(ASnapLine); // добавить новую ортолинию TempDefaultNum := GDefaultNum; GDefaultNum := ASnapLine.FCount; GDefaultGap := ASnapLine.FGap; AddLine := TOrthoLine.Create(Modx, Mody, Modz, NextModx, NextMody, NextModz, 1,ord(psSolid), clBlack, 0, ASnapLine.LayerHandle, mydsNormal, GCadForm.PCad); GCadForm.PCad.AddCustomFigure (GLN(ASnapLine.LayerHandle), AddLine, false); AddLine.Name := cCadClasses_Mes32; SetNewObjectNameInPM(AddLine.ID, AddLine.Name); ObjParams := GetFigureParams(AddLine.ID); AddLine.Name := ObjParams.Name; AddLine.FIndex := ObjParams.MarkID; AddLine.FIsVertical := True; GDefaultNum := TempDefaultNum; // присвоить связи новой ортолинии AddLine.SetJConnector1(AConnector); AddLine.SetJConnector2(NextConnector); AConnector.ActualZOrder[1] := DeltaPos; ASnapLine.ActualZOrder[2] := AConnector.ActualZOrder[1]; AddLine.ActualZOrder[1] := AConnector.ActualZOrder[1]; // перерасчет длины новой линии ASnapLine.CalculLength := ASnapLine.LengthCalc; ASnapLine.LineLength := ASnapLine.CalculLength; ASnapLine.UpdateLengthTextBox(false, true); SetLineFigureLengthInPM(ASnapLine.ID, ASnapLine.LineLength); // передвинуть TextBoxesGroup if ASnapLine.CaptionsGroup <> nil then begin CP_Line.x := (ASnapLine.ActualPoints[1].x + ASnapLine.ActualPoints[2].x) / 2; CP_Line.y := (ASnapLine.ActualPoints[1].y + ASnapLine.ActualPoints[2].y) / 2; ASnapLine.CaptionsGroup.Move(CP_Line.x - ASnapLine.CaptionsGroup.CenterPoint.x, CP_Line.y - ASnapLine.CaptionsGroup.CenterPoint.y); end; // перерасчет длины созданной линии AddLine.CalculLength := AddLine.LengthCalc; AddLine.LineLength := AddLine.CalculLength; AddLine.UpdateLengthTextBox(false, false); SetLineFigureLengthInPM(AddLine.ID, AddLine.LineLength); // передвинуть TextBoxesGroup if AddLine.CaptionsGroup <> nil then begin CP_Line.x := (AddLine.ActualPoints[1].x + AddLine.ActualPoints[2].x) / 2; CP_Line.y := (AddLine.ActualPoints[1].y + AddLine.ActualPoints[2].y) / 2; AddLine.CaptionsGroup.Move(CP_Line.x - AddLine.CaptionsGroup.CenterPoint.x, CP_Line.y - AddLine.CaptionsGroup.CenterPoint.y); end; GFigureSnap := Nil; // выровнять линии ReAlignObject(AConnector); ReAlignLine(ASnapLine); ReAlignLine(AddLine); SetConnBringToFront(AConnector); ReCalcZCoordSnapObjects(AConnector); // Протокол GCadForm.mProtocol.Lines.Add(cEndPoints_Mes1 + AConnector.Name + cCommon_Mes1 + ASnapLine.Name + '"'); // продолжить трассу на новый отрезок if AddLine.JoinConnector1 = AConnector then begin GetOtherConn := TConnectorObject(AddLine.JoinConnector2); if GetOtherConn.JoinedConnectorsList.Count > 0 then GetOtherConn := TConnectorObject(GetOtherConn.JoinedConnectorsList[0]); end; if AddLine.JoinConnector2 = AConnector then begin GetOtherConn := TConnectorObject(AddLine.JoinConnector1); if GetOtherConn.JoinedConnectorsList.Count > 0 then GetOtherConn := TConnectorObject(GetOtherConn.JoinedConnectorsList[0]); end; AutoConnectOverDivideLine(AConnector, GetOtherConn, ASnapLine, AddLine); //AutoConnectOverDivideLine(GetOtherConn, AConnector, AddLine); // !!! AddLine.FTraceColor := ASnapLine.FTraceColor; AddLine.FTraceStyle := ASnapLine.FTraceStyle; AddLine.FTraceWidth := ASnapLine.FTraceWidth; AddLine.FLineType := ASnapLine.FLineType; AddLine.FDrawFigurePercent := ASnapLine.FDrawFigurePercent; AddLine.BlockStep := ASnapLine.BlockStep; AddLine.DrawFigureH := 0; AddLine.CaptionsGroupH := 0; ASnapLine.DrawFigureH := 0; ASnapLine.CaptionsGroupH := 0; ASnapLine.ReCreateCaptionsGroup(false, false); ASnapLine.ReCreateNotesGroup; ASnapLine.ReCreateDrawFigureBlock; AddLine.ReCreateCaptionsGroup(false, false); AddLine.ReCreateNotesGroup; AddLine.ReCreateDrawFigureBlock; AddLine.ShowCaptions := False; AddLine.ShowNotes := False; AddLine.IsShowBlock := False; AddLine.FIsVertical := True; if ObjToDisconnect <> nil then FreeAndNil(ObjToDisconnect); AddLine.FTraceColor := ASnapLine.FTraceColor; AddLine.FTraceStyle := ASnapLine.FTraceStyle; AddLine.FTraceWidth := ASnapLine.FTraceWidth; AddLine.FLineType := ASnapLine.FLineType; AddLine.FDrawFigurePercent := ASnapLine.FDrawFigurePercent; RefreshCAD(GCadForm.PCad); except on E: Exception do AddExceptionToLogEx('U_Common.SnapConnectorToVertical', E.Message); end; end; *) //Tolik -- 10/04/2018 -- переписана наново через снап коннектора на линию, чтобы не дублировать функционал // Вчастности, для последующего восстановления кабельных соединений... procedure SnapPointObjectToOrthoLine(APointObject: TConnectorObject; ASnapLine: TOrthoLine); var i, j: integer; NewDeltaX, NewDeltaY: double; MustRealign: Boolean; AngleRad: double; AllLengthXY, DeltaHeight: Double; JoinedConn, ClearConn: TConnectorObject; SnapZ: Double; // высота, на которой объект попадает на трассу CadRefreshFlag: Boolean; RaiseLine, JoinedLine: TOrthoLine; RaiseLineCreated: Boolean; // вычисляет Z - координату "падения" точечного компонента на наклонную линию, // если координаты X, Y - известны Function GetCoordZ(ASnapFigure: TFigure; CoordX, CoordY: Double): Double; // Tolik 27/02/2018 Var vx, vy, vz, xx1, xx2, yy1, yy2, zz1, zz2, TempZ : Double; Begin Result := 0; //первая точка прямой xx1 := RounDX(TOrthoLine(ASnapFigure).JoinConnector1.ActualPoints[1].x,2); yy1 := RounDX(TOrthoLine(ASnapFigure).JoinConnector1.ActualPoints[1].y,2); zz1 := RounDX(TConnectorObject(TOrthoLine(ASnapFigure).JoinConnector1).ActualZOrder[1],2); //вторая точка прямой xx2 := RounDX(TOrthoLine(ASnapFigure).JoinConnector2.ActualPoints[1].x,2); yy2 := RounDX(TOrthoLine(ASnapFigure).JoinConnector2.ActualPoints[1].y,2); zz2 := RounDX(TConnectorObject(TOrthoLine(ASnapFigure).JoinConnector2).ActualZOrder[1],2); // направляющий вектор для прямой (координаты) vx := xx2 - xx1; vy := yy2 - yy1; vz := zz2 - zz1; if (vx <> 0) then begin Result := Roundx(((CoordX - xx1)/vx)*vz + zz1, 2); end else begin if (vy <> 0) then Result := RoundX(((CoordY - yy1)/vy)*vz + zz1, 2); end; End; Procedure SortLineList(aConn: TConnectorObject); // выставить первым райз(если есть) в списке присоединенных ортолиний на пустом коннекторе var i: Integer; begin if aConn.JoinedOrtholinesList.Count > 1 then begin for i := 1 to aConn.JoinedOrtholinesList.Count - 1 do begin if TOrthoLine(aConn.JoinedOrtholinesList[i]).FIsRaiseUpDown then begin aConn.JoinedOrtholinesList.Exchange(i,0); break; end; end; end; end; begin CadRefreshFlag := GCanRefreshCad; GCanRefreshCad := False; RaiseLineCreated := False; try // Tolik 09/07/2019 -- //if (IsSpecialTraceFigure(ASnapLine)) or (ASnapLine.FIsVertical) then if ((ASnapLine.FisRaiseUpDown) or (ASnapLine.FIsVertical)) then begin GCanRefreshCad := CadRefreshFlag; exit; end; //if (IsSpecialTraceFigure(ASnapLine)) or (ASnapLine.FIsVertical) then // exit; DeltaHeight := ASnapLine.ActualZOrder[2] - ASnapLine.ActualZOrder[1]; AllLengthXY := SQRT(SQR(ASnapLine.ActualPoints[1].x - ASnapLine.ActualPoints[2].x) + SQR(ASnapLine.ActualPoints[1].y - ASnapLine.ActualPoints[2].y)); // выравнивать линию? AngleRad := GetLineAngle(ASnapLine.ActualPoints[1], ASnapLine.ActualPoints[2]); if GCadForm.PCad.SnapToGrids then begin if (AngleRad = 0) or (AngleRad = 90) or (AngleRad = 180) or (AngleRad = 270) or (AngleRad = 360) then MustRealign := true else MustRealign := false; end else MustRealign := false; if ASnapLine.ActualPoints[1].x = ASnapLine.ActualPoints[2].x then begin NewDeltaY := 0; NewDeltaX := ASnapLine.ActualPoints[1].x - APointObject.ActualPoints[1].x; APointObject.ActualPoints[1] := DoublePoint(APointObject.ActualPoints[1].x + NewDeltaX, APointObject.ActualPoints[1].y); end else if ASnapLine.ActualPoints[1].y = ASnapLine.ActualPoints[2].y then begin NewDeltaX := 0; NewDeltaY := ASnapLine.ActualPoints[1].y - APointObject.ActualPoints[1].y; APointObject.ActualPoints[1] := DoublePoint(APointObject.ActualPoints[1].x, APointObject.ActualPoints[1].y + NewDeltaY); end else begin NewDeltaX := 0; NewDeltaY := 0; APointObject.ActualPoints[1] := DoublePoint(APointObject.ActualPoints[1].x + NewDeltaX, APointObject.ActualPoints[1].y + NewDeltaY); end; APointObject.DrawFigure.move(NewDeltaX, NewDeltaY); if APointObject.CaptionsGroup <> nil then APointObject.CaptionsGroup.Move(NewDeltaX, NewDeltaY); //Tolik -- 27/02/2018 -- if CompareValue(TConnectorObject(ASnapLine.JoinConnector1).ActualzOrder[1], TConnectorObject(ASnapLine.JoinConnector2).ActualZOrder[1]) = 0 then SnapZ := TConnectorObject(ASnapLine.JoinConnector1).ActualzOrder[1] else // если линая наклонная - вычислить высоту разделения линии SnapZ := GetCoordZ(ASnapLine, APointObject.ap1.x, APointObject.ap1.y); JoinedConn := Nil; // если не на одной высоте - создать и приконнектить райз if CompareValue(SnapZ, APointObject.ActualZOrder[1]) <> 0 then begin CreateRaiseOnPointObjectNew(APointObject, SnapZ); RaiseLineCreated := True; RaiseLine := nil; for i := 0 to APointObject.JoinedConnectorsList.Count - 1 do begin for j := 0 to TConnectorObject(APointObject.JoinedConnectorsList[i]).JoinedOrtholinesList.Count - 1 do begin if TOrthoLine(TConnectorObject(APointObject.JoinedConnectorsList[i]).JoinedOrtholinesList[j]).FIsRaiseUpDown then begin RaiseLine := TOrthoLine(TConnectorObject(APointObject.JoinedConnectorsList[i]).JoinedOrtholinesList[j]); break; end; end end; if RaiseLine <> nil then begin if CompareValue(SnapZ, TConnectorObject(RaiseLine.JoinConnector1).ActualZOrder[1]) = 0 then JoinedConn := TConnectorObject(RaiseLine.JoinConnector1) else if CompareValue(SnapZ, TConnectorObject(RaiseLine.JoinConnector2).ActualZOrder[1]) = 0 then JoinedConn := TConnectorObject(RaiseLine.JoinConnector2); end; end; if JoinedConn = nil then // высоты совпадают, райз не создаем... begin JoinedConn := TConnectorObject.Create(APointObject.ap1.x, APointObject.ap1.y, SnapZ, ASnapLine.LayerHandle, mydsNormal, GCadForm.PCad); JoinedConn.ConnectorType := ct_Clear; GCadForm.PCad.AddCustomFigure (GLN(ASnapLine.LayerHandle), JoinedConn, False); end; SnapConnectorToOrthoLine(JoinedConn, ASnapLine); // SnapConnectorToPointObject(JoinedConn, APointObject); // присоединить объект в точке (если не было создания райза -- точка снапа на трассу и высота объекта одинаковые) if not RaiseLineCreated then begin JoinedConn.JoinedConnectorsList.Add(aPointObject); APointObject.JoinedConnectorsList.Add(JoinedConn); //Tolik 19/11/2019 DeleteObjectFromPM(JoinedConn.ID, JoinedConn.Name); // SortLineList(JoinedConn); // чтобы не поломать райз //присоединить трассы через коннекторы к точечному for i := 1 to JoinedConn.JoinedOrtholinesList.Count - 1 do begin JoinedLine := TOrthoLine(JoinedConn.JoinedOrtholinesList[i]); ClearConn := TConnectorObject.Create(APointObject.ap1.x, APointObject.ap1.y, SnapZ, ASnapLine.LayerHandle, mydsNormal, GCadForm.PCad); ClearConn.ConnectorType := ct_Clear; GCadForm.PCad.AddCustomFigure (GLN(ASnapLine.LayerHandle), ClearConn, False); if JoinedLine.JoinConnector1.ID = JoinedConn.ID then JoinedLine.SetJConnector1(ClearConn) else JoinedLine.SetJConnector2(ClearConn); ClearConn.JoinedConnectorsList.Add(APointObject); APointObject.JoinedConnectorsList.Add(ClearConn); DeleteObjectFromPM(ClearConn.ID, ClearConn.Name); end; // сбросить соединения на пустом коннекторе JoinedLine := TOrthoLine(JoinedConn.JoinedOrtholinesList[0]); JoinedConn.JoinedOrtholinesList.Clear; JoinedConn.JoinedOrtholinesList.Add(JoinedLine); end; // Протокол GCadForm.mProtocol.Lines.Add(cEndPoints_Mes1 + APointObject.Name + cCommon_Mes1 + ASnapLine.Name + '"'); except on E: Exception do addExceptionToLogEx('U_Common.SnapPointObjectToOrtholine', E.Message); end; GCanRefreshCad := CadRefreshFlag; GCadForm.PCad.Refresh; end; //Tolik 27/02/2018 -- переписана совсем -- старая нахрен (совсем херня...) // ПРИВЯЗКА ОБЬЕКТА К ЛИНИИ (* procedure SnapPointObjectToOrthoLine(APointObject: TConnectorObject; ASnapLine: TOrthoLine); var i, j: integer; NewDeltaX, NewDeltaY: double; AddLine: TOrthoLine; JoinedCon: TConnectorObject; ClearCon1, ClearCon2: TConnectorObject; NextConnector: TFigure; Modx, Mody, NextModx, NextMody: Double; TempDefaultNum: integer; CurrentLine: TOrthoLine; CP_Line: TDoublePoint; MustRealign: Boolean; AngleRad: double; // Koef: Double; AllLengthXY: Double; CurrLengthXY: Double; DeltaHeight: Double; JoinedConn: TConnectorObject; ObjToDisconnect: TList; GetOtherConn: TConnectorObject; //Tolik GtempListCreated: Boolean; SnapZ: Double; // высота, на которой объект попадает на трассу CadRefreshFlag: Boolean; RaiseLine: TOrthoLine; RaiseConn: TConnectorObject; JoinedComponList: TList; // Tolik SavedLineComponList, SavedPointComponList: TList; DivLineObject, JoinedPointObject: TSCSCatalog; PointCompon: TSCSComponent; NBConnector: TConnectorObject; InterfRel : TSCSIOfIRel; InterfPosition, JoinedPosition: TSCSInterfPosition; LineCompon: TSCSComponent; ALineInterFace, APointInterFace, aTempInterf: TSCSInterface; LineInterfList: TList; ConnComponList: TList; AInterfPositions1, AInterfPositions2: TSCSInterfPositions; LineComponInterFace, PointComponInterFace: TSCSInterFace; InterFaceAccordanceList: TList; APointInterfID: Integer; ConnectedInterFaces: TSCSIOfIRel; ConnectIDCompRel: Integer; TempInterfaces1, TempInterfaces2: TSCSInterfaces; InterfCount: Integer; ptrConnection: PComplect; DisJoinList: TList; JoinedLineConnectInfo, SelfLineConnectInfo: TLineComponConnectionInfo; SavedComponList, SavedLineConnectionsList: TList; ObjParams: TObjectParams; // Procedure CheckSaveLineConnectionsBySide(aLine: TOrthoLine; aCableCompon: TSCSComponent; aSide: Integer); var i, j, k: Integer; InterfPos: TSCSInterfPosition; Interf, ConnectedInterf: TSCSInterface; DirectConnectedComponList, ConnectedComponList: TList; JoinedCompon, ConnectedLineComponent: TSCSComponent; PointToSave: TConnectorObject; PointCatalog, LineCatalog, JoinedLineCatalog: TSCSCatalog; POintFigure, LineFigure: TFigure; CanContinue: Boolean; WayList: TList; // ComponToDeleteList: TSCSComponents; LastComponent: TSCSComponent; LastSide: Integer; isLineConnection, isPointConnection: Boolean; ComponJoinedByMultiInterface: TSCSComponent; JoinedInterface: TSCSInterface; FirstComponID: Integer; SavedPointConnection: Boolean; Procedure SaveConnectionOnPointObject(aPointObject: TConnectorObject; aPointCatalog: TSCSCatalog; aJoinedLineCompon: TSCSComponent; ConnectionSide: Integer); var i, j, k, l, m: Integer; PointJoinedLineCatalog : TSCSCatalog; PointComponent, LineComponent: TSCSComponent; LineJoinedComponList: TList; LineInterface: TSCSInterface; aCableComponInterface: TSCSInterface; begin NBConnector := APointObject; if NBConnector <> nil then begin if (aPointCatalog <> nil) then begin //if ((aPointCatalog.ComponentReferences.Count > 0) and (DivLineObject.ComponentReferences.Count > 0)) then begin InterFaceAccordanceList := TList.Create; if IsCableComponent(aJoinedLineCompon) then // так правильнее -- для всех кабелей // begin if CheckJoinedComponToComponFromObject(aJoinedLineCompon, aPointCatalog) then begin for k := 0 to aJoinedLineCompon.Interfaces.count - 1 do begin if (aJoinedLineCompon.Interfaces[k].TypeI = itFunctional) and (aJoinedLineCompon.Interfaces[k].Side = ConnectionSide) and ((aJoinedLineCompon.Interfaces[k].IsBusy = biTrue) or (aJoinedLineCompon.Interfaces[k].BusyPositions.Count > 0)) then begin SavedLineComponList := TList.Create; SavedPointComponList := TList.Create; ALineInterFace := TSCSInterFace(aJoinedLineCompon.Interfaces.Items[k]); if aCableCompon.Id = aJoinedLineCompon.id then begin if SavedLineComponList.IndexOf(ALineInterFace) = -1 then SavedLineComponList.Add(TSCSInterface(ALineInterFace)); end else begin aCableComponInterFace := aCableCompon.Interfaces[k]; if SavedLineComponList.IndexOf(aCableComponInterFace) = -1 then SavedLineComponList.Add(TSCSInterface(aCableComponInterFace)); end; APointInterfID := -1; for l := 0 to ALineInterFace.BusyPositions.Count - 1 do begin InterfPosition := ALineInterFace.BusyPositions[l]; JoinedPosition := InterfPosition.GetConnectedPos; if JoinedPosition <> nil then begin if JoinedPosition.InterfOwner <> nil then begin if SavedPointComponList.IndexOf(JoinedPosition.InterfOwner) = -1 then SavedPointComponList.Add(TSCSInterFace(JoinedPosition.InterfOwner)); end; end; end; if ((SavedLineComponList.Count > 0) and (SavedPointComponList.Count > 0)) then begin InterFaceAccordanceList.Add(SavedLineComponList); InterFaceAccordanceList.Add(SavedPointComponList); end else begin SavedLineComponList.Clear; SavedPointComponList.Clear; FreeAndNil(SavedLineComponList); FreeAndNil(SavedPointComponList); end; end; end; end; end; //end; end; if InterFaceAccordanceList.Count > 0 then begin // состояние соединения кабеля на точечном объекте SelfLineConnectInfo := TLineComponConnectionInfo.Create(True); SelfLineConnectInfo.ComponId := aCableCompon.ID;//AJoinedLineCompon.ID; //SelfLineConnectInfo.ComponSide := ConnectionSide; SelfLineConnectInfo.ComponSide := aSide; SelfLineConnectInfo.isLineConnection := False; JoinedLineConnectInfo := TLineComponConnectionInfo.Create(False); JoinedLineConnectInfo.ComponCatalogID := APointCatalog.ID; JoinedLineConnectInfo.ComponSide := 0; JoinedLineConnectInfo.ConnectedComponList := InterFaceAccordanceList; SelfLineConnectInfo.ConnectedComponList.Add(JoinedLineConnectInfo); SavedLineConnectionsList.Add(SelfLineConnectInfo); end else FreeAndNil(InterFaceAccordanceList); end; end; // сбросить соединения линейного с точечными на заданной стороне LineJoinedComponList := TList.Create; for i := 0 to aJoinedLineCompon.Interfaces.Count - 1 do begin LineInterface := TSCSInterface(aJoinedLineCompon.Interfaces[i]); if (LineInterface.TypeI = itFunctional) and (LineInterface.Side = ConnectionSide) then begin for j := 0 to LineInterface.ConnectedInterfaces.Count - 1 do if LineJoinedComponList.IndexOf(TSCSComponent(LineInterface.ConnectedInterfaces[j].ComponentOwner)) = -1 then LineJoinedComponList.Add(TSCSComponent(LineInterface.ConnectedInterfaces[j].ComponentOwner)); end; end; for i := 0 to LineJoinedComponList.Count - 1 do begin aJoinedLineCompon.DisJoinFrom(TSCSComponent(LineJoinedComponList[i])); end; FreeAndNil(LineJoinedComponList); // end; begin CanContinue := False; SelfLineConnectInfo := nil; JoinedLineConnectInfo := Nil; ConnectedComponList := TList.Create; PointToSave := nil; isLineConnection := False; isPointConnection := False; LineFigure := Nil; SavedPointConnection := False; if ((aCableCompon.JoinedComponents.count > 0) and (SavedComponList.IndexOf(aCableCompon) = -1)) then SavedComponList.Add(ACablecompon); for i := 0 to aCableCompon.Interfaces.Count - 1 do begin Interf := TSCSInterface(aCableCompon.Interfaces[i]); // ищем возможные подключения с указанной стороны if ((Interf.Side = aSide) and (Interf.TypeI = itFunctional) and ((Interf.IsBusy = biTrue) or (interf.BusyPositions.Count > 0))) then begin for j := 0 to Interf.BusyPositions.Count - 1 do begin InterfPos := TSCSInterfPosition(Interf.BusyPositions[j]); // занятая позиция интерфейса InterfPos := InterfPos.GetConnectedPos; // подключенная к ней непосредственно позиция интерфейса // присоединенного компонента JoinedCompon := InterfPos.InterfOwner.ComponentOwner; // присоединенный компонент if JoinedCompon <> nil then begin // подключен точечный компонент if JoinedCompon.IsLine = biFalse then begin // точечное соединение -- сохранить по позициям для восстановления if ConnectedComponList.IndexOf(JoinedCompon) = -1 then ConnectedComponList.Add(JoinedCompon); if PointToSave = nil then begin PointCatalog := JoinedCompon.GetFirstParentCatalog; PointToSave := TConnectorObject(GetFigurebyCatalogID(PointCatalog.SCSID)); // нашли точечный, присоединенный к кабелю -- сохраняем соединение и вываливаемся if ((PointToSave <> nil) and (CheckFigureByClassName(PointToSave, cTConnectorObject))) then begin SaveConnectionOnPointObject(PointtoSave, PointCatalog, aCableCompon, aSide); exit; //// BREAK ////; end; end; end // подключен линейный компонент // линейные поинтерфейсно соединять не нужно, просто соединить кабель else if JoinedCompon.isLine = biTrue then begin if ConnectedComponlist.IndexOf(JoinedCompon) = -1 then begin ConnectedComponList.Add(JoinedCompon); isLineConnection := True; LastSide := InterfPos.InterfOwner.Side; // сторона подлючения подключенного кабеля к текущему // если соединение - линейное - сохранить его if (LineFigure <> nil) and (not SavedPointConnection) then begin // кабель поднимаемой трассы SelfLineConnectInfo := TLineComponConnectionInfo.Create(True); SelfLineConnectInfo.ComponId := aCableCompon.ID; SelfLineConnectInfo.ComponSide := aSide; // трасса и сторона соединения JoinedLineConnectInfo:= TLineComponConnectionInfo.Create(False); JoinedLineConnectInfo.ComponId := JoinedCompon.ID; if TOrthoLine(LineFigure).FIsVertical then begin if LastSide = 1 then LastSide := 2 else if LastSide = 2 then LastSide := 1; end; JoinedLineConnectInfo.ComponSide := LastSide; JoinedLineCatalog := JoinedCompon.GetFirstParentCatalog; if JoinedLineCatalog <> nil then JoinedLineConnectInfo.ComponCatalogID := JoinedLineCatalog.ID; SelfLineConnectInfo.ConnectedComponList.Add(JoinedLineConnectInfo); SavedLineConnectionsList.Add(SelfLineConnectInfo); //отключить найденный кабель нах if aCableCompon.JoinedComponents.IndexOF(JoinedCompon) <> -1 then aCableCompon.DisJoinFrom(JoinedCompon); end; end; end; end; if isLineConnection then Break; //// BREAK //// if isPointConnection then Break; //// BREAK ////; end; end; if isLineConnection then Break; //// BREAK //// if isPointConnection then Break; //// BREAK ////; end; // если мультиинтерфейс - отключить все подключенные на нем( остальные кабели) // и загнать их в список подключенных компонент для восстановления, if aCableCompon.JoinedComponents.Count > 0 then begin for i := 0 to aCableCompon.Interfaces.count - 1 do begin Interf := TSCSInterface(aCableCompon.Interfaces[i]); if ((Interf.TypeI = itFunctional) and (Interf.Side = aSide) and (Interf.Multiple = biTrue) and (Interf.ConnectedInterfaces.Count > 1)) then begin if aCableCompon.JoinedComponents.Count > 0 then begin While Interf.ConnectedInterfaces.Count > 0 do begin JoinedInterface := TSCSInterface(Interf.ConnectedInterfaces[0]); ComponJoinedByMultiInterface := JoinedInterface.ComponentOwner; if ComponJoinedByMultiInterface <> nil then begin if (ComponJoinedByMultiInterface.IsLine = biTrue) then begin ConnectedComponList.Add(ComponJoinedByMultiInterface); // если было сохранение линейного соединения -- добавить в список сохранения подключенный кабель if SelfLineConnectInfo <> nil then begin FirstComponID := TLineComponConnectionInfo(SelfLineConnectInfo.ConnectedComponList[0]).ComponId; // на всякий if ComponJoinedByMultiInterface.ID <> FirstComponID then begin JoinedLineConnectInfo := TLineComponConnectionInfo.Create(False); JoinedLineConnectInfo.ComponId := ComponJoinedByMultiInterface.ID; JoinedLineConnectInfo.ComponSide := JoinedInterface.Side; SelfLineConnectInfo.ConnectedComponList.Add(JoinedLineConnectInfo); end; end; end; // отключить (если уже есть в списке или точечный компонент) aCableCompon.DisJoinFrom(ComponJoinedByMultiInterface); end; end; end; end; end; end; ConnectedComponList.Clear; FreeAndNil(ConnectedcomponList); GCadForm.PCad.Refresh; end; Procedure CheckDisJoinLineComponBySide(aLineCompon: TSCSComponent; ASide: Integer); var i, j: Integer; Interf: TSCSInterface; InterfPos: TSCSInterfPosition; JoinedComponList: TList; begin JoinedComponList := TList.Create; for i := 0 to aLineCompon.Interfaces.Count - 1 do begin Interf := TSCSInterface(aLineCompon.Interfaces[i]); if ((Interf.TypeI = itFunctional) and (Interf.Side = aSide)) then begin for j := 0 to Interf.BusyPositions.Count - 1 do begin InterfPos := TSCSInterfPosition(Interf.BusyPositions[j]); InterfPos := InterfPos.GetConnectedPos; if InterfPos <> nil then begin if JoinedComponList.IndexOf(InterfPos.InterfOwner.ComponentOwner) = -1 then JoinedComponList.Add(InterfPos.InterfOwner.ComponentOwner); end; end; end; end; for i := 0 to JoinedComponList.Count - 1 do aLineCompon.DisJoinFrom(TSCSComponent(JoinedComponList[i])); FreeAndNil(JoinedComponList); end; Procedure ConnectCableComponents(ACompon1, ACompon2: TSCSComponent); var LineCatalog1, LineCatalog2 : TSCSCatalog; SelfSide, JoinSide : integer; Line1, Line2: TOrthoLine; function CheckCanJoinOnConnectors(aConn1, aConn2: TConnectorObject): Boolean; begin Result := False; // если на одном точечном if (aConn1.JoinedConnectorsList.Count > 0) and (TConnectorObject(aConn1.JoinedConnectorsList[0]).JoinedConnectorsList.IndexOf(aConn2) <> -1) then Result := True else // или это один и тот же коннектор if aConn1.ID = aConn2.ID then Result := True; end; begin LineCatalog1 := ACompon1.GetFirstParentCatalog; LineCatalog2 := ACompon2.GetFirstParentCatalog; if ((LineCatalog1 <> nil) and (LineCatalog2 <> nil)) then begin Line1 := TOrthoLine(GetFigureByCatalogId(LineCatalog1.SCSId)); Line2 := TOrthoLine(GetFigureByCatalogId(LineCatalog2.SCSId)); if ((Line1 <> nil) and (Line2 <> nil)) then begin SelfSide := 0; JoinSide := 0; if (ACompon1 <> nil) and (ACompon2 <> nil) then begin if CheckCanJoinOnConnectors(TConnectorObject(Line1.JoinConnector1), TConnectorObject(Line2.JoinConnector1)) then ACompon1.JoinTo(ACompon2, 1, 1) else if CheckCanJoinOnConnectors(TConnectorObject(Line1.JoinConnector1), TConnectorObject(Line2.JoinConnector2)) then ACompon1.JoinTo(ACompon2, 1, 2) else if CheckCanJoinOnConnectors(TConnectorObject(Line1.JoinConnector2), TConnectorObject(Line2.JoinConnector1)) then ACompon1.JoinTo(ACompon2, 2, 1) else if CheckCanJoinOnConnectors(TConnectorObject(Line1.JoinConnector2), TConnectorObject(Line2.JoinConnector2)) then ACompon1.JoinTo(ACompon2, 2, 2); end; end; end; end; Procedure RestoreLineConnectionsBySide(aLine: TOrthoLine; ACableCompon: TSCSComponent; aSide: Integer); var i, j, k, l, m: Integer; TargetLine, TargetPointFigure: TFigure; WayList: TList; SelfConnector, TargetConn: TConnectorObject; TargetCatalog: TSCSCatalog; IdNewCompon: Integer; TargetCompon, NewCompon, FirstCompon, NextCompon: TSCSComponent; PassWayList: Boolean; // прокладывать кабель на вертикали/райзы ComponJoinedByMultiInterFace: TSCSComponent; CanRestoreConnection: Boolean; DisJoinSide: Integer; DisJoinComponList: TList; SideConnectionDropped: Boolean; Function GetInterfaceForConnection(AInterf: TSCSInterFace; WasConnectedCable, isConnectedCable: TSCSComponent; aPointObject: TConnectorObject): TSCSInterFace; var i, j, k: Integer; LineCompon: TSCSComponent; LineFigure: TOrthoLine; LineCatalog: TSCSCatalog; SourceLineCatalog, DestLineCatalog: TSCSCatalog; ConnectionSide : Integer; TmpInterfPos: TSCSInterfPosition; begin Result := nil; LineCatalog := Nil; ConnectionSide := 0; LineCompon := isConnectedCable;//AInterf.ComponentOwner; if LineCompon <> nil then begin LineCatalog := LineCompon.GetFirstParentCatalog; if LineCatalog <> nil then begin LineFigure := TOrthoLine(GetFigurebyCatalogID(LineCatalog.SCSID)); if LineFigure <> nil then begin if (TConnectorObject(LineFigure.JoinConnector1).JoinedConnectorsList.IndexOf(aPointObject) <> -1) or (TConnectorObject(LineFigure.JoinConnector1).ID = aPointObject.ID) then ConnectionSide := 1 else if (TConnectorObject(LineFigure.JoinConnector2).JoinedConnectorsList.IndexOf(aPointObject) <> -1) or (TConnectorObject(LineFigure.JoinConnector2).ID = aPointObject.ID) then ConnectionSide := 2; for j := 0 to LineCompon.Interfaces.Count - 1 do begin if TSCSInterface(LineCompon.Interfaces[j]).TypeI = itFunctional then if TSCSInterface(LineCompon.Interfaces[j]).Npp = AInterf.Npp then // вторая сторона идин х занята уже ...(если не обрыв кабеля) if TSCSInterface(LineCompon.Interfaces[j]).Side = ConnectionSide then if ((TSCSInterface(LineCompon.Interfaces[j]).IsBusy = biFalse) or (TSCSInterface(LineCompon.Interfaces[j]).BusyPositions.Count = 0)) then begin Result := TSCSInterface(LineCompon.Interfaces[j]); break; end; end; end; end; end; end; Function DefineIDComponRel(ALineCompon, APointCompon: TSCSComponent): Integer; var TopCatalog: TSCSCatalog; begin Result := -1; begin TopCatalog := aLineCompon.GetTopParentCatalog; if TopCatalog <> nil then if TopCatalog is TSCSProject then Result := TSCSProject(TopCatalog).GenIDByGeneratorIndex(giComponentRelationID, 1); end; //if IDComponRel = -1 then //IDComponRel := TF_Main(ActiveForm).AppendToComponRel(Self.ID, AComponent.ID, 1, AConnectType); end; begin WayList := nil; SelfLineConnectInfo := Nil; SelfConnector := nil; TargetConn := Nil; PassWayList := True; DisJoinComponList := nil; CanRestoreConnection := True; SideConnectionDropped := False; While CanRestoreconnection do begin CanRestoreConnection := False; for i := 0 to SavedLineConnectionsList.Count - 1 do begin if ((TLineComponConnectionInfo(SavedLineConnectionsList[i]).ComponId = ACableCompon.ID) and (TLineComponConnectionInfo(SavedLineConnectionsList[i]).ComponSide = aSide)) then begin SelfLineConnectInfo := TLineComponConnectionInfo(SavedLineConnectionsList[i]); CanRestoreConnection := True; Break; //// BREAK ////; end; end; if SelfLineConnectInfo <> nil then begin if not SideConnectionDropped then begin CheckDisJoinLineComponBySide(ACableCompon, aSide); SideConnectionDropped := True; end; if SelfLineConnectInfo.ComponSide = 1 then SelfConnector := TConnectorObject(aLine.JoinConnector1) else if SelfLineConnectInfo.ComponSide = 2 then SelfConnector := TConnectorObject(aLine.JoinConnector2); if SelfConnector <> nil then begin // for i := 0 to SelfLineConnectInfo.ConnectedComponList.Count - 1 do begin FirstCompon := F_ProjMan.GSCSBase.CurrProject.CurrList.GetComponentFromReferences(SelfLineConnectInfo.ComponId); JoinedLineConnectInfo := TLineComponConnectionInfo(SelfLineConnectInfo.ConnectedComponList[0]); TargetCompon := nil; if SelfLineConnectInfo.isLineConnection then TargetCompon := F_ProjMan.GSCSBase.CurrProject.CurrList.GetComponentFromReferences(JoinedLineConnectInfo.ComponId); if FirstCompon <> nil then begin // произошло разделение вертикали if TargetCompon = nil then begin TargetCatalog := F_ProjMan.GSCSBase.CurrProject.CurrList.GetCatalogFromReferences(JoinedLineConnectInfo.ComponCatalogID); end else if TargetCompon <> nil then TargetCatalog := TargetCompon.GetFirstParentCatalog; // линейное соединение (кабель -- кабель) if TargetCatalog <> nil then begin TargetLine := GetFigureByCatalogID(TargetCatalog.SCSID); if TargetLine <> nil then begin TargetConn := Nil; if CheckFigureByClassName(TargetLine, cTOrthoLine) then begin // линейноне подключение if JoinedLineConnectInfo.ComponSide = 1 then TargetConn := TConnectorObject(TOrthoLine(TargetLine).JoinConnector1) else if JoinedLineConnectInfo.ComponSide = 2 then TargetConn := TConnectorObject(TOrthoLine(TargetLine).JoinConnector2); end else if CheckFigureByClassName(TargetLine, CTConnectorObject) then begin // точечное подключение TargetPointfigure := TargetLine; if JoinedLineConnectInfo.ComponSide = 0 then begin TargetConn := TConnectorObject(TargetLine); end; end; if TargetConn <> nil then begin // если произошло разделение вертикали - найти коннектор от высоты подъема WayList := GetAllTraceInCAD(TFigure(SelfConnector), TFigure(TargetConn)); if WayList <> nil then begin // прокладка кабеля for j := 0 to WayList.Count - 1 do begin TargetLine := TFigure(WayList[j]); if CheckFigureByClassName(TargetLine, CTOrthoLine) then begin TargetCatalog := F_ProjMan.GSCSBase.CurrProject.CurrList.GetCatalogFromReferencesBySCSID(TargetLine.ID); if TargetCatalog <> nil then begin NewCompon := Nil; // вкинуть кабель на трассу NewCompon := CopyComponentToPMSCSObject(ACableCompon, TargetCatalog, False); // рассоединить добавленный кабель от всего, к чему подключился автоматом if NewCompon <> nil then NewCompon.DisJoinFromAll(false); end; end; end; end; end; end; // FirstCompon := TargetCompon; // соединить кабели if WayList <> nil then begin if WayList.Count > 0 then begin //FirstCompon := aCableCompon; for j := 0 to WayList.count - 1 do begin TargetLine := TFigure(WayList[j]); if CheckFigureByClassName(TargetLine, cTOrthoLine) then begin TargetCatalog := F_ProjMan.GSCSBase.CurrProject.CurrList.GetCatalogFromReferencesBySCSID(TargetLine.ID); if TargetCatalog <> nil then begin NewCompon := TargetCatalog.LastAddedComponent; if NewCompon <> nil then begin if FirstCompon.JoinedComponents.IndexOf(NewCompon) = -1 then ConnectCableComponents(FirstCompon, NewCompon); // если на мультиинтерфейсе if ((j = 0) and (SelfLineConnectInfo.ConnectedComponList.Count > 1)) then begin for k := 1 to SelfLineConnectInfo.ConnectedComponList.Count - 1 do begin ComponJoinedByMultiInterFace := F_ProjMan.GSCSBase.CurrProject.CurrList.GetComponentFromReferences(TLineComponConnectionInfo(SelfLineConnectInfo.ConnectedComponList[k]).ComponId); if ComponJoinedByMultiInterFace <> nil then begin if NewCompon.JoinedComponents.IndexOf(ComponJoinedByMultiInterFace) = -1 then ConnectCableComponents(NewCompon, ComponJoinedByMultiInterFace); end; end; end; FirstCompon := NewCompon; NewCompon := Nil; end; end; end; end; // конечное соединение //NewCompon := aCableCompon;//F_ProjMan.GSCSBase.CurrProject.CurrList.GetComponentFromReferences(JoinedLineConnectInfo.ComponId); if SelfLineConnectInfo.isLineConnection then begin NewCompon := F_ProjMan.GSCSBase.CurrProject.CurrList.GetComponentFromReferences(JoinedLineConnectInfo.ComponId); if ((NewCompon <> nil) and (FirstCompon.JoinedComponents.IndexOf(NewCompon) = -1)) then ConnectCableComponents(FirstCompon, NewCompon); end else begin if not SelfLineConnectInfo.isLineConnection then begin // Restore Connection // восстановить состояние соединения кабеля с точечными компонентами NewCompon := FirstCompon; // если коннектор упал на точечный объект, то кабель мог автоматом соединиться с // компонентами точечного, поэтому нужно их расконнектить до восстановления соединения TargetCatalog := NewCompon.GetFirstParentCatalog; if TargetCatalog <> nil then begin TargetLine := GetFigureByCatalogId(TargetCatalog.SCSID); if TargetLine <> nil then begin DisJoinSide := 0; if TConnectorObject(TOrthoLine(TargetLine).JoinConnector1).JoinedConnectorsList.IndexOf(TConnectorObject(TargetPointFigure)) <> -1 then DisJoinSide := 1 else if TConnectorObject(TOrthoLine(TargetLine).JoinConnector2).JoinedConnectorsList.IndexOf(TConnectorObject(TargetPointFigure)) <> -1 then DisJoinSide := 2; if DisJoinSide <> 0 then begin DisJoinComponList := TList.Create; for i := 0 to NewCompon.Interfaces.Count - 1 do begin if (NewCompon.Interfaces[i].TypeI = itFunctional) and (NewCompon.Interfaces[i].Side = DisJoinSide) then begin for j := 0 to NewCompon.Interfaces[i].ConnectedInterfaces.Count - 1 do begin if (TSCSInterface(NewCompon.Interfaces[i].ConnectedInterfaces[j]).ComponentOwner <> nil) and (DisJoinComponList.IndexOf(TSCSInterface(NewCompon.Interfaces[i].ConnectedInterfaces[j]).ComponentOwner) = -1) then DisJoinComponList.Add(TSCSInterface(NewCompon.Interfaces[i].ConnectedInterfaces[j]).ComponentOwner); end; end; end; for i := 0 to DisJoinComponList.Count - 1 do begin NewCompon.DisJoinFrom(TSCSComponent(DisJoinComponList[i])); end; end; FreeAndNil(DisJoinComponList); end; end; FirstCompon := F_ProjMan.GSCSBase.CurrProject.CurrList.GetComponentFromReferences(SelfLineConnectInfo.ComponId); InterFaceAccordanceList := JoinedLineConnectInfo.ConnectedComponList; if ((InterFaceAccordanceList <> nil) and (InterFaceAccordanceList.Count > 0)) then begin i := 0; While (i <= (InterFaceAccordanceList.Count - 1)) do begin SavedLineComponList := TList(InterFaceAccordanceList[i]); SavedPointComponList := TList(InterFaceAccordanceList[i + 1]); for j := 0 to SavedLineComponList.Count - 1 do begin aTempInterf := TSCSInterface(SavedLineComponList[j]); ALineInterFace := GetInterfaceForConnection(aTempInterf, FirstCompon, NewCompon, TConnectorObject(TargetPointFigure)); if ALineInterFace <> nil then begin LineCompon := ALineInterFace.ComponentOwner; for k := 0 to SavedPointComponList.Count - 1 do begin APointInterFace := TSCSInterface(SavedPointComponList[k]); PointCompon := APointInterFace.ComponentOwner; AInterfPositions1 := ALineInterFace.GetEmptyPositions; AInterfPositions2 := APointInterFace.GetEmptyPositions; // уравнять количество позиций для соединения if AInterfPositions1.Positions.Count > AInterfPositions2.Positions.Count then begin While AInterfPositions1.Positions.Count <> AInterfPositions2.Positions.Count do begin l := AInterfPositions1.Positions.Count - 1; AInterfPositions1.Positions.Delete(l); end; AInterfPositions1.DefineKolvo; end else if AInterfPositions2.Positions.Count > AInterfPositions1.Positions.Count then begin While AInterfPositions2.Positions.Count <> AInterfPositions1.Positions.Count do begin l := AInterfPositions2.Positions.Count - 1; AInterfPositions2.Positions.Delete(l); end; AInterfPositions2.DefineKolvo; end; ConnectIDCompRel := DefineIDComponRel(LineCompon, PointCompon); // До того как соединить интерфейсы, нужно соединить сами компоненты if LineCompon.JoinedComponents.IndexOf(PointCompon) = -1 then begin TempInterfaces1 := TSCSInterfaces.Create(false); TempInterfaces2 := TSCSInterfaces.Create(false); if TF_Main(LineCompon.ActiveForm).F_ChoiceConnectSide.JoinWithDefineSides(LineCompon, PointCompon, false, TempInterfaces1, TempInterfaces2, true).CanConnect then; FreeAndNil(TempInterfaces1); FreeAndNil(TempInterfaces2); end; if LineCompon.JoinedComponents.IndexOf(PointCompon) <> -1 then begin ptrConnection := LineCompon.GetConnectionByConnected(PointCompon); if ptrConnection <> nil then begin TempInterfaces1 := TSCSInterfaces.Create(false); TempInterfaces2 := TSCSInterfaces.Create(false); TempInterfaces1.Add(ALineInterFace); TempInterfaces2.Add(APointInterFace); InterfCount := AInterfPositions1.Kolvo; if InterfCount > AInterfPositions2.Kolvo then InterfCount := AInterfPositions2.Kolvo; TF_Main(LineCompon.ActiveForm).ConnectInterfacesWithAccordance(ALineInterFace, APointInterFace, InterfCount, InterfCount, ptrConnection.ID, cntUnion, AInterfPositions1, AInterfPositions2, true, TempInterfaces1, TempInterfaces2); TF_Main(LineCompon.ActiveForm).F_ChoiceConnectSide.OnAfterJoinCompons(LineCompon, PointCompon, -1, -1); end; end; end; end; end; SavedLineComponList.Clear; SavedPointComponList.Clear; FreeAndNil(SavedLineComponList); FreeAndNil(SavedPointComponList); Inc(i,2); end; end; if InterFaceAccordanceList <> nil then begin InterFaceAccordanceList.clear; FreeAndNil(InterFaceAccordanceList); end; end; end; end else begin //NewCompon := aCableCompon;// F_ProjMan.GSCSBase.CurrProject.CurrList.GetComponentFromReferences(JoinedLineConnectInfo.ComponId); NewCompon := F_ProjMan.GSCSBase.CurrProject.CurrList.GetComponentFromReferences(JoinedLineConnectInfo.ComponId); if NewCompon <> nil then if FirstCompon.JoinedComponents.IndexOf(NewCompon) = -1 then ConnectCableComponents(FirstCompon, NewCompon); // если на мультиинтерфейсе if SelfLineConnectInfo.ConnectedComponList.Count > 1 then begin for k := 1 to SelfLineConnectInfo.ConnectedComponList.Count - 1 do begin ComponJoinedByMultiInterFace := F_ProjMan.GSCSBase.CurrProject.CurrList.GetComponentFromReferences(TLineComponConnectionInfo(SelfLineConnectInfo.ConnectedComponList[k]).ComponId); if ComponJoinedByMultiInterFace <> nil then begin if NewCompon.JoinedComponents.IndexOf(ComponJoinedByMultiInterFace) = -1 then ConnectCableComponents(NewCompon, ComponJoinedByMultiInterFace); end; end; end; end; WayList.Clear; FreeAndNil(WayList); end else begin // если соединение линейное if SelfLineConnectInfo.isLineConnection then begin // NewCompon := aCableCompon;//F_ProjMan.GSCSBase.CurrProject.CurrList.GetComponentFromReferences(JoinedLineConnectInfo.ComponId); NewCompon := F_ProjMan.GSCSBase.CurrProject.CurrList.GetComponentFromReferences(JoinedLineConnectInfo.ComponId); if NewCompon <> nil then if FirstCompon.JoinedComponents.IndexOf(NewCompon) = - 1 then ConnectCableComponents(FirstCompon, NewCompon); // если на мультиинтерфейсе if SelfLineConnectInfo.ConnectedComponList.Count > 1 then begin for k := 1 to SelfLineConnectInfo.ConnectedComponList.Count - 1 do begin ComponJoinedByMultiInterFace := F_ProjMan.GSCSBase.CurrProject.CurrList.GetComponentFromReferences(TLineComponConnectionInfo(SelfLineConnectInfo.ConnectedComponList[k]).ComponId); if ComponJoinedByMultiInterFace <> nil then begin if NewCompon.JoinedComponents.IndexOf(ComponJoinedByMultiInterFace) = -1 then ConnectCableComponents(NewCompon, ComponJoinedByMultiInterFace); end; end; end; end // если кабель был присобачен к компонентам точечного объекта - соединить как было else begin end; // end; end else begin if not SelfLineConnectInfo.isLineConnection then begin TargetPointFigure := TConnectorObject(GetFigureByCatalogId(JoinedLineConnectInfo.ComponId)); if TargetPointFigure <> nil then begin // если чистый коннектор и на нем объект -- получить его if (TConnectorObject(TargetPointFigure).ConnectorType = ct_clear) and (TConnectorObject(TargetPointFigure).JoinedConnectorsList.Count > 0) then TargetPointFigure := TFigure(TConnectorObject(TargetPointFigure).JoinedConnectorsList[0]); WayList := GetAllTraceInCAD(TFigure(SelfConnector), TFigure(TargetPointFigure)); if WayList <> nil then begin // прокладка кабеля (только на райз или на вертикали) for j := 0 to WayList.Count - 1 do begin TargetLine := TFigure(WayList[j]); if CheckFigureByClassName(TargetLine, CTOrthoLine) then begin if ((TOrthoLine(TargetLine).FIsVertical) or (TOrthoLine(TargetLine).FIsRaiseUpDown)) then begin TargetCatalog := F_ProjMan.GSCSBase.CurrProject.CurrList.GetCatalogFromReferencesBySCSID(TargetLine.ID); if TargetCatalog <> nil then begin NewCompon := Nil; // вкинуть кабель на трассу NewCompon := CopyComponentToPMSCSObject(ACableCompon, TargetCatalog, False); // рассоединить добавленный кабель от всего, к чему подключился автоматом if NewCompon <> nil then NewCompon.DisJoinFromAll(false); end; end; end; end; // выполнить кабельное соединение по пути следования for j := 0 to WayList.count - 1 do begin TargetLine := TFigure(WayList[j]); if CheckFigureByClassName(TargetLine, cTOrthoLine) then begin if TOrthoLine(TargetLine).FIsVertical or TOrthoLine(TargetLine).FIsRaiseUpDown then begin TargetCatalog := F_ProjMan.GSCSBase.CurrProject.CurrList.GetCatalogFromReferencesBySCSID(TargetLine.ID); if TargetCatalog <> nil then begin NewCompon := TargetCatalog.LastAddedComponent; if NewCompon <> nil then begin if FirstCompon.JoinedComponents.IndexOf(NewCompon) = -1 then ConnectCableComponents(FirstCompon, NewCompon); // если на мультиинтерфейсе if ((j = 0) and (SelfLineConnectInfo.ConnectedComponList.Count > 1)) then begin for k := 1 to SelfLineConnectInfo.ConnectedComponList.Count - 1 do begin ComponJoinedByMultiInterFace := F_ProjMan.GSCSBase.CurrProject.CurrList.GetComponentFromReferences(TLineComponConnectionInfo(SelfLineConnectInfo.ConnectedComponList[k]).ComponId); if ComponJoinedByMultiInterFace <> nil then begin if NewCompon.JoinedComponents.IndexOf(ComponJoinedByMultiInterFace) = -1 then ConnectCableComponents(NewCompon, ComponJoinedByMultiInterFace); end; end; end; FirstCompon := NewCompon; NewCompon := Nil; end; end; end; end; end; end; // Restore Connection // восстановить состояние соединения кабеля с точечными компонентами NewCompon := FirstCompon; FirstCompon := F_ProjMan.GSCSBase.CurrProject.CurrList.GetComponentFromReferences(SelfLineConnectInfo.ComponId); InterFaceAccordanceList := JoinedLineConnectInfo.ConnectedComponList; if ((InterFaceAccordanceList <> nil) and (InterFaceAccordanceList.Count > 0)) then begin i := 0; While (i <= (InterFaceAccordanceList.Count - 1)) do begin SavedLineComponList := TList(InterFaceAccordanceList[i]); SavedPointComponList := TList(InterFaceAccordanceList[i + 1]); for j := 0 to SavedLineComponList.Count - 1 do begin aTempInterf := TSCSInterface(SavedLineComponList[j]); ALineInterFace := GetInterfaceForConnection(aTempInterf, FirstCompon, NewCompon, TConnectorObject(TargetPointFigure)); LineCompon := ALineInterFace.ComponentOwner; if ALineInterFace <> nil then begin for k := 0 to SavedPointComponList.Count - 1 do begin APointInterFace := TSCSInterface(SavedPointComponList[k]); PointCompon := APointInterFace.ComponentOwner; AInterfPositions1 := ALineInterFace.GetEmptyPositions; AInterfPositions2 := APointInterFace.GetEmptyPositions; // уравнять количество позиций для соединения if AInterfPositions1.Positions.Count > AInterfPositions2.Positions.Count then begin While AInterfPositions1.Positions.Count <> AInterfPositions2.Positions.Count do begin l := AInterfPositions1.Positions.Count - 1; AInterfPositions1.Positions.Delete(l); end; AInterfPositions1.DefineKolvo; end else if AInterfPositions2.Positions.Count > AInterfPositions1.Positions.Count then begin While AInterfPositions2.Positions.Count <> AInterfPositions1.Positions.Count do begin l := AInterfPositions2.Positions.Count - 1; AInterfPositions2.Positions.Delete(l); end; AInterfPositions2.DefineKolvo; end; ConnectIDCompRel := DefineIDComponRel(LineCompon, PointCompon); // До того как соединить интерфейсы, нужно соединить сами компоненты if LineCompon.JoinedComponents.IndexOf(PointCompon) = -1 then begin TempInterfaces1 := TSCSInterfaces.Create(false); TempInterfaces2 := TSCSInterfaces.Create(false); if TF_Main(LineCompon.ActiveForm).F_ChoiceConnectSide.JoinWithDefineSides(LineCompon, PointCompon, false, TempInterfaces1, TempInterfaces2, true).CanConnect then; FreeAndNil(TempInterfaces1); FreeAndNil(TempInterfaces2); end; if LineCompon.JoinedComponents.IndexOf(PointCompon) <> -1 then begin ptrConnection := LineCompon.GetConnectionByConnected(PointCompon); if ptrConnection <> nil then begin TempInterfaces1 := TSCSInterfaces.Create(false); TempInterfaces2 := TSCSInterfaces.Create(false); TempInterfaces1.Add(ALineInterFace); TempInterfaces2.Add(APointInterFace); InterfCount := AInterfPositions1.Kolvo; if InterfCount > AInterfPositions2.Kolvo then InterfCount := AInterfPositions2.Kolvo; TF_Main(LineCompon.ActiveForm).ConnectInterfacesWithAccordance(ALineInterFace, APointInterFace, InterfCount, InterfCount, ptrConnection.ID, cntUnion, AInterfPositions1, AInterfPositions2, true, TempInterfaces1, TempInterfaces2); TF_Main(LineCompon.ActiveForm).F_ChoiceConnectSide.OnAfterJoinCompons(LineCompon, PointCompon, -1, -1); end; end; end; end; end; SavedLineComponList.Clear; SavedPointComponList.Clear; FreeAndNil(SavedLineComponList); FreeAndNil(SavedPointComponList); Inc(i,2); end; end; if InterFaceAccordanceList <> nil then begin InterFaceAccordanceList.clear; FreeAndNil(InterFaceAccordanceList); end; end; end; end; end; end; end; SavedLineConnectionsList.Remove(SelfLineConnectInfo); FreeAndNil(SelfLineConnectInfo); end; end; end; // // вычисляет Z - координату "падения" точечного компонента на наклонную линию, // если координаты X, Y - известны Function GetCoordZ(ASnapFigure: TFigure; CoordX, CoordY: Double): Double; // Tolik 27/02/2018 Var vx, vy, vz, xx1, xx2, yy1, yy2, zz1, zz2, TempZ : Double; Begin Result := 0; //первая точка прямой xx1 := RounDX(TOrthoLine(ASnapFigure).JoinConnector1.ActualPoints[1].x,2); yy1 := RounDX(TOrthoLine(ASnapFigure).JoinConnector1.ActualPoints[1].y,2); zz1 := RounDX(TConnectorObject(TOrthoLine(ASnapFigure).JoinConnector1).ActualZOrder[1],2); //вторая точка прямой xx2 := RounDX(TOrthoLine(ASnapFigure).JoinConnector2.ActualPoints[1].x,2); yy2 := RounDX(TOrthoLine(ASnapFigure).JoinConnector2.ActualPoints[1].y,2); zz2 := RounDX(TConnectorObject(TOrthoLine(ASnapFigure).JoinConnector2).ActualZOrder[1],2); // направляющий вектор для прямой (координаты) vx := xx2 - xx1; vy := yy2 - yy1; vz := zz2 - zz1; if (vx <> 0) then begin Result := Roundx(((CoordX - xx1)/vx)*vz + zz1, 2); end else begin if (vy <> 0) then Result := RoundX(((CoordY - yy1)/vy)*vz + zz1, 2); end; End; // отсоединить компоненты трассы на втором коннекторе от всего, что там есть Procedure DisJoinOnSide2(aLine: TOrthoLine); var i, j, k: Integer; LineCatalog, JoinedCatalog: TSCSCatalog; FigList: tList; JoinedCatalogList: TList; JoinedComponList: TList; JoinedLine: TOrthoLine; TraceCompon, JoinedCompon: TSCSComponent; NB_Connector, JoinedConnector: TConnectorObject; begin LineCatalog := F_ProjMan.GSCSBase.CurrProject.CurrList.GetCatalogFromReferencesBySCSID(aLine.Id); if LineCatalog = nil then exit; JoinedComponList := TList.Create; JoinedCatalogList := TList.Create; //определить подключения на второй стороне if Assigned(aLine.JoinConnector2) then begin for i := 0 to TConnectorObject(aLine.JoinConnector2).JoinedOrthoLinesList.Count - 1 do begin JoinedLine := TOrthoLine(TConnectorObject(aLine.JoinConnector2).JoinedOrthoLinesList[i]); if JoinedLine <> nil then if not JoinedLine.deleted then JoinedCatalog := F_ProjMan.GSCSBase.CurrProject.CurrList.GetCatalogFromReferencesBySCSID(JoinedLine.ID); if JoinedCatalog <> nil then if JoinedCatalogList.IndexOf(JoinedCatalog) = -1 then JoinedCatalogList.Add(JoinedCatalog); end; if TConnectorObject(aLine.JoinConnector2).JoinedConnectorsList.Count > 0 then begin NB_Connector := TConnectorObject(TConnectorObject(aLine.JoinConnector2).JoinedConnectorsList[0]); if Nb_Connector <> nil then if not NB_Connector.Deleted then begin // Point Compons JoinedCatalog := F_ProjMan.GSCSBase.CurrProject.CurrList.GetCatalogFromReferencesBySCSID(NB_Connector.ID); if JoinedCatalog <> nil then begin if JoinedCatalogList.IndexOf(JoinedCatalog) = -1 then JoinedCatalogList.Add(JoinedCatalog); end; // LineCompons for i := 0 to NB_Connector.JoinedConnectorsList.Count - 1 do begin JoinedConnector := TconnectorObject(NB_Connector.JoinedConnectorsList[i]); if JoinedConnector.ID <> aLine.JoinConnector2.ID then begin for j := 0 to JoinedConnector.JoinedOrtholinesList.Count - 1 do begin JoinedLine := TOrthoLine(TConnectorObject(aLine.JoinConnector2).JoinedOrthoLinesList[j]); if JoinedLine <> nil then if not JoinedLine.deleted then JoinedCatalog := F_ProjMan.GSCSBase.CurrProject.CurrList.GetCatalogFromReferencesBySCSID(JoinedLine.ID); if JoinedCatalog <> nil then if JoinedCatalogList.IndexOf(JoinedCatalog) = -1 then JoinedCatalogList.Add(JoinedCatalog); end; end; end end; end; end; for i := 0 to LineCatalog.ComponentReferences.Count - 1 do begin TraceCompon := TSCSComponent(LineCatalog.ComponentReferences[i]); for j := 0 to JoinedCatalogList.Count - 1 do begin JoinedCatalog := TSCSCatalog(JoinedCatalogList[j]); for k := 0 to JoinedCatalog.ComponentReferences.Count - 1 do begin JoinedCompon := TSCSComponent(JoinedCatalog.ComponentReferences[k]); if TraceCompon.JoinedComponents.IndexOf(JoinedCompon) <> -1 then TraceCompon.DisJoinFrom(JoinedCompon); end; end; end; end; Procedure ReconnConnectors; var i: Integer; Nb_Conn: TConnectorObject; JoinedLine: TOrthoLine; NewJConn, OldJConn, RaiseConn: TConnectorObject; begin NewJConn := TConnectorObject(AddLine.JoinConnector2); OldJConn := TConnectorObject(ASnapLine.JoinConnector2); NewJConn.FConnRaiseType := OldJConn.FConnRaiseType; NewJConn.FObjectFromRaise := OldJConn.FObjectFromRaise; OldJConn.FConnRaiseType := crt_None; OldJConn.FObjectFromRaise := nil; if TConnectorObject(aSnapLine.JoinConnector2).JoinedConnectorsList.Count > 0 then begin Nb_Conn := TConnectorObject(TConnectorObject(aSnapLine.JoinConnector2).JoinedConnectorsList[0]); if not NB_Conn.Deleted then begin TConnectorObject(aSnapLine.JoinConnector2).JoinedConnectorsList.Remove(NB_Conn); NB_Conn.JoinedConnectorsList.Remove(TConnectorObject(aSnapLine.JoinConnector2)); Nb_Conn.JoinedConnectorsList.Add(TConnectorObject(AddLine.JoinConnector2)); TConnectorObject(AddLine.JoinConnector2).JoinedConnectorsList.Insert(0, NB_Conn); end; end; for i := (TConnectorObject(ASnapLine.JoinConnector2).JoinedOrtholinesList.Count - 1) downto 0 do begin JoinedLine := TOrthoLine(TConnectorObject(aSnapLine.JoinConnector2).JoinedOrtholinesList[i]); if JoinedLine.ID <> aSnapLine.ID then begin if not JoinedLine.Deleted then begin TConnectorObject(ASnapLine.JoinConnector2).JoinedOrtholinesList.Remove(JoinedLine); if JoinedLine.JoinConnector1.ID = ASnapLine.JoinConnector2.ID then JoinedLine.SetJConnector1(AddLine.JoinConnector2, True) else if JoinedLine.JoinConnector2.ID = ASnapLine.JoinConnector2.ID then JoinedLine.SetJConnector2(AddLine.JoinConnector2, True); if JoinedLine.FIsRaiseUpDown then begin if JoinedLine.FObjectFromRaisedLine = OldJConn then JoinedLine.FObjectFromRaisedLine := NewJConn; if JoinedLine.JoinConnector1.ID = NewJConn.ID then RaiseConn := TConnectorObject(JoinedLine.JoinConnector2) else RaiseConn := TConnectorObject(JoinedLine.JoinConnector1); if RaiseConn.FObjectFromRaise <> nil then if RaiseConn.FObjectFromRaise.ID = OldJConn.ID then RaiseConn.FObjectFromRaise := NewJConn; end; end; end; end; end; begin // Tolik 09/02/2017 -- ObjToDisconnect := nil; CadRefreshFlag := GCanRefreshCad; GCanRefreshCad := False; // try GtempListCreated := False; if (IsSpecialTraceFigure(ASnapLine)) or (ASnapLine.FIsVertical) then begin GCanRefreshCad := CadRefreshFlag; exit; end; GetOtherConn := nil; //#From Oleg# SavedLineConnectionsList := TList.Create; SavedComponList := TList.Create; // получить лист с присоединенными объектами стороны 2 JoinedConn := TConnectorObject(ASnapLine.JoinConnector2); ObjToDisconnect := TList.Create; if JoinedConn.JoinedConnectorsList.Count > 0 then ObjToDisconnect.Add(JoinedConn.JoinedConnectorsList[0]) else begin for i := 0 to JoinedConn.JoinedOrtholinesList.Count - 1 do if TOrthoLine(JoinedConn.JoinedOrtholinesList[i]) <> ASnapLine then ObjToDisconnect.Add(JoinedConn.JoinedOrtholinesList[i]); end; // Tolik -- попытаться сохранить состояние соединения до ... // если был точечный -- сохраняем на точечном begin DivLineObject := F_ProjMan.GSCSBase.CurrProject.CurrList.GetCatalogFromReferencesBySCSID(ASnapLine.Id); if DivLineObject <> nil then begin for i := 0 to DivLineObject.ComponentReferences.Count - 1 do begin LineCompon := TSCSComponent(DivLineObject.ComponentReferences[i]); if IsCableComponent(LineCompon) then CheckSaveLineConnectionsBySide(ASnapLine, LineCompon, 2); end; end; end; DisJoinOnSide2(aSnapLine); // отсоединить кабели разделяемой трассы на второй стороне DeltaHeight := ASnapLine.ActualZOrder[2] - ASnapLine.ActualZOrder[1]; AllLengthXY := SQRT(SQR(ASnapLine.ActualPoints[1].x - ASnapLine.ActualPoints[2].x) + SQR(ASnapLine.ActualPoints[1].y - ASnapLine.ActualPoints[2].y)); // выравнивать линию? AngleRad := GetLineAngle(ASnapLine.ActualPoints[1], ASnapLine.ActualPoints[2]); if GCadForm.PCad.SnapToGrids then begin if (AngleRad = 0) or (AngleRad = 90) or (AngleRad = 180) or (AngleRad = 270) or (AngleRad = 360) then MustRealign := true else MustRealign := false; end else MustRealign := false; NextConnector := ASnapLine.JoinConnector2; if ASnapLine.ActualPoints[1].x = ASnapLine.ActualPoints[2].x then begin NewDeltaY := 0; NewDeltaX := ASnapLine.ActualPoints[1].x - APointObject.ActualPoints[1].x; APointObject.ActualPoints[1] := DoublePoint(APointObject.ActualPoints[1].x + NewDeltaX, APointObject.ActualPoints[1].y); end else if ASnapLine.ActualPoints[1].y = ASnapLine.ActualPoints[2].y then begin NewDeltaX := 0; NewDeltaY := ASnapLine.ActualPoints[1].y - APointObject.ActualPoints[1].y; APointObject.ActualPoints[1] := DoublePoint(APointObject.ActualPoints[1].x, APointObject.ActualPoints[1].y + NewDeltaY); end else begin NewDeltaX := 0; NewDeltaY := 0; APointObject.ActualPoints[1] := DoublePoint(APointObject.ActualPoints[1].x + NewDeltaX, APointObject.ActualPoints[1].y + NewDeltaY); end; APointObject.DrawFigure.move(NewDeltaX, NewDeltaY); if APointObject.CaptionsGroup <> nil then APointObject.CaptionsGroup.Move(NewDeltaX, NewDeltaY); for i := 0 to APointObject.JoinedOrtholinesList.Count - 1 do begin if APointObject = TOrthoLine(APointObject.JoinedOrtholinesList[i]).JoinConnector1 then begin TOrthoLine(APointObject.JoinedOrtholinesList[i]).ActualPoints[1] := DoublePoint( TOrthoLine(APointObject.JoinedOrtholinesList[i]).ActualPoints[1].x + NewDeltaX, TOrthoLine(APointObject.JoinedOrtholinesList[i]).ActualPoints[1].y + NewDeltaY); end; if APointObject = TOrthoLine(APointObject.JoinedOrtholinesList[i]).JoinConnector2 then begin TOrthoLine(APointObject.JoinedOrtholinesList[i]).ActualPoints[2] := DoublePoint( TOrthoLine(APointObject.JoinedOrtholinesList[i]).ActualPoints[2].x + NewDeltaX, TOrthoLine(APointObject.JoinedOrtholinesList[i]).ActualPoints[2].y + NewDeltaY); end; end; // вычисление точек модификации Modx := APointObject.ActualPoints[1].x; Mody := APointObject.ActualPoints[1].y; NextModx := NextConnector.ActualPoints[1].x; NextMody := NextConnector.ActualPoints[1].y; //Tolik -- 27/02/2018 -- if CompareValue(TConnectorObject(ASnapLine.JoinConnector1).ActualzOrder[1], TConnectorObject(ASnapLine.JoinConnector2).ActualZOrder[1]) = 0 then SnapZ := TConnectorObject(ASnapLine.JoinConnector1).ActualzOrder[1] else // если линая наклонная - вычислить высоту разделения линии SnapZ := GetCoordZ(ASnapLine, APointObject.ap1.x, APointObject.ap1.y); AddLine := TOrthoLine.Create(Modx, Mody, Snapz, ASnapLine.JoinConnector2.ap1.x, ASnapLine.JoinConnector2.ap1.y, TConnectorObject(ASnapLine.JoinConnector2).ActualZOrder[1], 1,ord(psSolid), clBlack, 0, ASnapLine.LayerHandle, mydsNormal, GCadForm.PCad); GCadForm.PCad.AddCustomFigure (GLN(ASnapLine.LayerHandle), AddLine, false); ClearCon2 := TConnectorObject.Create(ASnapLine.JoinConnector2.ap1.x, ASnapLine.JoinConnector2.ap1.y, TConnectorObject(ASnapLine.JoinConnector2).ActualZOrder[1], ASnapLine.LayerHandle, mydsNormal, GCadForm.PCad); ClearCon2.ConnectorType := ct_Clear; GCadForm.PCad.AddCustomFigure (GLN(ASnapLine.LayerHandle), ClearCon2, False); ClearCon2.Name := cCadClasses_Mes12; SetNewObjectNameInPM(ClearCon2.ID, ClearCon2.Name); ObjParams := GetFigureParams(ClearCon2.ID); ClearCon2.Name := ObjParams.Name; ClearCon2.FIndex := ObjParams.MarkID; AddLine.SetJConnector2(TFigure(ClearCon2)); ReconnConnectors; //оторвать второй коннектор разделяемой трассы от всего, к чему присоединен и переключить соединения на коннектор созданной трассы // При соединении конектора с линией, создается 2 линии // переназначение связей линии к которой присоединились новому коннектору ASnapLine.ActualPoints[2] := DoublePoint(Modx, Mody); ASnapLine.ActualZOrder[2] := SnapZ; TConnectorObject(ASnapLine.JoinConnector2).ActualPoints[1] := DoublePoint(Modx, Mody); TConnectorObject(ASnapLine.JoinConnector2).ActualZOrder[1] := SnapZ; //SnapConnectorToConnector(TConnectorObject(AddLine.JoinConnector1), TConnectorObject(ASnapLine.JoinConnector2)); //ConnectCableCompons(ASnapLine, AddLine); AddLine.SetJConnector1(ASnapLine.JoinConnector2); // пересчитать длину первой трассы, которая "ужимается" ASnapLine.CalculLength := ASnapLine.LengthCalc; ASnapLine.LineLength := ASnapLine.CalculLength; ASnapLine.ReCreateCaptionsGroup(True, False, nil, -1, -1); //пересоздать подпись к трассе, чтобы двинула на средину разделяемой трассы, а то так и будет сидеть там, где и была...что не ечть гут if Not ASnapLine.FNotRecalcLength then SetLineFigureLengthInPM(ASnapLine.ID, ASnapLine.LineLength); // если не на одной высоте - создать и приконнектить райз if CompareValue(SnapZ, APointObject.ActualZOrder[1]) = 0 then SnapConnectorToPointObject(TConnectorObject(AddLine.JoinConnector1), APointObject) else begin CreateRaiseOnPointObjectNew(APointObject, SnapZ); RaiseLine := nil; for i := 0 to APointObject.JoinedConnectorsList.Count - 1 do begin for j := 0 to TConnectorObject(APointObject.JoinedConnectorsList[i]).JoinedOrtholinesList.Count - 1 do begin if TOrthoLine(TConnectorObject(APointObject.JoinedConnectorsList[i]).JoinedOrtholinesList[j]).FIsRaiseUpDown then begin RaiseLine := TOrthoLine(TConnectorObject(APointObject.JoinedConnectorsList[i]).JoinedOrtholinesList[j]); break; end; end end; if RaiseLine <> nil then begin RaiseConn := Nil; if CompareValue(SnapZ, TConnectorObject(RaiseLine.JoinConnector1).ActualZOrder[1]) = 0 then RaiseConn := tconnectorObject(RaiseLine.JoinConnector1) else if CompareValue(SnapZ, TConnectorObject(RaiseLine.JoinConnector2).ActualZOrder[1]) = 0 then RaiseConn := tconnectorObject(RaiseLine.JoinConnector2); if RaiseConn <> nil then RaiseConn := SnapConnectorToConnector(RaiseConn, TConnectorObject(ASnapLine.JoinConnector2)); end; end; // отсоединить разделяемую трассу на втором конце (компоненты) DisJoinOnSide2(ASnapLine); //попытаться восстановить состояние соединений на втором конце (как было до... ) DivLineObject := F_ProjMan.GSCSBase.CurrProject.CurrList.GetCatalogFromReferencesBySCSID(ASnapLine.ID); if DivLineObject <> nil then begin for i := 0 to DivLineObject.ComponentReferences.Count - 1 do begin LineCompon := TSCSComponent(DivLineObject.ComponentReferences[i]); if IsCableComponent(LineCompon) then RestoreLineConnectionsBySide(ASnapLine, LineCompon, 2); end; end; FreeAndNil(SavedLineConnectionsList); FreeAndNil(SavedComponList); // Протокол GCadForm.mProtocol.Lines.Add(cEndPoints_Mes1 + APointObject.Name + cCommon_Mes1 + ASnapLine.Name + '"'); except on E: Exception do addExceptionToLogEx('U_Common.SnapPointObjectToOrtholine', E.Message); end; GCanRefreshCad := CadRefreshFlag; GCadForm.PCad.Refresh; end; *) // Tolik -- преобразовать С/П в вертикаль Procedure ConvertRaiseToVertical(var aRise: TOrthoLine); var LineConnector: TConnectorObject; NB_Connector: TConnectorObject; // точечный для выравнивания вертикали DownConn, UpConn: TConnectorObject; // верхний и нижний коннектор begin BaseBeginUpdate; try if not aRise.FIsRaiseUpDown then begin BaseEndUpdate; exit; end; if CompareValue(TConnectorObject(aRise.JoinConnector1).ActualZOrder[1], TConnectorObject(aRise.JoinConnector2).ActualZOrder[1]) = 1 then begin UpConn := TConnectorObject(aRise.JoinConnector1); DownConn := TConnectorObject(aRise.JoinConnector2); end else begin UpConn := TConnectorObject(aRise.JoinConnector2); DownConn := TConnectorObject(aRise.JoinConnector1); end; // Tolik 14/11/2019 -- // вот тут не проебать и не преобразовать случайно магистраль или межэтажку.... if UpConn.FConnRaiseType in [crt_BetweenFloorUp, crt_BetweenFloorDown, crt_TrunkUp, crt_TrunkDown] then begin BaseEndUpdate; exit; end; if DownConn.FConnRaiseType in [crt_BetweenFloorUp, crt_BetweenFloorDown, crt_TrunkUp, crt_TrunkDown] then begin BaseEndUpdate; exit; end; // //BaseBeginUpdate; NB_Connector := Nil; // сбрасываем соединители (наименование в ПМ) if aRise.JoinConnector1 <> nil then begin LineConnector := TConnectorObject(aRise.JoinConnector1); if LineConnector.JoinedConnectorsList.Count > 0 then NB_Connector := TConnectorObject(LineConnector.JoinedConnectorsList[0]); if NB_Connector <> nil then if not NB_Connector.Deleted then begin NB_Connector.FObjectFromRaise := Nil; NB_Connector.FConnRaiseType := crt_None; end; if LineConnector.Name <> cCadClasses_Mes12 then begin LineConnector.Name := cCadClasses_Mes12; if LineConnector.FConnRaiseType <> crt_None then begin LineConnector.FConnRaiseType := crt_None; LineConnector.FObjectFromRaise := nil; LineConnector.LockMove := False; LineConnector.LockModify := False; end; if NB_Connector = nil then SetNewObjectNameInPM(LineConnector.ID, LineConnector.Name); end; end; NB_Connector := Nil; if aRise.JoinConnector2 <> nil then begin LineConnector := TConnectorObject(aRise.JoinConnector2); if NB_Connector = Nil then begin if LineConnector.JoinedConnectorsList.Count > 0 then NB_Connector := TConnectorObject(LineConnector.JoinedConnectorsList[0]); if NB_Connector <> nil then if not NB_Connector.Deleted then begin NB_Connector.FObjectFromRaise := Nil; NB_Connector.FConnRaiseType := crt_None; end; end else if LineConnector.JoinedConnectorsList.Count > 0 then if TConnectorObject(LineConnector.JoinedConnectorsList[0]) <> nil then if not TConnectorObject(LineConnector.JoinedConnectorsList[0]).deleted then TConnectorObject(LineConnector.JoinedConnectorsList[0]).FObjectFromRaise := nil; if LineConnector.Name <> cCadClasses_Mes12 then begin LineConnector.Name := cCadClasses_Mes12; if LineConnector.FConnRaiseType <> crt_None then begin LineConnector.FConnRaiseType := crt_None; LineConnector.FObjectFromRaise := nil; LineConnector.LockMove := False; LineConnector.LockModify := False; end; if NB_Connector = nil then SetNewObjectNameInPM(LineConnector.ID, LineConnector.Name); end; end; // сбрасываем райз aRise.Name := cCadClasses_Mes32; TConnectorObject(aRise.JoinConnector1).FConnRaiseType := crt_None; TConnectorObject(aRise.JoinConnector2).FConnRaiseType := crt_None; TConnectorObject(aRise.JoinConnector1).FObjectFromRaise := Nil; TConnectorObject(aRise.JoinConnector2).FObjectFromRaise := Nil; // выравнивание if NB_Connector <> nil then begin //Tolik 03/08/2021 -- { TConnectorObject(aRise.JoinConnector1).MoveP(Nb_Connector.ActualPoints[1].x - TConnectorObject(aRise.JoinConnector1).ActualPoints[1].x, Nb_Connector.ActualPoints[1].y - TConnectorObject(aRise.JoinConnector1).ActualPoints[1].y, False); TConnectorObject(aRise.JoinConnector2).MoveP(Nb_Connector.ActualPoints[2].x - TConnectorObject(aRise.JoinConnector2).ActualPoints[1].x, Nb_Connector.ActualPoints[2].y - TConnectorObject(aRise.JoinConnector2).ActualPoints[1].y, False); } TConnectorObject(aRise.JoinConnector1).MoveP(Nb_Connector.ActualPoints[1].x - TConnectorObject(aRise.JoinConnector1).ActualPoints[1].x, Nb_Connector.ActualPoints[1].y - TConnectorObject(aRise.JoinConnector1).ActualPoints[1].y, False, False); TConnectorObject(aRise.JoinConnector2).MoveP(Nb_Connector.ActualPoints[2].x - TConnectorObject(aRise.JoinConnector2).ActualPoints[1].x, Nb_Connector.ActualPoints[2].y - TConnectorObject(aRise.JoinConnector2).ActualPoints[1].y, False, False); end; SetNewObjectNameInPM(aRise.ID, aRise.Name); // на всякий (вершину райза поправить ) aRise.ActualZOrder[1] := TConnectorObject(aRise.JoinConnector1).ActualZOrder[1]; aRise.ActualZOrder[2] := TConnectorObject(aRise.JoinConnector2).ActualZOrder[1]; aRise.ActualPoints[1] := TConnectorObject(aRise.JoinConnector1).ActualPoints[1]; aRise.ActualPoints[2] := TConnectorObject(aRise.JoinConnector2).ActualPoints[1]; SetLineFigureCoordZInPM(aRise.ID, 1, aRise.ActualZOrder[1]); SetLineFigureCoordZInPM(aRise.ID, 2, aRise.ActualZOrder[2]); // aRise.FIsRaiseUpDown := False; aRise.FIsVertical := True; aRise.LockMove := False; aRise.LockModify := True; aRise.FLineRaiseType := lrt_None; aRise.CalculLength := aRise.LengthCalc; aRise.LineLength := aRise.CalculLength; aRise.ReCreateDrawFigureBlock; aRise.ReCreateCaptionsGroup(True, false); aRise.UpdateLengthTextBox(True, false); aRise.ReCreateNotesGroup(True); aRise.ReCreateDrawFigureBlock; aRise.ShowCaptions := False; aRise.ShowNotes := False; aRise.IsShowBlock := False; aRise.FObjectFromRaisedLine := Nil; SetConnBringToFront(TConnectorObject(aRise.JoinConnector1)); SetConnBringToFront(TConnectorObject(aRise.JoinConnector2)); RefreshCAD(GCadForm.PCad); //BaseEndUpdate; except on E: exception do AddExceptionToLogEx('U_Common.ConvertRaiseToVertical', E.Message); end; BaseEndUpdate; end; // Tolik -- 15/03/2017 -- возвращает занятую память компика в %(процентах) -- function GetMemInUsePercentage: Integer; var MemoryStatus: TMemoryStatus; begin Result := 0; MemoryStatus.dwLength := SizeOf(MemoryStatus); GlobalMemoryStatus(MemoryStatus); Result := MemoryStatus.dwMemoryLoad; end; function GetMemStatusFull : string; var MemoryStatus: TMemoryStatus; Ms : TMemoryStatusEx; ErrCode : Integer; begin Result := ''; Ms.dwLength := SizeOf(Ms); if GlobalMemoryStatusEx(Ms) = True then begin Result := Result + 'All Comp MEMORY STATUS: ' + #13#10'dwMemoryLoad = ' + FloatToStr(RoundX(Ms.dwMemoryLoad/(1028*1024), 3)) + ' MB' + #13#10'ullTotalPhys = ' + FloatToStr(RoundX((Ms.ullTotalPhys/(1028*1024)), 3)) + ' MB' + #13#10'ullAvailPhys = ' + FloatToStr(RoundX((Ms.ullAvailPhys/(1028*1024)), 3)) + ' MB' + #13#10'ullTotalPageFile = ' + FloatToStr(RoundX((Ms.ullTotalPageFile/(1028*1024)), 3)) + ' MB' + #13#10'ullAvailPageFile = ' + FloatToStr(RoundX((Ms.ullAvailPageFile/(1028*1024)), 3)) + ' MB' + #13#10'ullTotalVirtual = ' + FloatToStr(RoundX(Ms.ullTotalVirtual/(1028*1024), 3)) + ' MB' + #13#10'ullAvailVirtual = ' + FloatToStr(RoundX((Ms.ullAvailVirtual/(1028*1024)), 3)) + ' MB' + #13#10'ullAvailExtendedVirtual = ' + FloatToStr(RoundX((Ms.ullAvailExtendedVirtual/(1028*1024)), 3)) + ' MB' + #13#10; end else begin Result := 'Ошибка!' + #13#10' Код ошибки: ' + IntToStr(ErrCode) + #13#10' Сообщение: ' + SysErrorMessage(ErrCode); end; {MemoryStatus.dwLength := SizeOf(MemoryStatus); GlobalMemoryStatus(MemoryStatus); with MemoryStatus do begin Result := Result + (IntToStr(dwLength) + ' Size of ''MemoryStatus'' record') + #13#10 + (IntToStr(dwMemoryLoad) + '% memory in use') + #13#10 + (IntToStr(dwTotalPhys) + ' Total Physical Memory in bytes') + #13#10 + (IntToStr(dwAvailPhys) + ' Available Physical Memory in bytes') + #13#10 + (IntToStr(dwTotalPageFile) + ' Total Bytes of Paging File') + #13#10 + (IntToStr(dwAvailPageFile) + ' Available bytes in paging file') + #13#10 + (IntToStr(dwTotalVirtual) + ' User Bytes of Address space') + #13#10 + (IntToStr(dwAvailVirtual) + ' Available User bytes of address space'); end;} end; function getAppMemStatus: String; var procMem: TProcessMemoryCounters; currh: THandle; ErrCode: Integer; begin Result := ''; currh := GetCurrentProcess; if MiTeC_PsAPI.GetProcessMemoryInfo(currh, procMem, sizeof(procMem)) then begin { ProcMem.cb ProcMem.PageFaultCount ProcMem.PagefileUsage ProcMem.PeakPagefileUsage ProcMem.PeakWorkingSetSize ProcMem.QuotaNonPagedPoolUsage ProcMem.QuotaPagedPoolUsage ProcMem.QuotaPeakNonPagedPoolUsage ProcMem.QuotaPeakPagedPoolUsage ProcMem.WorkingSetSize } { Memo1.Lines.Add( '================================================================' ); Memo1.Lines.Add('Ошибок стр.: '+ FloatToStr(ProcMem.PageFaultCount) + #13#10 + 'Макс. использ. памяти (Kb): '+ FloatToStr(ProcMem.PeakWorkingSetSize/1024) + #13#10 + 'Выгружаемый пул (макс.): '+ FloatToStr(ProcMem.QuotaPeakPagedPoolUsage) + #13#10 + 'Выгружаемый пул : '+ FloatToStr(ProcMem.QuotaPagedPoolUsage) + #13#10 + 'Невыгруж. пул (макс.): '+ FloatToStr(ProcMem.QuotaPeakNonPagedPoolUsage) + #13#10 + 'Невыгруж. пул : '+ FloatToStr(ProcMem.QuotaNonPagedPoolUsage) + #13#10 + 'Вирт. память (Kb): '+ FloatToStr(ProcMem.PagefileUsage/1024) + #13#10 + 'Макс. вирт. память (Kb): '+ FloatToStr(ProcMem.PeakPagefileUsage/1024) + #13#10 + 'Память (Kb): ' + FloatToStr(ProcMem.WorkingSetSize/1024)); } Result := Result + ' Application MEMORY STATUS: ' + #13#10 +'PageFaultCount: '+ FloatToStr(ProcMem.PageFaultCount) + #13#10 + 'PagefileUsage: '+ FloatToStr(RoundX(ProcMem.PeakWorkingSetSize/(1024*1024),3)) +' MB' + #13#10 + 'PeakPagefileUsage: '+ FloatToStr(RoundX(ProcMem.QuotaPeakPagedPoolUsage/(1024*1024),3)) + ' MB' + #13#10 + 'PeakWorkingSetSize: '+ FloatToStr(ProcMem.QuotaPagedPoolUsage) + #13#10 + 'QuotaNonPagedPoolUsage: '+ FloatToStr(ProcMem.QuotaPeakNonPagedPoolUsage) + #13#10 + 'QuotaPagedPoolUsage: '+ FloatToStr(ProcMem.QuotaNonPagedPoolUsage) + #13#10 + 'QuotaPeakNonPagedPoolUsage: '+ FloatToStr(RoundX(ProcMem.PagefileUsage/(1024*1024), 3)) + ' MB' + #13#10 + 'QuotaPeakPagedPoolUsage: '+ FloatToStr(RoundX(ProcMem.PeakPagefileUsage/(1024*1024), 3)) + ' MB' + #13#10 + 'WorkingSetSize: ' + FloatToStr(RoundX(ProcMem.WorkingSetSize/(1024*1024), 3)) + ' MB' +#13#10; //beep end else begin Result := 'Ошибка!' + #13#10' Код ошибки: ' + IntToStr(ErrCode) + #13#10' Сообщение: ' + SysErrorMessage(ErrCode); end; end; // объект к вертикальной трассе // 06/04/2018 -- Tolik -- старая закомменчена, смотри ниже...что-то там совсем наврочено... // здесь выполнено через снап коннектора (там уже восстановление соединений на втором конце трассы реализовано) procedure SnapPointObjectToVertical(APointObject: TConnectorObject; ASnapLine: TOrthoLine); var i: integer; ClearConn: TConnectorObject; JoinedLine: TOrthoLine; JoinedConn: TConnectorObject; deltax, deltay: Double; function CheckCanSnap : Boolean; // можно ли снапить коннеткор на вертикаль (должен быть между коннекторами вертикали по высоте) begin Result := False; if CompareValue(TConnectorObject(aSnapLine.JoinConnector1).ActualZOrder[1], APointObject.ActualZOrder[1]) = -1 then if CompareValue(TConnectorObject(aSnapLine.JoinConnector2).ActualZOrder[1], APointObject.ActualZOrder[1]) = 1 then Result := True; if not Result then begin if CompareValue(TConnectorObject(aSnapLine.JoinConnector1).ActualZOrder[1], APointObject.ActualZOrder[1]) = 1 then if CompareValue(TConnectorObject(aSnapLine.JoinConnector2).ActualZOrder[1], APointObject.ActualZOrder[1]) = -1 then Result := True; end; end; begin if CheckCanSnap then begin try //придвигаем на место снапа deltax := ASnapLine.ActualPoints[1].x - APointObject.ActualPoints[1].x; deltay := ASnapLine.ActualPoints[1].y - APointObject.ActualPoints[1].y; if ((deltax <> 0) or (deltay <> 0)) then //Tolik 03/08/2021 -- // APointObject.MoveP(deltax, deltay, false); APointObject.MoveP(deltax, deltay, false, False); // //создаем пустой коннектор, который снапнем на трассу JoinedConn := TConnectorObject.Create(APointObject.aP1.x, APointObject.aP1.y, APointObject.ActualZOrder[1], APointObject.LayerHandle, mydsNormal, GCadForm.PCad); JoinedConn.ConnectorType := ct_Clear; GCadForm.PCad.AddCustomFigure (GLN(APointObject.LayerHandle), JoinedConn, false); //снап пустого коннектора на трассу с восстановлением предидущих соединений SnapConnectorToVertical(JoinedConn, ASnapLine, True); //присоединяем к поинту JoinedConn.JoinedConnectorsList.Add(APointObject); APointObject.JoinedConnectorsList.Add(JoinedConn); //Tolik 19/11/2019 -- DeleteObjectFromPM(JoinedConn.ID, JoinedConn.Name); // //создаем коннекторы для трасс на объекте (первый уже есть) for i := 1 to JoinedConn.JoinedOrtholinesList.Count - 1 do begin JoinedLine := TOrthoLine(JoinedConn.JoinedOrtholinesList[i]); ClearConn := TConnectorObject.Create(APointObject.aP1.x, APointObject.aP1.y, APointObject.ActualZOrder[1], APointObject.LayerHandle, mydsNormal, GCadForm.PCad); ClearConn.ConnectorType := ct_Clear; GCadForm.PCad.AddCustomFigure (GLN(APointObject.LayerHandle), ClearConn, false); if JoinedLine.JoinConnector1.ID = JoinedConn.ID then JoinedLine.SetJConnector1(ClearConn) else JoinedLine.SetJConnector2(ClearConn); APointObject.JoinedConnectorsList.Add(ClearConn); ClearConn.JoinedConnectorsList.Add(APointObject); // Tolik 19/11/2019 -- DeleteObjectFromPM(ClearConn.ID, ClearConn.Name); // end; // сбрасываем все трассы, кроме первой, с первого коннектора JoinedLine := TOrthoLine(JoinedConn.JoinedOrthoLinesList[0]); JoinedConn.JoinedOrthoLinesList.Clear; JoinedConn.JoinedOrthoLinesList.Add(JoinedLine); // Протокол GCadForm.mProtocol.Lines.Add(cEndPoints_Mes1 + APointObject.Name + cCommon_Mes1 + ASnapLine.Name + '"'); except on E: Exception do AddExceptionToLogEx('U_Common.SnapPointObjectToVertical', E.Message); end; end; end; (* procedure SnapPointObjectToVertical(APointObject: TConnectorObject; ASnapLine: TOrthoLine); var i, j: integer; NewDeltaX, NewDeltaY: double; AddLine: TOrthoLine; JoinedCon: TConnectorObject; ClearCon1, ClearCon2: TConnectorObject; //NextConnector: TFigure; NextConnector, NB_Conn: TConnectorObject; Modx, Mody, NextModx, NextMody: Double; TempDefaultNum: integer; CurrLine: TOrthoLine; CP_Line: TDoublePoint; DeltaPos: Double; JoinedConn: TConnectorObject; ObjToDisconnect: TList; GetOtherConn: TConnectorObject; function CheckCanSnap : Boolean; // можно ли снапить коннеткор на вертикаль (должен быть между коннекторами вертикали по высоте) begin Result := False; if CompareValue(TConnectorObject(aSnapLine.JoinConnector1).ActualZOrder[1], APointObject.ActualZOrder[1]) = -1 then if CompareValue(TConnectorObject(aSnapLine.JoinConnector2).ActualZOrder[1], APointObject.ActualZOrder[1]) = 1 then Result := True; if not Result then begin if CompareValue(TConnectorObject(aSnapLine.JoinConnector1).ActualZOrder[1], APointObject.ActualZOrder[1]) = 1 then if CompareValue(TConnectorObject(aSnapLine.JoinConnector2).ActualZOrder[1], APointObject.ActualZOrder[1]) = -1 then Result := True; end; end; begin if CheckCanSnap then begin // Tolik 09/02/2017 -- ObjToDisconnect := nil; // try GetOtherConn := nil; APointObject.MoveConnector(ASnapLine.ActualPoints[1].x - APointObject.ActualPoints[1].x, ASnapLine.ActualPoints[1].y - APointObject.ActualPoints[1].y, false, true); if CompareValue(TConnectorObject(ASnapLine.JoinConnector2).ActualZOrder[1], APointObject.ActualZOrder[1]) = 1 then JoinedConn := TConnectorObject(ASnapLine.JoinConnector2) else JoinedConn := TConnectorObject(ASnapLine.JoinConnector1); ObjToDisconnect := TList.Create; if JoinedConn.JoinedConnectorsList.Count > 0 then begin ObjToDisconnect.Add(JoinedConn.JoinedConnectorsList[0]); JoinedConn.JoinedconnectorsList.Clear; end else begin for i := 0 to JoinedConn.JoinedOrtholinesList.Count - 1 do if TOrthoLine(JoinedConn.JoinedOrtholinesList[i]) <> ASnapLine then ObjToDisconnect.Add(JoinedConn.JoinedOrtholinesList[i]); JoinedConn.JoinedOrthoLinesList.Clear; JoinedConn.JoinedOrthoLinesList.Add(ASnapLine); end; // добавить новую ортолинию { AddLine := TOrthoLine.Create(Modx, Mody, APointObject.ActualZOrder[1], NextModx, NextMody, JoinedConn.ActualZOrder[1], 1,ord(psSolid), clBlack, 0, ASnapLine.LayerHandle, mydsNormal, GCadForm.PCad);} AddLine := TOrthoLine.Create(JoinedConn.aP1.x, JoinedConn.aP1.y, APointObject.ActualZOrder[1], JoinedConn.aP1.x, JoinedConn.aP1.y, JoinedConn.ActualZOrder[1], 1,ord(psSolid), clBlack, 0, ASnapLine.LayerHandle, mydsNormal, GCadForm.PCad); GCadForm.PCad.AddCustomFigure (GLN(ASnapLine.LayerHandle), AddLine, false); GDefaultNum := TempDefaultNum; // создать пустые конекторы //ClearCon1 := TConnectorObject.Create(Modx, Mody, APointObject.ActualZOrder[1], AddLine.LayerHandle, mydsNormal, GCadForm.PCad); ClearCon1 := TConnectorObject.Create(JoinedConn.aP1.x, JoinedConn.aP1.y, APointObject.ActualZOrder[1], AddLine.LayerHandle, mydsNormal, GCadForm.PCad); ClearCon1.ConnectorType := ct_Clear; GCadForm.PCad.AddCustomFigure (GLN(AddLine.LayerHandle), ClearCon1, false); //ClearCon2 := TConnectorObject.Create(Modx, Mody, JoinedConn.ActualZOrder[1], AddLine.LayerHandle, mydsNormal, GCadForm.PCad); ClearCon2 := TConnectorObject.Create(JoinedConn.aP1.x, JoinedConn.aP1.y, JoinedConn.ActualZOrder[1], AddLine.LayerHandle, mydsNormal, GCadForm.PCad); ClearCon2.ConnectorType := ct_Clear; GCadForm.PCad.AddCustomFigure (GLN(AddLine.LayerHandle), ClearCon2, false); AddLine.SetJConnector1(ClearCon1); AddLine.SetJConnector2(ClearCon2); GTempJoinedLinesConnectors.Clear; JoinedConn.ActualZOrder[1] := aPointObject.ActualZOrder[1]; //SnapConnectorToPointObject(ClearCon1, APointObject); ClearCon1.JoinedConnectorsList.Add(aPointObject); APointObject.JoinedConnectorsList.Add(ClearCon1); //SnapConnectorToPointObject(JoinedConn, APointObject); JoinedConn.JoinedConnectorsList.Add(aPointObject); APointObject.JoinedconnectorsList.Add(JoinedConn); // перерасчет длины новой линии ASnapLine.CalculLength := ASnapLine.LengthCalc; ASnapLine.LineLength := ASnapLine.CalculLength; ASnapLine.UpdateLengthTextBox(false, true); SetLineFigureLengthInPM(ASnapLine.ID, ASnapLine.LineLength); // передвинуть TextBoxesGroup if ASnapLine.CaptionsGroup <> nil then begin CP_Line.x := (ASnapLine.ActualPoints[1].x + ASnapLine.ActualPoints[2].x) / 2; CP_Line.y := (ASnapLine.ActualPoints[1].y + ASnapLine.ActualPoints[2].y) / 2; ASnapLine.CaptionsGroup.Move(CP_Line.x - ASnapLine.CaptionsGroup.CenterPoint.x, CP_Line.y - ASnapLine.CaptionsGroup.CenterPoint.y); end; SetLineFigureLengthInPM(AddLine.ID, AddLine.LineLength); // передвинуть TextBoxesGroup if AddLine.CaptionsGroup <> nil then begin CP_Line.x := (AddLine.ActualPoints[1].x + AddLine.ActualPoints[2].x) / 2; CP_Line.y := (AddLine.ActualPoints[1].y + AddLine.ActualPoints[2].y) / 2; AddLine.CaptionsGroup.Move(CP_Line.x - AddLine.CaptionsGroup.CenterPoint.x, CP_Line.y - AddLine.CaptionsGroup.CenterPoint.y); end; GFigureSnap := Nil; if ObjToDisconnect.Count > 0 then begin if CheckFigureByClassNAme(TFigure(ObjToDisconnect[0]), ctConnectorObject) then begin NB_Conn := TConnectorObject(ObjToDisconnect[0]); SnapPointObjectToConnector(NB_Conn, ClearCon2); end else begin for i := 0 to ObjToDisconnect.Count - 1 do begin CurrLine := TOrthoLine(ObjToDisconnect[i]); if CurrLine.JoinConnector1.ID = JoinedConn.Id then CurrLine.SetJConnector1(ClearCon2) else CurrLine.SetJConnector2(ClearCon2); end; end; end; AutoConnectObjectInTrace(APointObject, ASnapLine, AddLine); SetConnBringToFront(APointObject); // Протокол GCadForm.mProtocol.Lines.Add(cEndPoints_Mes1 + APointObject.Name + cCommon_Mes1 + ASnapLine.Name + '"'); // продолжить трассу на новый отрезок //AutoConnectOverDivideLine(APointObject, GetOtherConn, ASnapLine, AddLine); //AutoConnectOverDivideLine(GetOtherConn, APointObject, AddLine); // !!! AddLine.FTraceColor := ASnapLine.FTraceColor; AddLine.FTraceStyle := ASnapLine.FTraceStyle; AddLine.FTraceWidth := ASnapLine.FTraceWidth; AddLine.FLineType := ASnapLine.FLineType; AddLine.FDrawFigurePercent := ASnapLine.FDrawFigurePercent; AddLine.BlockStep := ASnapLine.BlockStep; AddLine.DrawFigureH := 0; AddLine.CaptionsGroupH := 0; ASnapLine.DrawFigureH := 0; ASnapLine.CaptionsGroupH := 0; ASnapLine.ReCreateCaptionsGroup(false, false); ASnapLine.ReCreateNotesGroup; ASnapLine.ReCreateDrawFigureBlock; AddLine.ReCreateCaptionsGroup(false, false); AddLine.ReCreateNotesGroup; AddLine.ReCreateDrawFigureBlock; AddLine.ShowCaptions := False; AddLine.ShowNotes := False; AddLine.IsShowBlock := False; AddLine.FIsVertical := True; if ObjToDisconnect <> nil then FreeAndNil(ObjToDisconnect); except on E: Exception do AddExceptionToLogEx('U_Common.SnapPointObjectToVertical', E.Message); end; end; end; *) (* procedure SnapPointObjectToVertical(APointObject: TConnectorObject; ASnapLine: TOrthoLine); var i, j: integer; NewDeltaX, NewDeltaY: double; AddLine: TOrthoLine; JoinedCon: TConnectorObject; ClearCon1, ClearCon2: TConnectorObject; NextConnector: TFigure; Modx, Mody, NextModx, NextMody: Double; TempDefaultNum: integer; CurrentLine: TOrthoLine; CP_Line: TDoublePoint; DeltaPos: Double; JoinedConn: TConnectorObject; ObjToDisconnect: TList; GetOtherConn: TConnectorObject; begin // Tolik 09/02/2017 -- ObjToDisconnect := nil; // try GetOtherConn := nil; APointObject.MoveConnector(ASnapLine.ActualPoints[1].x - APointObject.ActualPoints[1].x, ASnapLine.ActualPoints[1].y - APointObject.ActualPoints[1].y, false, true); JoinedConn := TConnectorObject(ASnapLine.JoinConnector2); ObjToDisconnect := TList.Create; if JoinedConn.JoinedConnectorsList.Count > 0 then ObjToDisconnect.Add(JoinedConn.JoinedConnectorsList[0]) else begin for i := 0 to JoinedConn.JoinedOrtholinesList.Count - 1 do if TOrthoLine(JoinedConn.JoinedOrtholinesList[i]) <> ASnapLine then ObjToDisconnect.Add(JoinedConn.JoinedOrtholinesList[i]); end; if (ASnapLine.ActualZOrder[2] > APointObject.ActualZOrder[1]) and (ASnapLine.ActualZOrder[1] < APointObject.ActualZOrder[1]) then DeltaPos := APointObject.ActualZOrder[1] else DeltaPos := (ASnapLine.ActualZOrder[1] + ASnapLine.ActualZOrder[2]) / 2; // выравнивать линию? NextConnector := ASnapLine.JoinConnector2; // вычисление точек модификации Modx := APointObject.ActualPoints[1].x; Mody := APointObject.ActualPoints[1].y; NextModx := NextConnector.ActualPoints[1].x; NextMody := NextConnector.ActualPoints[1].y; // При соединении конектора с линией, создается 2 линии // переназначение связей линии к которой присоединились новому коннектору ASnapLine.ActualPoints[2] := DoublePoint(Modx, Mody); // добавить новую ортолинию TempDefaultNum := GDefaultNum; GDefaultNum := ASnapLine.FCount; GDefaultGap := ASnapLine.FGap; AddLine := TOrthoLine.Create(Modx, Mody, ASnapLine.ActualZOrder[2], NextModx, NextMody, ASnapLine.ActualZOrder[2], 1,ord(psSolid), clBlack, 0, ASnapLine.LayerHandle, mydsNormal, GCadForm.PCad); GCadForm.PCad.AddCustomFigure (GLN(ASnapLine.LayerHandle), AddLine, false); GDefaultNum := TempDefaultNum; // создать пустые конекторы ClearCon1 := TConnectorObject.Create(Modx, Mody, GCadForm.FConnHeight, AddLine.LayerHandle, mydsNormal, GCadForm.PCad); ClearCon1.ConnectorType := ct_Clear; GCadForm.PCad.AddCustomFigure (GLN(AddLine.LayerHandle), ClearCon1, false); ClearCon2 := TConnectorObject.Create(Modx, Mody, GCadForm.FConnHeight, AddLine.LayerHandle, mydsNormal, GCadForm.PCad); ClearCon2.ConnectorType := ct_Clear; GCadForm.PCad.AddCustomFigure (GLN(AddLine.LayerHandle), ClearCon2, false); ASnapLine.SetJConnector2(ClearCon1); TConnectorObject(NextConnector).JoinedOrtholinesList.Remove(ASnapLine); // присвоить связи новой ортолинии AddLine.SetJConnector1(ClearCon2); AddLine.SetJConnector2(NextConnector); GTempJoinedLinesConnectors.Clear; // commented by Tolik 25/03/2016 -- на снапе коннектора список все равно сбросится и построится заново { for i := 0 to ClearCon1.JoinedOrtholinesList.Count - 1 do begin JoinedCon := TConnectorObject(TOrthoLine(ClearCon1.JoinedOrtholinesList[i]).JoinConnector1); if JoinedCon <> ClearCon1 then GTempJoinedLinesConnectors.Add(JoinedCon); JoinedCon := TConnectorObject(TOrthoLine(ClearCon1.JoinedOrtholinesList[i]).JoinConnector2); if JoinedCon <> ClearCon1 then GTempJoinedLinesConnectors.Add(JoinedCon); end;} SnapConnectorToPointObject(ClearCon1, APointObject); GTempJoinedLinesConnectors.Clear; // commented by Tolik 25/03/2016 -- на снапе коннектора список все равно сбросится и построится заново {for i := 0 to ClearCon2.JoinedOrtholinesList.Count - 1 do begin JoinedCon := TConnectorObject(TOrthoLine(ClearCon2.JoinedOrtholinesList[i]).JoinConnector1); if JoinedCon <> ClearCon2 then GTempJoinedLinesConnectors.Add(JoinedCon); JoinedCon := TConnectorObject(TOrthoLine(ClearCon2.JoinedOrtholinesList[i]).JoinConnector2); if JoinedCon <> ClearCon2 then GTempJoinedLinesConnectors.Add(JoinedCon); end;} SnapConnectorToPointObject(ClearCon2, APointObject); APointObject.ActualZOrder[1] := DeltaPos; ClearCon1.ActualZOrder[1] := APointObject.ActualZOrder[1]; ClearCon2.ActualZOrder[1] := APointObject.ActualZOrder[1]; ASnapLine.ActualZOrder[2] := APointObject.ActualZOrder[1]; AddLine.ActualZOrder[1] := APointObject.ActualZOrder[1]; // перерасчет длины новой линии ASnapLine.CalculLength := ASnapLine.LengthCalc; ASnapLine.LineLength := ASnapLine.CalculLength; ASnapLine.UpdateLengthTextBox(false, true); SetLineFigureLengthInPM(ASnapLine.ID, ASnapLine.LineLength); // передвинуть TextBoxesGroup if ASnapLine.CaptionsGroup <> nil then begin CP_Line.x := (ASnapLine.ActualPoints[1].x + ASnapLine.ActualPoints[2].x) / 2; CP_Line.y := (ASnapLine.ActualPoints[1].y + ASnapLine.ActualPoints[2].y) / 2; ASnapLine.CaptionsGroup.Move(CP_Line.x - ASnapLine.CaptionsGroup.CenterPoint.x, CP_Line.y - ASnapLine.CaptionsGroup.CenterPoint.y); end; // перерасчет длины созданной линии AddLine.CalculLength := AddLine.LengthCalc; AddLine.LineLength := AddLine.CalculLength; AddLine.UpdateLengthTextBox(false, false); SetLineFigureLengthInPM(AddLine.ID, AddLine.LineLength); // передвинуть TextBoxesGroup if AddLine.CaptionsGroup <> nil then begin CP_Line.x := (AddLine.ActualPoints[1].x + AddLine.ActualPoints[2].x) / 2; CP_Line.y := (AddLine.ActualPoints[1].y + AddLine.ActualPoints[2].y) / 2; AddLine.CaptionsGroup.Move(CP_Line.x - AddLine.CaptionsGroup.CenterPoint.x, CP_Line.y - AddLine.CaptionsGroup.CenterPoint.y); end; GFigureSnap := Nil; AutoConnectObjectInTrace(APointObject, ASnapLine, AddLine); // выровнять линии ReAlignObject(APointObject); ReAlignLine(ASnapLine); ReAlignLine(AddLine); SetConnBringToFront(APointObject); ReCalcZCoordSnapObjects(APointObject); // Протокол GCadForm.mProtocol.Lines.Add(cEndPoints_Mes1 + APointObject.Name + cCommon_Mes1 + ASnapLine.Name + '"'); // продолжить трассу на новый отрезок JoinedConn := TConnectorObject(AddLine.JoinConnector1); if JoinedConn.JoinedConnectorsList.Count > 0 then begin if TConnectorObject(JoinedConn.JoinedConnectorsList[0]) = APointObject then begin GetOtherConn := TConnectorObject(AddLine.JoinConnector2); if GetOtherConn.JoinedConnectorsList.Count > 0 then GetOtherConn := TConnectorObject(GetOtherConn.JoinedConnectorsList[0]); end; end; JoinedConn := TConnectorObject(AddLine.JoinConnector2); if JoinedConn.JoinedConnectorsList.Count > 0 then begin if TConnectorObject(JoinedConn.JoinedConnectorsList[0]) = APointObject then begin GetOtherConn := TConnectorObject(AddLine.JoinConnector1); if GetOtherConn.JoinedConnectorsList.Count > 0 then GetOtherConn := TConnectorObject(GetOtherConn.JoinedConnectorsList[0]); end; end; AutoConnectOverDivideLine(APointObject, GetOtherConn, ASnapLine, AddLine); //AutoConnectOverDivideLine(GetOtherConn, APointObject, AddLine); // !!! AddLine.FTraceColor := ASnapLine.FTraceColor; AddLine.FTraceStyle := ASnapLine.FTraceStyle; AddLine.FTraceWidth := ASnapLine.FTraceWidth; AddLine.FLineType := ASnapLine.FLineType; AddLine.FDrawFigurePercent := ASnapLine.FDrawFigurePercent; AddLine.BlockStep := ASnapLine.BlockStep; AddLine.DrawFigureH := 0; AddLine.CaptionsGroupH := 0; ASnapLine.DrawFigureH := 0; ASnapLine.CaptionsGroupH := 0; ASnapLine.ReCreateCaptionsGroup(false, false); ASnapLine.ReCreateNotesGroup; ASnapLine.ReCreateDrawFigureBlock; AddLine.ReCreateCaptionsGroup(false, false); AddLine.ReCreateNotesGroup; AddLine.ReCreateDrawFigureBlock; AddLine.ShowCaptions := False; AddLine.ShowNotes := False; AddLine.IsShowBlock := False; AddLine.FIsVertical := True; if ObjToDisconnect <> nil then FreeAndNil(ObjToDisconnect); except on E: Exception do AddExceptionToLogEx('U_Common.SnapPointObjectToVertical', E.Message); end; end; *) Procedure FillPOintsForConnect(SideConn,APointObject,ConnectedConn: TConnectorObject; AddDeltaX, AddDeltaY: Double; var Points: TDoublePointArr; var CrossPoints: array of Tdoublepoint); begin if (not APointObject.FDrawFigureMoved)and(APointObject.FDrawFigureAngle = 0) then if not HaveObjectSocketComponent(APointObject.ID) then begin CrossPoints[0] := GetCrossPoint(SideConn.ActualPoints[1].x, SideConn.ActualPoints[1].y, ConnectedConn.ActualPoints[1].x, ConnectedConn.ActualPoints[1].y, APointObject.ActualPoints[1].x - APointObject.GrpSizeX / 2 + AddDeltaX, APointObject.ActualPoints[1].y + APointObject.GrpSizeY / 2 - AddDeltaY, APointObject.ActualPoints[1].x - APointObject.GrpSizeX / 2 + AddDeltaX, APointObject.ActualPoints[1].y - APointObject.GrpSizeY / 2 + AddDeltaY); CrossPoints[1] := GetCrossPoint(SideConn.ActualPoints[1].x, SideConn.ActualPoints[1].y, ConnectedConn.ActualPoints[1].x, ConnectedConn.ActualPoints[1].y, APointObject.ActualPoints[1].x - APointObject.GrpSizeX / 2 + AddDeltaX, APointObject.ActualPoints[1].y - APointObject.GrpSizeY / 2 + AddDeltaY, APointObject.ActualPoints[1].x + APointObject.GrpSizeX / 2 - AddDeltaX, APointObject.ActualPoints[1].y - APointObject.GrpSizeY / 2 + AddDeltaY); CrossPoints[2] := GetCrossPoint(SideConn.ActualPoints[1].x, SideConn.ActualPoints[1].y, ConnectedConn.ActualPoints[1].x, ConnectedConn.ActualPoints[1].y, APointObject.ActualPoints[1].x + APointObject.GrpSizeX / 2 - AddDeltaX, APointObject.ActualPoints[1].y - APointObject.GrpSizeY / 2 + AddDeltaY, APointObject.ActualPoints[1].x + APointObject.GrpSizeX / 2 - AddDeltax, APointObject.ActualPoints[1].y + APointObject.GrpSizeY / 2 - AddDeltaY); CrossPoints[3] := GetCrossPoint(SideConn.ActualPoints[1].x, SideConn.ActualPoints[1].y, ConnectedConn.ActualPoints[1].x, ConnectedConn.ActualPoints[1].y, APointObject.ActualPoints[1].x + APointObject.GrpSizeX / 2 - AddDeltaX, APointObject.ActualPoints[1].y + APointObject.GrpSizeY / 2 - AddDeltaY, APointObject.ActualPoints[1].x - APointObject.GrpSizeX / 2 + AddDeltaX, APointObject.ActualPoints[1].y + APointObject.GrpSizeY / 2 - AddDeltaY); SetLength(Points, 4); Points[0].x := (APointObject.ActualPoints[1].x - APointObject.GrpSizeX / 2 + AddDeltaX) - 0.1; Points[0].y := (APointObject.ActualPoints[1].y + APointObject.GrpSizeY / 2 - AddDeltaY) + 0.1; Points[1].x := (APointObject.ActualPoints[1].x - APointObject.GrpSizeX / 2 + AddDeltaX) - 0.1; Points[1].y := (APointObject.ActualPoints[1].y - APointObject.GrpSizeY / 2 + AddDeltaY) - 0.1; Points[2].x := (APointObject.ActualPoints[1].x + APointObject.GrpSizeX / 2 - AddDeltaX) + 0.1; Points[2].y := (APointObject.ActualPoints[1].y - APointObject.GrpSizeY / 2 + AddDeltaY) - 0.1; Points[3].x := (APointObject.ActualPoints[1].x + APointObject.GrpSizeX / 2 - AddDeltaX) + 0.1; Points[3].y := (APointObject.ActualPoints[1].y + APointObject.GrpSizeY / 2 - AddDeltaY) + 0.1; end else begin CrossPoints[0] := GetCrossPoint(SideConn.ActualPoints[1].x, SideConn.ActualPoints[1].y, ConnectedConn.ActualPoints[1].x, ConnectedConn.ActualPoints[1].y, APointObject.ActualPoints[1].x, APointObject.ActualPoints[1].y + APointObject.GrpSizeY / 2 - AddDeltaY, APointObject.ActualPoints[1].x, APointObject.ActualPoints[1].y - APointObject.GrpSizeY / 2 + AddDeltaY); CrossPoints[1] := GetCrossPoint(SideConn.ActualPoints[1].x, SideConn.ActualPoints[1].y, ConnectedConn.ActualPoints[1].x, ConnectedConn.ActualPoints[1].y, APointObject.ActualPoints[1].x, APointObject.ActualPoints[1].y - APointObject.GrpSizeY / 2 + AddDeltaY, APointObject.ActualPoints[1].x + APointObject.GrpSizeX - 2*AddDeltaX, APointObject.ActualPoints[1].y - APointObject.GrpSizeY / 2 + AddDeltaY); CrossPoints[2] := GetCrossPoint(SideConn.ActualPoints[1].x, SideConn.ActualPoints[1].y, ConnectedConn.ActualPoints[1].x, ConnectedConn.ActualPoints[1].y, APointObject.ActualPoints[1].x + APointObject.GrpSizeX - 2*AddDeltaX, APointObject.ActualPoints[1].y - APointObject.GrpSizeY / 2 + AddDeltaY, APointObject.ActualPoints[1].x + APointObject.GrpSizeX - 2*AddDeltaX, APointObject.ActualPoints[1].y + APointObject.GrpSizeY / 2 - AddDeltaY); CrossPoints[3] := GetCrossPoint(SideConn.ActualPoints[1].x, SideConn.ActualPoints[1].y, ConnectedConn.ActualPoints[1].x, ConnectedConn.ActualPoints[1].y, APointObject.ActualPoints[1].x + APointObject.GrpSizeX - 2*AddDeltaX, APointObject.ActualPoints[1].y + APointObject.GrpSizeY / 2 - AddDeltaY, APointObject.ActualPoints[1].x, APointObject.ActualPoints[1].y + APointObject.GrpSizeY / 2 - AddDeltaY); SetLength(Points, 4); Points[0].x := (APointObject.ActualPoints[1].x) - 0.1; Points[0].y := (APointObject.ActualPoints[1].y + APointObject.GrpSizeY / 2 - AddDeltaY) + 0.1; Points[1].x := (APointObject.ActualPoints[1].x) - 0.1; Points[1].y := (APointObject.ActualPoints[1].y - APointObject.GrpSizeY / 2 + AddDeltaY) - 0.1; Points[2].x := (APointObject.ActualPoints[1].x + APointObject.GrpSizeX - 2 * AddDeltaX) + 0.1; Points[2].y := (APointObject.ActualPoints[1].y - APointObject.GrpSizeY / 2 + AddDeltaY) - 0.1; Points[3].x := (APointObject.ActualPoints[1].x + APointObject.GrpSizeX - 2 * AddDeltaX) + 0.1; Points[3].y := (APointObject.ActualPoints[1].y + APointObject.GrpSizeY / 2 - AddDeltaY) + 0.1; end; end; // Tolik -- старая -- НЕ ЛОМАТЬ!!! // ПРИВЯЗКА ПУСТОГО КОНЕКТОРА К ОБЬЕКТУ // 03/04/2018 -- переписана нах.... старая закомменчена - смотри ниже ... Procedure SnapConnectorToPointObject(AConnector, APointObject: TConnectorObject; AOnRaise: Boolean = false; ASnapObjectToLine: Boolean = false); var i, j: integer; CurrLine: TOrthoLine; isExistInList: Boolean; isInRegion: Boolean; CurrConnector: TConnectorObject; SideConn: TConnectorObject; ConnectedConn: TConnectorObject; Points: TDoublePointArr; CrossPoints: array [1..4] of TDoublePoint; RegHandle: HRGN; MinLength: Double; CurrLength: Double; ConnectToPoint: TDoublePoint; SaveFigureSnap: TFigure; SavePrevFigureSnap: TFigure; LHandle: integer; TempNewConnList: TList; JoinedLine: TOrthoLine; JoinedConn: TConnectorObject; RaiseConn: TConnectorObject; RaiseLine: TOrthoLine; OtherList: TF_CAD; OtherRaise: TConnectorObject; AddDeltaX, AddDeltaY: double; ComponWidth: Double; SnapGrids,SnapGuides: Boolean; // Tolik -- 20/04/2017 -- AConnectorJoinedLines_Count: Integer; FirstLineIndex: Integer; function GetConnectorNotDeletedLines(AConn: TConnectorObject): Integer; var i: Integer; begin Result := 0; FirstLineIndex := 0; for i := 0 to aConn.JoinedOrthoLinesList.Count - 1 do begin if not TOrthoLine(AConn.JoinedOrtholinesList[i]).Deleted then begin Inc(Result); if FirstLineIndex = 0 then FirstLineIndex := i + 1; end; end; end; // begin // Tolik -- 09/02/2017 -- TempNewConnList := nil; //Tolik -- 20/04/2017 -- if (AConnector.Deleted or APointObject.Deleted) then Exit; if aPointObject.JoinedConnectorsList.IndexOf(AConnector) <> -1 then exit; AConnectorJoinedLines_Count := GetConnectorNotDeletedLines(AConnector); // try if CompareValue(APointObject.ActualZOrder[1], AConnector.ActualZOrder[1]) = 0 then begin CheckingSnapConnectorToPointObject(AConnector, APointObject, False); exit; end; APointObject.FConnRaiseType := AConnector.FConnRaiseType; if (AConnector.FConnRaiseType = crt_BetweenFloorUp) or (AConnector.FConnRaiseType = crt_BetweenFloorDown) or (AConnector.FConnRaiseType = crt_TrunkUp) or (AConnector.FConnRaiseType = crt_TrunkDown) then begin APointObject.FID_ConnToPassage := AConnector.FID_ConnToPassage; APointObject.FID_ListToPassage := AConnector.FID_ListToPassage; OtherList := GetListByID(AConnector.FID_ListToPassage); if OtherList <> nil then begin OtherRaise := TConnectorObject(GetFigureByID(OtherList, AConnector.FID_ConnToPassage)); if OtherRaise <> nil then OtherRaise.FID_ConnToPassage := APointObject.ID; end; end; APointObject.FObjectFromRaise := AConnector.FObjectFromRaise; AConnector.FConnRaiseType := crt_None; AConnector.FObjectFromRaise := nil; AConnector.FID_ConnToPassage := -1; AConnector.FID_ListToPassage := -1; TempNewConnList := TList.Create; LHandle := GCadForm.PCad.GetLayerHandle(2); isExistInList := False; for i := 0 to APointObject.JoinedConnectorsList.Count - 1 do begin CurrConnector := TConnectorObject(APointObject.JoinedConnectorsList[i]); if CurrConnector = AConnector then isExistInList := True; end; if not isExistInList then begin APointObject.JoinedConnectorslist.Add(AConnector); AConnector.JoinedConnectorslist.Add(APointObject); DeleteObjectFromPM(AConnector.ID, AConnector.Name);// Tolik 19/11/2019 -- end; // Tolik 31/03/2016 -- // GTempJoinedLinesConnectors.Clear if GTempJoinedLinesConnectors <> nil then GTempJoinedLinesConnectors.Clear else GTempJoinedLinesConnectors := TList.Create; // for i := 0 to AConnector.JoinedOrtholinesList.Count - 1 do begin // Tolik 20/04/2017 -- CurrLine := TOrthoLine(AConnector.JoinedOrtholinesList[i]); if not CurrLine.deleted then begin SideConn := TConnectorObject(CurrLine.JoinConnector1); if SideConn <> AConnector then GTempJoinedLinesConnectors.Add(SideConn); SideConn := TConnectorObject(CurrLine.JoinConnector2); if SideConn <> AConnector then GTempJoinedLinesConnectors.Add(SideConn); end; { SideConn := TConnectorObject(TOrthoLine(AConnector.JoinedOrtholinesList[i]).JoinConnector1); if SideConn <> AConnector then GTempJoinedLinesConnectors.Add(SideConn); SideConn := TConnectorObject(TOrthoLine(AConnector.JoinedOrtholinesList[i]).JoinConnector2); if SideConn <> AConnector then GTempJoinedLinesConnectors.Add(SideConn); } // end; // если разветвление !!! // Tolik -- 20/04/2017 -- // if AConnector.JoinedOrtholinesList.Count > 1 then if AConnectorJoinedLines_Count > 1 then begin //Tolik 20/04/2017 -- //for i := 1 to AConnector.JoinedOrtholinesList.Count - 1 do for i := FirstLineIndex to AConnector.JoinedOrtholinesList.Count - 1 do begin CurrLine := TOrthoLine(AConnector.JoinedOrtholinesList[i]); // Tolik 20/04/2017 -- if not CurrLine.deleted then begin if TConnectorObject(TOrthoLine(CurrLine.JoinConnector1)) = AConnector then begin CurrLine.JoinConnector1 := nil; ConnectedConn := TConnectorObject.Create(CurrLine.ActualPoints[1].x, CurrLine.ActualPoints[1].y, AConnector.ActualZOrder[1], LHandle, mydsNormal, GCadForm.PCad); ConnectedConn.ConnectorType := ct_Clear; GCadForm.PCad.AddCustomFigure (GLN(LHandle), ConnectedConn, False); CurrLine.SetJConnector1(ConnectedConn); APointObject.JoinedConnectorsList.Add(ConnectedConn); ConnectedConn.JoinedConnectorsList.Add(APointObject); DeleteObjectFromPM(ConnectedConn.ID, ConnectedConn.Name); // Tolik 19/11/2019 -- TempNewConnList.Add(ConnectedConn); end; if TConnectorObject(TOrthoLine(CurrLine.JoinConnector2)) = AConnector then begin CurrLine.JoinConnector2 := nil; ConnectedConn := TConnectorObject.Create(CurrLine.ActualPoints[2].x, CurrLine.ActualPoints[2].y, AConnector.ActualZOrder[1], LHandle, mydsNormal, GCadForm.PCad); ConnectedConn.ConnectorType := ct_Clear; GCadForm.PCad.AddCustomFigure (GLN(LHandle), ConnectedConn, False); CurrLine.SetJConnector2(ConnectedConn); APointObject.JoinedConnectorsList.Add(ConnectedConn); ConnectedConn.JoinedConnectorsList.Add(APointObject); DeleteObjectFromPM(ConnectedConn.ID, ConnectedConn.Name); // Tolik 19/11/2019 -- TempNewConnList.Add(ConnectedConn); end; end; end; // Tolik -- 20/04/2017 -- сбросить с коннектора все (кроме первой ) НЕ УДАЛЕННЫЕ трассы j := FirstLineIndex; for j := AConnector.JoinedOrtholinesList.Count - 1 downto FirstLineIndex do begin if not TOrthoLine(AConnector.JoinedOrtholinesList[j]).Deleted then AConnector.JoinedOrtholinesList.Delete(j); end; { j := 1; while j < AConnector.JoinedOrtholinesList.Count do begin AConnector.JoinedOrtholinesList.Delete(j); end; } end; // получить точки пересечения линии с обьектом for i := 0 to GTempJoinedLinesConnectors.Count - 1 do begin if i = 0 then ConnectedConn := AConnector else if i > 0 then ConnectedConn := TConnectorObject(TempNewConnList[i - 1]); SideConn := TConnectorObject(GTempJoinedLinesConnectors[i]); if (APointObject.DrawFigure.InFigures.Count = 1) and CheckFigureByClassName(TFigure(APointObject.DrawFigure.InFigures[0]), 'TWMFObject') then begin //FormatFloat(ffMask, AObject.FDrawFigureAngle / pi * 180); ComponWidth := APointObject.DrawFigure.GetBoundRect.Right - APointObject.DrawFigure.GetBoundRect.Left; AddDeltaX := 0.04 * ComponWidth; AddDeltaY := APointObject.GrpSizeY * 0.04; end else begin AddDeltaX := 0; AddDeltaY := 0; end; //Внутри делает то, что ниже.Для экономии места, так как код повторяется ниже по коду FillPOintsForConnect(SideConn,APointObject,ConnectedConn,AddDeltaX, AddDeltaY,Points,CrossPoints); // создать регион точек точечного обьекта MinLength := 0; CurrLength := 0; ConnectToPoint.x := 0; ConnectToPoint.y := 0; isInRegion := PtInPolygon(Points, CrossPoints[1]); if isInRegion then begin CurrLength := SQRT(SQR(CrossPoints[1].x - SideConn.ActualPoints[1].x) + SQR(CrossPoints[1].y - SideConn.ActualPoints[1].y)); MinLength := CurrLength; ConnectToPoint := CrossPoints[1]; end; isInRegion := PtInPolygon(Points, CrossPoints[2]); if isInRegion then begin CurrLength := SQRT(SQR(CrossPoints[2].x - SideConn.ActualPoints[1].x) + SQR(CrossPoints[2].y - SideConn.ActualPoints[1].y)); if (CurrLength <= MinLength) or (MinLength = 0) then begin ConnectToPoint := CrossPoints[2]; MinLength := CurrLength; end; end; isInRegion := PtInPolygon(Points, CrossPoints[3]); if isInRegion then begin CurrLength := SQRT(SQR(CrossPoints[3].x - SideConn.ActualPoints[1].x) + SQR(CrossPoints[3].y - SideConn.ActualPoints[1].y)); if (CurrLength <= MinLength) or (MinLength = 0) then begin ConnectToPoint := CrossPoints[3]; MinLength := CurrLength; end; end; isInRegion := PtInPolygon(Points, CrossPoints[4]); if isInRegion then begin CurrLength := SQRT(SQR(CrossPoints[4].x - SideConn.ActualPoints[1].x) + SQR(CrossPoints[4].y - SideConn.ActualPoints[1].y)); if (CurrLength <= MinLength) or (MinLength = 0) then begin ConnectToPoint := CrossPoints[4]; MinLength := CurrLength; end; end; // подвинуть к месту соединения SaveFigureSnap := GFigureSnap; SavePrevFigureSnap := GPrevFigureSnap; GFigureSnap := nil; GPrevFigureSnap := nil; // !!! Подравнять по алгоритму если есть точка соединения if (ConnectToPoint.x <> 0) and (ConnectToPoint.y <> 0) then begin // Tolik -- 23/11/2015 -- переменные не сброшены по условию в обратное состояние,(и не проинициализированы нигде) // так что если настройка = false, получим в переменных произвольное значение и, соответственно, // произвольный результат. Мало того, настройки КАДа "полетят" { if GCadform.PCad.SnapToGrids then SnapGrids := true; if GCadform.PCad.SnapToGuides then SnapGuides := true; } if GCadform.PCad.SnapToGrids then SnapGrids := True else SnapGrids := False; if GCadform.PCad.SnapToGuides then SnapGuides := True else SnapGuides := False; //------------------------------------ GCadform.PCad.SnapToGrids := false; GCadform.PCad.SnapToGuides := false; // Tolik --03/05/2017 -- if GConnectTraceOnClickPoint then ConnectedConn.Move(ConnectToPoint.x - ConnectedConn.ActualPoints[1].x, ConnectToPoint.y - ConnectedConn.ActualPoints[1].y); if SnapGrids then GCadform.PCad.SnapToGrids := True; if SnapGuides then GCadform.PCad.SnapToGuides := True; end; if ConnectedConn.Selected then ConnectedConn.Deselect; // DELETE FROM PM DeleteObjectFromPM(ConnectedConn.ID, ConnectedConn.Name); GFigureSnap := SaveFigureSnap; GPrevFigureSnap := SavePrevFigureSnap; end; if Not AOnRaise then //#FROM Oleg# AutoConnectObjectToConnectors(APointObject, AConnector, TempNewConnList); if TempNewConnList <> nil then FreeAndNil(TempNewConnList); SetConnBringToFront(APointObject); ReCalcZCoordSnapObjects(APointObject); // Протокол GCadForm.mProtocol.Lines.Add(cEndPoints_Mes1 + AConnector.Name + cCommon_Mes1 + APointObject.Name + '"'); RefreshCAD(GCadForm.PCad); if GCadForm.PCad.SnapToGrids then begin for i := 0 to APointObject.JoinedConnectorsList.Count - 1 do begin JoinedConn := TConnectorObject(APointObject.JoinedConnectorsList[i]); for j := 0 to JoinedConn.JoinedOrtholinesList.Count - 1 do begin // JoinedLine := TOrthoLine(AConnector.JoinedOrtholinesList[j]); // ReAlignLine(JoinedLine); end; end; end; except on E: Exception do addExceptionToLogEx('U_Common.SnapConnectorToPointObject', E.Message); end; end; (* Procedure SnapConnectorToPointObject(AConnector, APointObject: TConnectorObject; AOnRaise: Boolean = false; ASnapObjectToLine: Boolean = false); var i, j: integer; CurrLine: TOrthoLine; isExistInList: Boolean; isInRegion: Boolean; CurrConnector: TConnectorObject; SideConn: TConnectorObject; ConnectedConn: TConnectorObject; Points: TDoublePointArr; CrossPoints: array [1..4] of TDoublePoint; RegHandle: HRGN; MinLength: Double; CurrLength: Double; ConnectToPoint: TDoublePoint; SaveFigureSnap: TFigure; SavePrevFigureSnap: TFigure; LHandle: integer; TempNewConnList: TList; JoinedLine: TOrthoLine; JoinedConn: TConnectorObject; RaiseConn: TConnectorObject; RaiseLine: TOrthoLine; OtherList: TF_CAD; OtherRaise: TConnectorObject; AddDeltaX, AddDeltaY: double; ComponWidth: Double; SnapGrids,SnapGuides: Boolean; // Tolik -- 20/04/2017 -- AConnectorJoinedLines_Count: Integer; FirstLineIndex: Integer; function GetConnectorNotDeletedLines(AConn: TConnectorObject): Integer; var i: Integer; begin Result := 0; FirstLineIndex := 0; for i := 0 to aConn.JoinedOrthoLinesList.Count - 1 do begin if not TOrthoLine(AConn.JoinedOrtholinesList[i]).Deleted then begin Inc(Result); if FirstLineIndex = 0 then FirstLineIndex := i + 1; end; end; end; // begin // Tolik -- 09/02/2017 -- TempNewConnList := nil; //Tolik -- 20/04/2017 -- if (AConnector.Deleted or APointObject.Deleted) then Exit; AConnectorJoinedLines_Count := GetConnectorNotDeletedLines(AConnector); // try ConnectedConn := nil; //#From Oleg# if Not ASnapObjectToLine then begin APointObject.ActualZOrder[1] := AConnector.ActualZOrder[1]; //if (not (F_ProjMan.GSCSBase.CurrProject.CurrList.Setting.CADAutoPosTraceBetweenRM) then // AConnector.ActualZOrder[1] := APointObject.ActualZOrder[1] end else begin // Tolik if (TConnectorObject(APointObject).Radius > 10000000) then begin if {(not (F_ProjMan.GSCSBase.CurrProject.CurrList.Setting.CADAutoPosTraceBetweenRM) or} (( (TConnectorObject(APointObject).Radius - 11000000) = 999 ) or ( (TConnectorObject(APointObject).Radius - 11000000) = 0 )) then AConnector.ActualZOrder[1] := APointObject.ActualZOrder[1] else AConnector.ActualZOrder[1] := TConnectorObject(APointObject).Radius - 11000000;// APointObject.ActualZOrder[1]; end else AConnector.ActualZOrder[1] := APointObject.ActualZOrder[1] end; APointObject.FConnRaiseType := AConnector.FConnRaiseType; APointObject.FObjectFromRaise := AConnector.FObjectFromRaise; RaiseConn := GetRaiseConn(AConnector); if RaiseConn <> nil then begin RaiseConn.FObjectFromRaise := APointObject; RaiseLine := GetRaiseLine(RaiseConn); if RaiseLine <> nil then RaiseLine.FObjectFromRaisedLine := APointObject; end; if (AConnector.FConnRaiseType = crt_BetweenFloorUp) or (AConnector.FConnRaiseType = crt_BetweenFloorDown) or (AConnector.FConnRaiseType = crt_TrunkUp) or (AConnector.FConnRaiseType = crt_TrunkDown) then begin APointObject.FID_ConnToPassage := AConnector.FID_ConnToPassage; APointObject.FID_ListToPassage := AConnector.FID_ListToPassage; OtherList := GetListByID(AConnector.FID_ListToPassage); if OtherList <> nil then begin OtherRaise := TConnectorObject(GetFigureByID(OtherList, AConnector.FID_ConnToPassage)); if OtherRaise <> nil then OtherRaise.FID_ConnToPassage := APointObject.ID; end; end; AConnector.FConnRaiseType := crt_None; AConnector.FObjectFromRaise := nil; AConnector.FID_ConnToPassage := -1; AConnector.FID_ListToPassage := -1; TempNewConnList := TList.Create; LHandle := GCadForm.PCad.GetLayerHandle(2); isExistInList := False; for i := 0 to APointObject.JoinedConnectorsList.Count - 1 do begin CurrConnector := TConnectorObject(APointObject.JoinedConnectorsList[i]); if CurrConnector = AConnector then isExistInList := True; end; if not isExistInList then begin APointObject.JoinedConnectorslist.Add(AConnector); AConnector.JoinedConnectorslist.Add(APointObject); end; // Tolik 31/03/2016 -- // GTempJoinedLinesConnectors.Clear if GTempJoinedLinesConnectors <> nil then GTempJoinedLinesConnectors.Clear else GTempJoinedLinesConnectors := TList.Create; // for i := 0 to AConnector.JoinedOrtholinesList.Count - 1 do begin // Tolik 20/04/2017 -- CurrLine := TOrthoLine(AConnector.JoinedOrtholinesList[i]); if not CurrLine.deleted then begin SideConn := TConnectorObject(CurrLine.JoinConnector1); if SideConn <> AConnector then GTempJoinedLinesConnectors.Add(SideConn); SideConn := TConnectorObject(CurrLine.JoinConnector2); if SideConn <> AConnector then GTempJoinedLinesConnectors.Add(SideConn); end; { SideConn := TConnectorObject(TOrthoLine(AConnector.JoinedOrtholinesList[i]).JoinConnector1); if SideConn <> AConnector then GTempJoinedLinesConnectors.Add(SideConn); SideConn := TConnectorObject(TOrthoLine(AConnector.JoinedOrtholinesList[i]).JoinConnector2); if SideConn <> AConnector then GTempJoinedLinesConnectors.Add(SideConn); } // end; // если разветвление !!! // Tolik -- 20/04/2017 -- // if AConnector.JoinedOrtholinesList.Count > 1 then if AConnectorJoinedLines_Count > 1 then begin //Tolik 20/04/2017 -- //for i := 1 to AConnector.JoinedOrtholinesList.Count - 1 do for i := FirstLineIndex to AConnector.JoinedOrtholinesList.Count - 1 do begin CurrLine := TOrthoLine(AConnector.JoinedOrtholinesList[i]); // Tolik 20/04/2017 -- if not CurrLine.deleted then begin if TConnectorObject(TOrthoLine(CurrLine.JoinConnector1)) = AConnector then begin CurrLine.JoinConnector1 := nil; ConnectedConn := TConnectorObject.Create(CurrLine.ActualPoints[1].x, CurrLine.ActualPoints[1].y, AConnector.ActualZOrder[1], LHandle, mydsNormal, GCadForm.PCad); ConnectedConn.ConnectorType := ct_Clear; GCadForm.PCad.AddCustomFigure (GLN(LHandle), ConnectedConn, False); CurrLine.SetJConnector1(ConnectedConn); APointObject.JoinedConnectorsList.Add(ConnectedConn); ConnectedConn.JoinedConnectorsList.Add(APointObject); TempNewConnList.Add(ConnectedConn); end; if TConnectorObject(TOrthoLine(CurrLine.JoinConnector2)) = AConnector then begin CurrLine.JoinConnector2 := nil; ConnectedConn := TConnectorObject.Create(CurrLine.ActualPoints[2].x, CurrLine.ActualPoints[2].y, AConnector.ActualZOrder[1], LHandle, mydsNormal, GCadForm.PCad); ConnectedConn.ConnectorType := ct_Clear; GCadForm.PCad.AddCustomFigure (GLN(LHandle), ConnectedConn, False); CurrLine.SetJConnector2(ConnectedConn); APointObject.JoinedConnectorsList.Add(ConnectedConn); ConnectedConn.JoinedConnectorsList.Add(APointObject); TempNewConnList.Add(ConnectedConn); end; end; end; // Tolik -- 20/04/2017 -- сбросить с коннектора все (кроме первой ) НЕ УДАЛЕННЫЕ трассы j := FirstLineIndex; for j := AConnector.JoinedOrtholinesList.Count - 1 downto FirstLineIndex do begin if not TOrthoLine(AConnector.JoinedOrtholinesList[j]).Deleted then AConnector.JoinedOrtholinesList.Delete(j); end; { j := 1; while j < AConnector.JoinedOrtholinesList.Count do begin AConnector.JoinedOrtholinesList.Delete(j); end; } end; // получить точки пересечения линии с обьектом for i := 0 to GTempJoinedLinesConnectors.Count - 1 do begin if i = 0 then ConnectedConn := AConnector else if i > 0 then ConnectedConn := TConnectorObject(TempNewConnList[i - 1]); SideConn := TConnectorObject(GTempJoinedLinesConnectors[i]); if (APointObject.DrawFigure.InFigures.Count = 1) and CheckFigureByClassName(TFigure(APointObject.DrawFigure.InFigures[0]), 'TWMFObject') then begin //FormatFloat(ffMask, AObject.FDrawFigureAngle / pi * 180); ComponWidth := APointObject.DrawFigure.GetBoundRect.Right - APointObject.DrawFigure.GetBoundRect.Left; AddDeltaX := 0.04 * ComponWidth; AddDeltaY := APointObject.GrpSizeY * 0.04; end else begin AddDeltaX := 0; AddDeltaY := 0; end; //Внутри делает то, что ниже.Для экономии места, так как код повторяется ниже по коду FillPOintsForConnect(SideConn,APointObject,ConnectedConn,AddDeltaX, AddDeltaY,Points,CrossPoints); // создать регион точек точечного обьекта MinLength := 0; CurrLength := 0; ConnectToPoint.x := 0; ConnectToPoint.y := 0; isInRegion := PtInPolygon(Points, CrossPoints[1]); if isInRegion then begin CurrLength := SQRT(SQR(CrossPoints[1].x - SideConn.ActualPoints[1].x) + SQR(CrossPoints[1].y - SideConn.ActualPoints[1].y)); MinLength := CurrLength; ConnectToPoint := CrossPoints[1]; end; isInRegion := PtInPolygon(Points, CrossPoints[2]); if isInRegion then begin CurrLength := SQRT(SQR(CrossPoints[2].x - SideConn.ActualPoints[1].x) + SQR(CrossPoints[2].y - SideConn.ActualPoints[1].y)); if (CurrLength <= MinLength) or (MinLength = 0) then begin ConnectToPoint := CrossPoints[2]; MinLength := CurrLength; end; end; isInRegion := PtInPolygon(Points, CrossPoints[3]); if isInRegion then begin CurrLength := SQRT(SQR(CrossPoints[3].x - SideConn.ActualPoints[1].x) + SQR(CrossPoints[3].y - SideConn.ActualPoints[1].y)); if (CurrLength <= MinLength) or (MinLength = 0) then begin ConnectToPoint := CrossPoints[3]; MinLength := CurrLength; end; end; isInRegion := PtInPolygon(Points, CrossPoints[4]); if isInRegion then begin CurrLength := SQRT(SQR(CrossPoints[4].x - SideConn.ActualPoints[1].x) + SQR(CrossPoints[4].y - SideConn.ActualPoints[1].y)); if (CurrLength <= MinLength) or (MinLength = 0) then begin ConnectToPoint := CrossPoints[4]; MinLength := CurrLength; end; end; // подвинуть к месту соединения SaveFigureSnap := GFigureSnap; SavePrevFigureSnap := GPrevFigureSnap; GFigureSnap := nil; GPrevFigureSnap := nil; // !!! Подравнять по алгоритму если есть точка соединения if (ConnectToPoint.x <> 0) and (ConnectToPoint.y <> 0) then begin // Tolik -- 23/11/2015 -- переменные не сброшены по условию в обратное состояние,(и не проинициализированы нигде) // так что если настройка = false, получим в переменных произвольное значение и, соответственно, // произвольный результат. Мало того, настройки КАДа "полетят" { if GCadform.PCad.SnapToGrids then SnapGrids := true; if GCadform.PCad.SnapToGuides then SnapGuides := true; } if GCadform.PCad.SnapToGrids then SnapGrids := True else SnapGrids := False; if GCadform.PCad.SnapToGuides then SnapGuides := True else SnapGuides := False; //------------------------------------ GCadform.PCad.SnapToGrids := false; GCadform.PCad.SnapToGuides := false; // Tolik --03/05/2017 -- if GConnectTraceOnClickPoint then ConnectedConn.Move(ConnectToPoint.x - ConnectedConn.ActualPoints[1].x, ConnectToPoint.y - ConnectedConn.ActualPoints[1].y); if SnapGrids then GCadform.PCad.SnapToGrids := True; if SnapGuides then GCadform.PCad.SnapToGuides := True; end; if ConnectedConn.Selected then ConnectedConn.Deselect; // DELETE FROM PM DeleteObjectFromPM(ConnectedConn.ID, ConnectedConn.Name); GFigureSnap := SaveFigureSnap; GPrevFigureSnap := SavePrevFigureSnap; end; if Not AOnRaise then //#FROM Oleg# AutoConnectObjectToConnectors(APointObject, AConnector, TempNewConnList); if TempNewConnList <> nil then FreeAndNil(TempNewConnList); SetConnBringToFront(APointObject); ReCalcZCoordSnapObjects(APointObject); // Протокол GCadForm.mProtocol.Lines.Add(cEndPoints_Mes1 + AConnector.Name + cCommon_Mes1 + APointObject.Name + '"'); RefreshCAD(GCadForm.PCad); if GCadForm.PCad.SnapToGrids then begin for i := 0 to APointObject.JoinedConnectorsList.Count - 1 do begin JoinedConn := TConnectorObject(APointObject.JoinedConnectorsList[i]); for j := 0 to JoinedConn.JoinedOrtholinesList.Count - 1 do begin // JoinedLine := TOrthoLine(AConnector.JoinedOrtholinesList[j]); // ReAlignLine(JoinedLine); end; end; end; except on E: Exception do addExceptionToLogEx('U_Common.SnapConnectorToPointObject', E.Message); end; end; *) // Tolik 18/04/2016 -- смотрит только верхний уровень, не проверяя вложенность компонент, // потому и не находит ни х... //В общемто сама проверка на наличие свободного функционального интерфейса { Function CheckCurrLine(CurrLineInterf: TSCSInterfaces; APointObject: TConnectorObject):Boolean; var i,j,k: Integer; Interfac,InterfPoint: TSCSInterface; SCSComponPoint: TSCSComponent; begin Result := False; for j := 0 to F_ProjMan.GSCSBase.CurrProject.CurrList.GetCatalogFromReferencesBySCSID(APointObject.ID).SCSComponents.Count - 1 do begin SCSComponPoint := F_ProjMan.GSCSBase.CurrProject.CurrList.GetCatalogFromReferencesBySCSID(APointObject.ID).SCSComponents[j]; for k := 0 to SCSComponPoint.Interfaces.Count - 1 do begin InterfPoint := SCSComponPoint.Interfaces[k]; if InterfPoint.TypeI = itFunctional then for i := 0 to CurrLineInterf.Count - 1 do begin Interfac := CurrLineInterf[i]; if Interfac.TypeI = itFunctional then if Interfac.IsBusy = Bifalse then begin if InterfPoint.SideSection = Interfac.SideSection then Result := true; break; end; end; end; if Result then break; end; end; } Function CheckCurrLine(CurrLineInterf: TSCSInterfaces; APointObject: TConnectorObject):Boolean; var i,j,k: Integer; Interfac,InterfPoint: TSCSInterface; SCSComponPoint: TSCSComponent; // SCSCatalog: TSCSCatalog; // begin Result := False; //for j := 0 to F_ProjMan.GSCSBase.CurrProject.CurrList.GetCatalogFromReferencesBySCSID(APointObject.ID).SCSComponents.Count - 1 do SCSCatalog := F_ProjMan.GSCSBase.CurrProject.CurrList.GetCatalogFromReferencesBySCSID(APointObject.ID); if SCSCatalog <> nil then begin for j := 0 to SCSCatalog.ComponentReferences.Count - 1 do begin // SCSComponPoint := F_ProjMan.GSCSBase.CurrProject.CurrList.GetCatalogFromReferencesBySCSID(APointObject.ID).SCSComponents[j]; SCSComponPoint := SCSCatalog.ComponentReferences[j]; for k := 0 to SCSComponPoint.Interfaces.Count - 1 do begin InterfPoint := SCSComponPoint.Interfaces[k]; if InterfPoint.TypeI = itFunctional then for i := 0 to CurrLineInterf.Count - 1 do begin Interfac := CurrLineInterf[i]; if Interfac.TypeI = itFunctional then if Interfac.IsBusy = Bifalse then begin if InterfPoint.SideSection = Interfac.SideSection then Result := true; break; end; end; end; if Result then break; end; end; end; // // Tolik 24/09/2018 -- старая закомменчена -- смотри ниже-- проебана инициализаци и проверка на наличие интерфейсов -- // выпадают АВ, поэтому немножко переписано ... //Проверка если APointObject имеет такие же параметры, как и CurrLine Function CheckInterfacesSideSection(APointObject, AConnector: TConnectorObject; CurrLine: TOrtholine): Boolean; var SCSComponLine, SCSComponPoint: TSCSComponent; LineInterf,PointInterf: TSCSInterfaces; i,j,k: integer; InterfacL,InterfacP: TSCSInterface; begin result := false; InterfacL := Nil; // Tolik 24/09/2018 //TODO возможно нужно будет добавить цикл, так как в Каталоге может быть >1 кабелей и с APointObject может потребуется то же самоенужно будет проверить if (F_ProjMan.GSCSBase.CurrProject.CurrList.GetCatalogFromReferencesBySCSID(CurrLine.ID).SCSComponents.Count = 0)or (F_ProjMan.GSCSBase.CurrProject.CurrList.GetCatalogFromReferencesBySCSID(APointObject.ID).SCSComponents.Count = 0) then exit; SCSComponPoint := F_ProjMan.GSCSBase.CurrProject.CurrList.GetCatalogFromReferencesBySCSID(APointObject.ID).SCSComponents[0]; //Интерфейсы точечного объекта PointInterf := SCSComponPoint.Interfaces; for k := 0 to F_ProjMan.GSCSBase.CurrProject.CurrList.GetCatalogFromReferencesBySCSID(CurrLine.ID).SCSComponents.Count - 1 do begin SCSComponLine := F_ProjMan.GSCSBase.CurrProject.CurrList.GetCatalogFromReferencesBySCSID(CurrLine.ID).SCSComponents[k]; // Интерфейсы Линии LineInterf := SCSComponLine.interfaces; IF CurrLine.JoinConnector1 = AConnector then begin for i := 0 to LineInterf.Count - 1 do begin InterfacL := LineInterf[i]; //Если нашли нужный интерфейс if InterfacL.Side = 1 then break; //брекаем end; if InterfacL <> nil then // Tolik 24/09/2018 begin for j := 0 to PointInterf.Count - 1 do begin InterfacP := PointInterf[j]; if InterfacL.SideSection = InterfacP.SideSection then //Если параметры линейного объекта = параметрам точечного begin result := true; break; end; end; end; end else IF CurrLine.JoinConnector2 = AConnector then //Все то же самое, как и со стороной № 1 begin for i := 0 to LineInterf.Count - 1 do begin InterfacL := LineInterf[i]; if InterfacL.Side = 2 then break; end; if InterfacL <> nil then // Tolik 24/09/2018 begin for j := 0 to PointInterf.Count - 1 do begin InterfacP := PointInterf[j]; if InterfacL.SideSection = InterfacP.SideSection then begin result := true; break; end; end; end; end; end; end; { //Проверка если APointObject имеет такие же параметры, как и CurrLine Function CheckInterfacesSideSection(APointObject, AConnector: TConnectorObject; CurrLine: TOrtholine): Boolean; var SCSComponLine, SCSComponPoint: TSCSComponent; LineInterf,PointInterf: TSCSInterfaces; i,j,k: integer; InterfacL,InterfacP: TSCSInterface; begin result := false; //TODO возможно нужно будет добавить цикл, так как в Каталоге может быть >1 кабелей и с APointObject может потребуется то же самоенужно будет проверить if (F_ProjMan.GSCSBase.CurrProject.CurrList.GetCatalogFromReferencesBySCSID(CurrLine.ID).SCSComponents.Count = 0)or (F_ProjMan.GSCSBase.CurrProject.CurrList.GetCatalogFromReferencesBySCSID(APointObject.ID).SCSComponents.Count = 0) then exit; SCSComponPoint := F_ProjMan.GSCSBase.CurrProject.CurrList.GetCatalogFromReferencesBySCSID(APointObject.ID).SCSComponents[0]; //Интерфейсы точечного объекта PointInterf := SCSComponPoint.Interfaces; for k := 0 to F_ProjMan.GSCSBase.CurrProject.CurrList.GetCatalogFromReferencesBySCSID(CurrLine.ID).SCSComponents.Count - 1 do begin SCSComponLine := F_ProjMan.GSCSBase.CurrProject.CurrList.GetCatalogFromReferencesBySCSID(CurrLine.ID).SCSComponents[k]; // Интерфейсы Линии LineInterf := SCSComponLine.interfaces; IF CurrLine.JoinConnector1 = AConnector then begin for i := 0 to LineInterf.Count - 1 do begin InterfacL := LineInterf[i]; //Если нашли нужный интерфейс if InterfacL.Side = 1 then break; //брекаем end; for j := 0 to PointInterf.Count - 1 do begin InterfacP := PointInterf[j]; if InterfacL.SideSection = InterfacP.SideSection then //Если параметры линейного объекта = параметрам точечного begin result := true; break; end; end; end else IF CurrLine.JoinConnector2 = AConnector then //Все то же самое, как и со стороной № 1 begin for i := 0 to LineInterf.Count - 1 do begin InterfacL := LineInterf[i]; if InterfacL.Side = 2 then break; end; for j := 0 to PointInterf.Count - 1 do begin InterfacP := PointInterf[j]; if InterfacL.SideSection = InterfacP.SideSection then begin result := true; break; end; end; end; end; end; } Procedure ClearLineInterfaces(APointObject, AConnector: TConnectorObject; var CurrLine: TOrtholine; FindFreeInterfac: Boolean); var i,j,m,n: integer; Interfac: TSCSInterface; CurrLineInterf: TSCSInterfaces; SCSComponLine,JoinCompon, SCSComponPoint: TSCSComponent; vList: TF_CAD; JoinFigure: TFigure; JoinCatalog: TSCSCatalog; Multip: Boolean; //Tolik CanClear: Boolean; currCatalog: TSCSCatalog; PointCatalog: TSCSCatalog; // Tolik 20/02/2021 -- begin try Multip := false; //Tolik CanClear := true; //Проверяем на многократоность APointObject... // Tolik 20/02/2021 -- //SCSComponPoint := F_ProjMan.GSCSBase.CurrProject.CurrList.GetCatalogFromReferencesBySCSID(APointObject.ID).SCSComponents[0]; SCSComponPoint := nil; PointCatalog := F_ProjMan.GSCSBase.CurrProject.CurrList.GetCatalogFromReferencesBySCSID(APointObject.ID); if PointCatalog <> nil then begin if PointCatalog.SCSComponents.Count > 0 then SCSComponPoint := PointCatalog.SCSComponents[0]; end; if SCSComponPoint = nil then exit; // CurrLineInterf := SCSComponPoint.Interfaces; for i := 0 to CurrLineInterf.Count - 1 do begin Interfac := CurrLineInterf[i]; if Interfac.TypeI = itFunctional then if Interfac.Multiple = BiTrue then begin Multip := true; break; end; end; //Если APointObject не многократна, и найдена трасса со свободным интерфейсом или параметры не совпадают - ВЫХОД if ((not Multip)and FindFreeInterfac)or (not CheckInterfacesSideSection(APointObject, AConnector, CurrLine))or (not SCSComponPoint.IDNetType in [3,{4,}5,7])then exit; IF CurrLine.JoinConnector1 = AConnector then //если линия соеденена стороной №1 begin for m := 0 to APointObject.JoinedConnectorsList.Count - 1 do if APointObject.JoinedConnectorsList[m] = AConnector then begin currCatalog := F_ProjMan.GSCSBase.CurrProject.CurrList.GetCatalogFromReferencesBySCSID(CurrLine.ID); if currCatalog <> nil then begin //for n := 0 to F_ProjMan.GSCSBase.CurrProject.CurrList.GetCatalogFromReferencesBySCSID(CurrLine.ID).SCSComponents.Count - 1 do for n := 0 to currCatalog.SCSComponents.Count - 1 do begin //СКС-компонент SCSComponLine := currCatalog.SCSComponents[n];//F_ProjMan.GSCSBase.CurrProject.CurrList.GetCatalogFromReferencesBySCSID(CurrLine.ID).SCSComponents[n]; // Tolik // При автотрассировке электрики не все соединения в данной точке нужно разрывать, а только кабели того типа, // который прокладываем в данный момент (если игнорить проложенный кабель, то только в том случае, если кабель - последний из проложенных в трассе) if (F_PEAutoTraceDialog.FromAutoTraceDialog and (F_PEAutoTraceDialog.Cypher <> '')) then begin if ((SCSComponLine.Cypher <> F_PEAutoTraceDialog.Cypher) or ((SCSComponLine.Cypher = F_PEAutoTraceDialog.Cypher) and (F_PEAutoTraceDialog.IgnoreExistingCable.Visible) and (F_PEAutoTraceDialog.IgnoreExistingCable.Checked) and (SCSComponLine <> currCatalog.LastAddedComponent))) then CanClear := False; end; if CanClear then begin //Его интерфейсы CurrLineInterf := SCSComponLine.Interfaces; for i := 0 to CurrLineInterf.Count - 1 do begin //Текущий интерфейс Interfac := CurrLineInterf[i]; //Если он функциональный if Interfac.TypeI = itFunctional then //И если она занят if Interfac.IsBusy = BiTrue then //И его сторона = стороне подключения с AConnector if Interfac.Side = 1 then begin //Получаем Форму КАДА vList := GetListByID(SCSCOmponLine.ListID); j := 0; While j < SCSComponLine.JoinedComponents.Count do begin //Уже подключенный компоненты JoinCompon := SCSComponLine.JoinedComponents[j]; //Определяем ФИГУРУ JoinFigure := GetFigureByID(vList,JoinCompon.GetFirstParentCatalog.SCSID); if JoinFigure <> nil then begin if ((SCSComponLine.IDNetType in [3,{4,}5,7])and (JoinCompon.IDNetType in [3,{4,}5,7])) then begin //Если подключена ортолиния if JoinFigure.ClassName = 'TOrthoLine' then //TODO проверить есть ли у APointObject схожие с SCSComponLine интерфейсы //если посоедененная линия лежит одной из сторон на нужном соеденителе - Отсоеденяем if (TOrthoLine(JoinFigure).JoinConnector1 = AConnector)or(TOrthoLine(JoinFigure).JoinConnector2 = AConnector) then begin SCSComponLine.DisJoinFrom(JoinCompon); end; {else Inc(j);} if JoinFigure.ClassName = 'TConnectorObject' then if TConnectorObject(JoinFigure).JoinedConnectorsList.IndexOf(AConnector) <> -1 then begin SCSComponLine.DisJoinFrom(JoinCompon); end; {else Inc(j);} end; end; inc(j); end; end; end; end; end; end; end; end else //Тута такая же схема, только со второй стороной линии IF CurrLine.JoinConnector2 = AConnector then //Стороной №2 begin for m := 0 to APointObject.JoinedConnectorsList.Count - 1 do if APointObject.JoinedConnectorsList[m] = AConnector then begin currCatalog := F_ProjMan.GSCSBase.CurrProject.CurrList.GetCatalogFromReferencesBySCSID(CurrLine.ID); if currCatalog <> nil then begin // for n := 0 to F_ProjMan.GSCSBase.CurrProject.CurrList.GetCatalogFromReferencesBySCSID(CurrLine.ID).SCSComponents.Count - 1 do for n := 0 to currCatalog.SCSComponents.Count - 1 do begin SCSComponLine := currCatalog.SCSComponents[n];//F_ProjMan.GSCSBase.CurrProject.CurrList.GetCatalogFromReferencesBySCSID(CurrLine.ID).SCSComponents[n]; // Tolik // При автотрассировке электрики не все соединения в данной точке нужно разрывать, а только кабели того типа, // который прокладываем в данный момент if (F_PEAutoTraceDialog.FromAutoTraceDialog and (F_PEAutoTraceDialog.Cypher <> '')) then begin // if SCSComponLine.Cypher <> F_PEAutoTraceDialog.Cypher then if ((SCSComponLine.Cypher <> F_PEAutoTraceDialog.Cypher) or ((SCSComponLine.Cypher = F_PEAutoTraceDialog.Cypher) and (F_PEAutoTraceDialog.IgnoreExistingCable.Visible) and (F_PEAutoTraceDialog.IgnoreExistingCable.Checked) and (SCSComponLine <> currCatalog.LastAddedComponent))) then CanClear := False; end; if CanClear then begin CurrLineInterf := SCSComponLine.Interfaces; for i := 0 to CurrLineInterf.Count - 1 do begin Interfac := CurrLineInterf[i]; if Interfac.TypeI = itFunctional then if Interfac.IsBusy = BiTrue then if Interfac.Side = 2 then begin vList := GetListByID(SCSCOmponLine.ListID); j := 0; While j < SCSComponLine.JoinedComponents.Count do begin JoinCompon := SCSComponLine.JoinedComponents[j]; JoinFigure := GetFigureByID(vList,JoinCompon.GetFirstParentCatalog.SCSID); if JoinFigure <> nil then begin if ((SCSComponLine.IDNetType in [3,{4,}5,7])and (JoinCompon.IDNetType in [3,{4,}5,7])) then begin if JoinFigure.ClassName = 'TOrthoLine' then //TODO проверить есть ли у APointObject схожие с SCSComponLine интерфейсы if (TOrthoLine(JoinFigure).JoinConnector1 = AConnector)or(TOrthoLine(JoinFigure).JoinConnector2 = AConnector) then begin SCSComponLine.DisJoinFrom(JoinCompon); end; if JoinFigure.ClassName = 'TConnectorObject' then if TConnectorObject(JoinFigure).JoinedConnectorsList.IndexOf(AConnector) <> -1 then begin SCSComponLine.DisJoinFrom(JoinCompon); end; end; end; Inc(j); end; end; end; end; end; end; end; end; except on E: Exception do addExceptionToLogEx('U_Common.ClearLineInterfaces', E.Message); end; end; // Tolik -- 10/04/2018 -- если есть райз на коннекторе -- передвинуть на первое место в списке подключенных Procedure SortConnLineListWithRaise(AConnector: TConnectorObject); var i, j : Integer; JoinedLine: TOrthoLine; JoinedConn: TConnectorObject; RaiseFound: Boolean; begin if AConnector.ConnectorType = ct_Clear then begin if AConnector.JoinedOrtholinesList.Count > 1 then begin for i := 0 to AConnector.JoinedOrtholinesList.Count - 1 do begin JoinedLine := TOrthoLine(AConnector.JoinedOrthoLinesList[i]); if JoinedLine.FIsRaiseUpDown then begin if i <> 0 then AConnector.JoinedOrtholinesList.Exchange(i, 0); break; end; end; end; end else if AConnector.ConnectorType = ct_NB then begin RaiseFound := False; for i := 1 to AConnector.JoinedConnectorsList.Count - 1 do begin JoinedConn := TconnectorObject(AConnector.JoinedConnectorsList[i]); for j := 0 to JoinedConn.JoinedOrtholinesList.Count - 1 do begin JoinedLine := TOrthoLine(JoinedConn.JoinedOrtholinesList[j]); if JoinedLine.FIsRaiseUpDown then begin RaiseFound := True; if j <> 0 then JoinedConn.JoinedOrtholinesList.Exchange(0, j); if i <> 0 then AConnector.JoinedConnectorsList.Exchange(0, i); end; end; if RaiseFound then exit; end; end; end; // // ПРИВЯЗКА ПУСТОГО КОНЕКТОРА К ОБЬЕКТУ // Tolik 03/04/2018 -- переписана... старая закомменчена -- смотри ниже ... procedure SnapPointObjectToConnector(APointObject, AConnector: TConnectorObject; AConnToPoint: Boolean = false); var i, j: integer; CurrLine: TOrthoLine; isExistInList: Boolean; isInRegion: Boolean; CurrConnector: TConnectorObject; SideConn: TConnectorObject; ConnectedConn: TConnectorObject; Points: TDoublePointArr; CrossPoints: array [1..4] of TDoublePoint; RegHandle: HRGN; MinLength: Double; CurrLength: Double; ConnectToPoint: TDoublePoint; SaveFigureSnap: TFigure; SavePrevFigureSnap: TFigure; LHandle: integer; FindRaise: TConnectorObject; TempNewConnList: TList; JoinedLine: TOrthoLine; JoinedConn: TConnectorObject; RaiseConn: TConnectorObject; RaiseLine: TOrthoLine; OtherList: TF_CAD; OtherRaise: TConnectorObject; AddDeltaX, AddDeltaY: Double; ComponWidth: Double; SnapGrids,SnapGuides: Boolean; FindFreeLine: Boolean; RememberI, StartCicle: Integer; //Tolik CreatedList: Boolean; CanMoveConns: Boolean; VertLine, FindedRaiseLine: TOrthoLine; // Tolik -- 06/04/2018 -- ConnToMove: TConnectorObject; deltax, deltay: Double; RaiseOnPoint, RaiseOnConn: TOrthoLine; LineCatalog: TSCSCatalog; // Tolik 20/02/2021 -- function GetConnToMove(aConn: TConnectorObject): TConnectorObject; var RLine: TOrthoLine; i: Integer; begin Result := nil; if aConn.FConnRaiseType = crt_None then begin RLine := Nil; for i := 0 to aConn.JoinedOrtholinesList.Count - 1 do begin if TOrthoLine(aConn.JoinedOrtholinesList[i]).FIsRaiseUpDown then begin RLine := TOrthoLine(aConn.JoinedOrtholinesList[i]); if RLine.JoinConnector1.ID = aConn.ID then Result := TConnectorObject(RLine.JoinConnector2) else if RLine.JoinConnector2.ID = aConn.ID then Result := TConnectorObject(RLine.JoinConnector1); RLine.FObjectFromRaisedLine := APointObject; break; end; end; end; end; // begin // Tolik -- 09/02/2017 -- TempNewConnList := nil; // if aPointObject.JoinedConnectorsList.IndexOf(AConnector) <> -1 then exit; try FindFreeLine := false; //From Dimon ;) RememberI := -1; ConnectedConn := nil; //#From Oleg# CreatedList := False; CanMoveConns := True; FindedRaiseLine := Nil; SortConnLineListWithRaise(AConnector); SortConnLineListWithRaise(APointObject); // if CompareValue(aPointObject.ActualZOrder[1], AConnector.ActualZOrder[1]) <> 0 then begin // размещать трассы на высоте рабочих мест //if CheckAllowTracesBetweenRM(AConnector) then // begin // aPointObject.ActualZOrder[1] := AConnector.ActualZOrder[1]; // end // else // если нельзя размещать трассы на высоте рабочих мест, то, наверное, нужно создавать с/п или что-то там ещё CheckingSnapPointObjectToConnector(APointObject, AConnector); end; if APointObject.FConnRaiseType = crt_None then APointObject.FConnRaiseType := AConnector.FConnRaiseType; //Tolik -- 20/03/2018 -- !!! Нельзя здесь!!! Потому что последующий сдвиг точечного подвинет и FObjectFromRaise;!!!! //APointObject.FObjectFromRaise := AConnector.FObjectFromRaise; // RaiseLine := nil; // Tolik 18/02/2021 -- if AConnector.Deleted then exit; RaiseConn := GetRaiseConn(AConnector); if RaiseConn <> nil then begin RaiseConn.FObjectFromRaise := APointObject; RaiseLine := GetRaiseLine(RaiseConn); // Tolik 15/11/2019 -- if RaiseLine <> nil then RaiseLine := RaiseFromConnector(AConnector); // if RaiseLine <> nil then RaiseLine.FObjectFromRaisedLine := APointObject; end; if RaiseLine <> nil then // нех это делать, если райза на коннекторе нет совсем begin if (AConnector.FConnRaiseType = crt_BetweenFloorUp) or (AConnector.FConnRaiseType = crt_BetweenFloorDown) or (AConnector.FConnRaiseType = crt_TrunkUp) or (AConnector.FConnRaiseType = crt_TrunkDown) then begin APointObject.FID_ConnToPassage := AConnector.FID_ConnToPassage; APointObject.FID_ListToPassage := AConnector.FID_ListToPassage; OtherList := GetListByID(AConnector.FID_ListToPassage); if OtherList <> nil then begin OtherRaise := TConnectorObject(GetFigureByID(OtherList, AConnector.FID_ConnToPassage)); if OtherRaise <> nil then OtherRaise.FID_ConnToPassage := APointObject.ID; end; end; end; // Tolik - - 20/03/2018 -- RaiseOnPoint := RaiseFromConnector(APointObject); // 15/11/2019 -- if RaiseOnPoint = nil then // APointObject.FObjectFromRaise := AConnector.FObjectFromRaise; // здесь только если на поинте нет райза !!! // AConnector.FConnRaiseType := crt_None; AConnector.FObjectFromRaise := nil; AConnector.FID_ConnToPassage := -1; AConnector.FID_ListToPassage := -1; SaveFigureSnap := GFigureSnap; SavePrevFigureSnap := GPrevFigureSnap; GFigureSnap := nil; GPrevFigureSnap := nil; deltax := AConnector.ActualPoints[1].x - APointObject.ActualPoints[1].x; deltay := AConnector.ActualPoints[1].y - APointObject.ActualPoints[1].y; if ((deltax <> 0) or (deltay <> 0)) then begin { if CompareValue(AConnector.ActualZOrder[1], aPointObject.ActualZOrder[1]) = 0 then begin if GCadForm.PCad.TraceFigure <> nil then // если идет создание трассы и в настройках установлено подключать в месте клика и begin if GCadForm.PCad.TraceFigure is TOrthoLine then // выключена опция подтягивать трассу к точечному - тогда не нужно двигать коннектор begin if GConnectTraceOnClickPoint then begin if GMoveRouteToPointObject then AConnector.MoveConnector(deltax, deltay, false, true) end else AConnector.MoveConnector(deltax, deltay, false, true) end else AConnector.MoveConnector(deltax, deltay, false, true) end else AConnector.MoveConnector(deltax, deltay, false, true) end else begin if AConnToPoint then //AConnector.MoveP(deltax, deltay, False) AConnector.MoveConnector(deltax, deltay, false, true) else APointObject.MoveP(deltax, deltay, False); end; } end; GFigureSnap := SaveFigureSnap; GPrevFigureSnap := SavePrevFigureSnap; TempNewConnList := TList.Create; LHandle := GCadForm.PCad.GetLayerHandle(2); isExistInList := False; begin APointObject.JoinedConnectorslist.Add(AConnector); AConnector.JoinedConnectorslist.Add(APointObject); DeleteObjectFromPM(AConnector.ID, AConnector.Name); // Tolik 19/11/2019 -- end; // сохранить конекторы - начальные точки присоединенных линий // // Tolik -- 25/03/2016 -- // GTempJoinedLinesConnectors.Clear; if GTempJoinedLinesConnectors <> nil then GTempJoinedLinesConnectors.Clear else begin GTempJoinedLinesConnectors := TList.Create; CreatedList := True; end; for i := 0 to AConnector.JoinedOrtholinesList.Count - 1 do begin SideConn := TConnectorObject(TOrthoLine(AConnector.JoinedOrtholinesList[i]).JoinConnector1); if SideConn <> AConnector then GTempJoinedLinesConnectors.Add(SideConn); SideConn := TConnectorObject(TOrthoLine(AConnector.JoinedOrtholinesList[i]).JoinConnector2); if SideConn <> AConnector then GTempJoinedLinesConnectors.Add(SideConn); end; // если разветвление !!! if AConnector.JoinedOrtholinesList.Count > 1 then begin //Предварительный поиска трассы со свободным интерфейсом for i := 0 to AConnector.JoinedOrtholinesList.Count - 1 do begin CurrLine := TOrthoLine(AConnector.JoinedOrtholinesList[i]); if not FindFreeLine then //From Dimon ;) begin //TODO: Тут тоже, скорей всего, нужно пройтись по всем скс-компонентам... // Tolik 20/02/2021 -- { for j := 0 to F_ProjMan.GSCSBase.CurrProject.CurrList.GetCatalogFromReferencesBySCSID(CurrLine.ID).SCSComponents.Count - 1 do if CheckCurrLine(F_ProjMan.GSCSBase.CurrProject.CurrList.GetCatalogFromReferencesBySCSID(CurrLine.ID).SCSComponents[j].Interfaces, APointObject)then begin RememberI := i; FindFreeLine := true; Break; end; } LineCatalog := F_ProjMan.GSCSBase.CurrProject.CurrList.GetCatalogFromReferencesBySCSID(CurrLine.ID); if LineCatalog <> nil then begin for j := 0 to LineCatalog.SCSComponents.Count - 1 do begin if CheckCurrLine(LineCatalog.SCSComponents[j].Interfaces, APointObject)then begin RememberI := i; FindFreeLine := true; Break; end; end; end; // end; if FindFreeLine then Break; end; if FindFreeLine then StartCicle := 0 else StartCicle := 1; for i := StartCicle to AConnector.JoinedOrtholinesList.Count - 1 do begin CurrLine := TOrthoLine(AConnector.JoinedOrtholinesList[i]); if i = RememberI then continue; ClearLineInterfaces(APointObject, AConnector,CurrLine, FindFreeLine); if TConnectorObject(TOrthoLine(CurrLine.JoinConnector1)) = AConnector then begin CurrLine.JoinConnector1 := nil; ConnectedConn := TConnectorObject.Create(CurrLine.ActualPoints[1].x, CurrLine.ActualPoints[1].y, AConnector.ActualZOrder[1], LHandle, mydsNormal, GCadForm.PCad); ConnectedConn.ConnectorType := ct_Clear; GCadForm.PCad.AddCustomFigure (GLN(LHandle), ConnectedConn, False); CurrLine.SetJConnector1(ConnectedConn); APointObject.JoinedConnectorsList.Add(ConnectedConn); ConnectedConn.JoinedConnectorsList.Add(APointObject); DeleteObjectFromPM(ConnectedConn.ID, ConnectedConn.Name); // Tolik 19/11/2019 -- TempNewConnList.Add(ConnectedConn); if CurrLine.FIsRaiseUpDown then begin ConnectedConn.LockMove := True; ConnectedConn.LockModify := True; end; end; if TConnectorObject(TOrthoLine(CurrLine.JoinConnector2)) = AConnector then begin CurrLine.JoinConnector2 := nil; ConnectedConn := TConnectorObject.Create(CurrLine.ActualPoints[2].x, CurrLine.ActualPoints[2].y, AConnector.ActualZOrder[1], LHandle, mydsNormal, GCadForm.PCad); ConnectedConn.ConnectorType := ct_Clear; GCadForm.PCad.AddCustomFigure (GLN(LHandle), ConnectedConn, False); CurrLine.SetJConnector2(ConnectedConn); APointObject.JoinedConnectorsList.Add(ConnectedConn); ConnectedConn.JoinedConnectorsList.Add(APointObject); DeleteObjectFromPM(ConnectedConn.ID, ConnectedConn.Name); // Tolik 19/11/2019 -- TempNewConnList.Add(ConnectedConn); if CurrLine.FIsRaiseUpDown then begin ConnectedConn.LockMove := True; ConnectedConn.LockModify := True; end; end; end; if Assigned(CurrLine) then CurrLine := nil; if RememberI <> -1 then begin CurrLine := TOrthoLine(AConnector.JoinedOrtholinesList[RememberI]); j := 0; end else j := 1; while j < AConnector.JoinedOrtholinesList.Count do begin if TOrthoLine(AConnector.JoinedOrtholinesList[j]) <> CurrLine then AConnector.JoinedOrtholinesList.Delete(j) else inc(j); end; end; // получить точки пересечения линии с обьектом if CanMoveConns then for i := 0 to GTempJoinedLinesConnectors.Count - 1 do begin if i = 0 then ConnectedConn := AConnector else if i > 0 then ConnectedConn := TConnectorObject(TempNewConnList[i - 1]); SideConn := TConnectorObject(GTempJoinedLinesConnectors[i]); if (APointObject.DrawFigure.InFigures.Count = 1) and CheckFigureByClassName(TFigure(APointObject.DrawFigure.InFigures[0]), 'TWMFObject') then begin ComponWidth := APointObject.DrawFigure.GetBoundRect.Right - APointObject.DrawFigure.GetBoundRect.Left; AddDeltaX := 0.04 * ComponWidth; AddDeltaY := APointObject.GrpSizeY * 0.04; end else begin AddDeltaX := 0; AddDeltaY := 0; end; //Внутри делает то, что ниже FillPOintsForConnect(SideConn,APointObject,ConnectedConn,AddDeltaX, AddDeltaY,Points,CrossPoints); // создать регион точек точечного обьекта MinLength := 0; CurrLength := 0; ConnectToPoint.x := 0; ConnectToPoint.y := 0; isInRegion := PtInPolygon(Points, CrossPoints[1]); if isInRegion then begin CurrLength := SQRT(SQR(CrossPoints[1].x - SideConn.ActualPoints[1].x) + SQR(CrossPoints[1].y - SideConn.ActualPoints[1].y)); MinLength := CurrLength; ConnectToPoint := CrossPoints[1]; end; isInRegion := PtInPolygon(Points, CrossPoints[2]); if isInRegion then begin CurrLength := SQRT(SQR(CrossPoints[2].x - SideConn.ActualPoints[1].x) + SQR(CrossPoints[2].y - SideConn.ActualPoints[1].y)); if (CurrLength <= MinLength) or (MinLength = 0) then begin ConnectToPoint := CrossPoints[2]; MinLength := CurrLength; end; end; isInRegion := PtInPolygon(Points, CrossPoints[3]); if isInRegion then begin CurrLength := SQRT(SQR(CrossPoints[3].x - SideConn.ActualPoints[1].x) + SQR(CrossPoints[3].y - SideConn.ActualPoints[1].y)); if (CurrLength <= MinLength) or (MinLength = 0) then begin ConnectToPoint := CrossPoints[3]; MinLength := CurrLength; end; end; isInRegion := PtInPolygon(Points, CrossPoints[4]); if isInRegion then begin CurrLength := SQRT(SQR(CrossPoints[4].x - SideConn.ActualPoints[1].x) + SQR(CrossPoints[4].y - SideConn.ActualPoints[1].y)); if (CurrLength <= MinLength) or (MinLength = 0) then begin ConnectToPoint := CrossPoints[4]; MinLength := CurrLength; end; end; // подвинуть к месту соединения SaveFigureSnap := GFigureSnap; SavePrevFigureSnap := GPrevFigureSnap; GFigureSnap := nil; GPrevFigureSnap := nil; // !!! Подравнять по алгоритму если есть точка соединения if (ConnectToPoint.x <> 0) and (ConnectToPoint.y <> 0) then begin //!!! Tolik 23/11/2015 -- по False получим "улет" настроек, так как переменные для сохранения не проинициализированы!!! // там может быть мусор (и не 0 и не 1 а хз что...) {if GCadform.PCad.SnapToGrids then SnapGrids := true; if GCadform.PCad.SnapToGuides then SnapGuides := true;} if GCadform.PCad.SnapToGrids then SnapGrids := true else SnapGrids := false; if GCadform.PCad.SnapToGuides then SnapGuides := true else SnapGuides := false; // ------------------------------- GCadform.PCad.SnapToGrids := false; GCadform.PCad.SnapToGuides := false; //Tolik -- 20/03/2018 -- //if not CheckJoinVertical(ConnectedConn,) then if ConnectedConn.ConnectorType = ct_Clear then begin {if CompareValue(ConnectedConn.ActualZOrder[1], aPointObject.ActualZOrder[1]) = 0 then begin if not CheckJoinVertical(ConnectedConn) and CanMoveConns then begin if GCadForm.PCad.TraceFigure <> nil then // если идет создание трассы и в настройках установлено подключать в месте клика и begin if GCadForm.PCad.TraceFigure is TOrthoLine then // выключена опция подтягивать трассу к точечному - тогда не нужно двигать коннектор begin if GConnectTraceOnClickPoint then begin if GMoveRouteToPointObject then ConnectedConn.Move(ConnectToPoint.x - ConnectedConn.ActualPoints[1].x, ConnectToPoint.y - ConnectedConn.ActualPoints[1].y) else begin if CheckCanMovePointOnSnap(aPointObject) then aPointObject.Move(ConnectedConn.Ap1.x - APointObject.Ap1.x, ConnectedConn.Ap1.y - APointObject.Ap1.y); end; end else ConnectedConn.Move(ConnectToPoint.x - ConnectedConn.ActualPoints[1].x, ConnectToPoint.y - ConnectedConn.ActualPoints[1].y); end else ConnectedConn.Move(ConnectToPoint.x - ConnectedConn.ActualPoints[1].x, ConnectToPoint.y - ConnectedConn.ActualPoints[1].y); end else ConnectedConn.Move(ConnectToPoint.x - ConnectedConn.ActualPoints[1].x, ConnectToPoint.y - ConnectedConn.ActualPoints[1].y); end else ConnectedConn.Move(ConnectToPoint.x - ConnectedConn.ActualPoints[1].x, ConnectToPoint.y - ConnectedConn.ActualPoints[1].y); end else ConnectedConn.Move(ConnectToPoint.x - ConnectedConn.ActualPoints[1].x, ConnectToPoint.y - ConnectedConn.ActualPoints[1].y); } end; if SnapGrids then GCadform.PCad.SnapToGrids := True; if SnapGuides then GCadform.PCad.SnapToGuides := True; end; if ConnectedConn.Selected then ConnectedConn.Deselect; // DELETE FROM PM DeleteObjectFromPM(ConnectedConn.ID, ConnectedConn.Name); GFigureSnap := SaveFigureSnap; GPrevFigureSnap := SavePrevFigureSnap; end; //Tolik GTempJoinedLinesConnectors.Clear; if CreatedList then FreeAndNil(GTempJoinedLinesConnectors); // AutoConnectObjectToConnectors(APointObject, AConnector, TempNewConnList); if TempNewConnList <> nil then FreeAndNil(TempNewConnList); ReCalcZCoordSnapObjects(APointObject); // Протокол GCadForm.mProtocol.Lines.Add(cEndPoints_Mes1 + APointObject.Name + cCommon_Mes1 + AConnector.Name + '"'); RefreshCAD(GCadForm.PCad); if GCadForm.PCad.SnapToGrids then begin for i := 0 to APointObject.JoinedConnectorsList.Count - 1 do begin JoinedConn := TConnectorObject(APointObject.JoinedConnectorsList[i]); for j := 0 to JoinedConn.JoinedOrtholinesList.Count - 1 do begin //JoinedLine := TOrthoLine(AConnector.JoinedOrtholinesList[j]); JoinedLine := TOrthoLine(JoinedConn.JoinedOrtholinesList[j]); //JoinedLine.FObjectFromRaisedLine := APointObject; ReAlignLine(JoinedLine); end; end; end; except on E: Exception do addExceptionToLogEx('U_Common.SnapPointObjectToConnector', E.Message); end; end; (* procedure SnapPointObjectToConnector(APointObject, AConnector: TConnectorObject; AOnRaise: Boolean = false); var i, j: integer; CurrLine: TOrthoLine; isExistInList: Boolean; isInRegion: Boolean; CurrConnector: TConnectorObject; SideConn: TConnectorObject; ConnectedConn: TConnectorObject; Points: TDoublePointArr; CrossPoints: array [1..4] of TDoublePoint; RegHandle: HRGN; MinLength: Double; CurrLength: Double; ConnectToPoint: TDoublePoint; SaveFigureSnap: TFigure; SavePrevFigureSnap: TFigure; LHandle: integer; FindRaise: TConnectorObject; TempNewConnList: TList; JoinedLine: TOrthoLine; JoinedConn: TConnectorObject; RaiseConn: TConnectorObject; RaiseLine: TOrthoLine; OtherList: TF_CAD; OtherRaise: TConnectorObject; AddDeltaX, AddDeltaY: Double; ComponWidth: Double; SnapGrids,SnapGuides: Boolean; FindFreeLine: Boolean; RememberI, StartCicle: Integer; //Tolik CreatedList: Boolean; CanMoveConns: Boolean; VertLine, FindedRaiseLine: TOrthoLine; Procedure SortConnLineListWithRaise; var i : Integer; JoinedLine: TOrthoLine; begin if AConnector.JoinedOrtholinesList.Count > 1 then begin for i := 0 to AConnector.JoinedOrtholinesList.Count - 1 do begin JoinedLine := TOrthoLine(AConnector.JoinedOrthoLinesList[i]); if JoinedLine.FIsRaiseUpDown then begin FindedRaiseLine := JoinedLine; if i <> 0 then AConnector.JoinedOrtholinesList.Exchange(i, 0); break; end; end; end; end; // begin // Tolik -- 09/02/2017 -- TempNewConnList := nil; // try FindFreeLine := false; //From Dimon ;) RememberI := -1; ConnectedConn := nil; //#From Oleg# CreatedList := False; //Tolik 20/03/2018 -- CanMoveConns := (AConnector.FConnRaiseType = crt_None); FindedRaiseLine := Nil; SortConnLineListWithRaise; // APointObject.ActualZOrder[1] := AConnector.ActualZOrder[1]; APointObject.FConnRaiseType := AConnector.FConnRaiseType; //Tolik -- 20/03/2018 -- !!! Нельзя здесь!!! Потому что последующий сдвиг точечного подвинет и FObjectFromRaise;!!!! //APointObject.FObjectFromRaise := AConnector.FObjectFromRaise; // RaiseConn := GetRaiseConn(AConnector); if RaiseConn <> nil then begin RaiseConn.FObjectFromRaise := APointObject; RaiseLine := GetRaiseLine(RaiseConn); if RaiseLine <> nil then RaiseLine.FObjectFromRaisedLine := APointObject; end; if (AConnector.FConnRaiseType = crt_BetweenFloorUp) or (AConnector.FConnRaiseType = crt_BetweenFloorDown) or (AConnector.FConnRaiseType = crt_TrunkUp) or (AConnector.FConnRaiseType = crt_TrunkDown) then begin APointObject.FID_ConnToPassage := AConnector.FID_ConnToPassage; APointObject.FID_ListToPassage := AConnector.FID_ListToPassage; OtherList := GetListByID(AConnector.FID_ListToPassage); if OtherList <> nil then begin OtherRaise := TConnectorObject(GetFigureByID(OtherList, AConnector.FID_ConnToPassage)); if OtherRaise <> nil then OtherRaise.FID_ConnToPassage := APointObject.ID; end; end; // Tolik - - 20/03/2018 -- APointObject.FObjectFromRaise := AConnector.FObjectFromRaise; // AConnector.FConnRaiseType := crt_None; AConnector.FObjectFromRaise := nil; AConnector.FID_ConnToPassage := -1; AConnector.FID_ListToPassage := -1; FindRaise := GetRaiseConn(APointObject); if FindRaise <> nil then begin // SnapConnectorToConnector(AConnector, FindRaise); //Tolik 29/03/2018 -- //AConnector := SnapConnectorToConnector(AConnector, FindRaise); CheckingSnapConnectorToConnector(AConnector, FindRaise); // Exit; end; SaveFigureSnap := GFigureSnap; SavePrevFigureSnap := GPrevFigureSnap; GFigureSnap := nil; GPrevFigureSnap := nil; APointObject.Move(AConnector.ActualPoints[1].x - APointObject.ActualPoints[1].x, AConnector.ActualPoints[1].y - APointObject.ActualPoints[1].y); GFigureSnap := SaveFigureSnap; GPrevFigureSnap := SavePrevFigureSnap; TempNewConnList := TList.Create; LHandle := GCadForm.PCad.GetLayerHandle(2); isExistInList := False; for i := 0 to APointObject.JoinedConnectorsList.Count - 1 do begin CurrConnector := TConnectorObject(APointObject.JoinedConnectorsList[i]); if CurrConnector = AConnector then isExistInList := True; end; if not isExistInList then begin APointObject.JoinedConnectorslist.Add(AConnector); AConnector.JoinedConnectorslist.Add(APointObject); end; // сохранить конекторы - начальные точки присоединенных линий // // Tolik -- 25/03/2016 -- // GTempJoinedLinesConnectors.Clear; if GTempJoinedLinesConnectors <> nil then GTempJoinedLinesConnectors.Clear else begin GTempJoinedLinesConnectors := TList.Create; CreatedList := True; end; for i := 0 to AConnector.JoinedOrtholinesList.Count - 1 do begin SideConn := TConnectorObject(TOrthoLine(AConnector.JoinedOrtholinesList[i]).JoinConnector1); if SideConn <> AConnector then GTempJoinedLinesConnectors.Add(SideConn); SideConn := TConnectorObject(TOrthoLine(AConnector.JoinedOrtholinesList[i]).JoinConnector2); if SideConn <> AConnector then GTempJoinedLinesConnectors.Add(SideConn); end; // если разветвление !!! if AConnector.JoinedOrtholinesList.Count > 1 then begin //Предварительный поиска трассы со свободным интерфейсом for i := 0 to AConnector.JoinedOrtholinesList.Count - 1 do begin CurrLine := TOrthoLine(AConnector.JoinedOrtholinesList[i]); if not FindFreeLine then //From Dimon ;) begin //TODO: Тут тоже, скорей всего, нужно пройтись по всем скс-компонентам... for j := 0 to F_ProjMan.GSCSBase.CurrProject.CurrList.GetCatalogFromReferencesBySCSID(CurrLine.ID).SCSComponents.Count - 1 do if CheckCurrLine(F_ProjMan.GSCSBase.CurrProject.CurrList.GetCatalogFromReferencesBySCSID(CurrLine.ID).SCSComponents[j].Interfaces, APointObject)then begin RememberI := i; FindFreeLine := true; Break; end; end; if FindFreeLine then Break; end; if FindFreeLine then StartCicle := 0 else StartCicle := 1; for i := StartCicle to AConnector.JoinedOrtholinesList.Count - 1 do begin CurrLine := TOrthoLine(AConnector.JoinedOrtholinesList[i]); if i = RememberI then continue; ClearLineInterfaces(APointObject, AConnector,CurrLine, FindFreeLine); if TConnectorObject(TOrthoLine(CurrLine.JoinConnector1)) = AConnector then begin CurrLine.JoinConnector1 := nil; ConnectedConn := TConnectorObject.Create(CurrLine.ActualPoints[1].x, CurrLine.ActualPoints[1].y, AConnector.ActualZOrder[1], LHandle, mydsNormal, GCadForm.PCad); ConnectedConn.ConnectorType := ct_Clear; GCadForm.PCad.AddCustomFigure (GLN(LHandle), ConnectedConn, False); CurrLine.SetJConnector1(ConnectedConn); APointObject.JoinedConnectorsList.Add(ConnectedConn); ConnectedConn.JoinedConnectorsList.Add(APointObject); TempNewConnList.Add(ConnectedConn); if CurrLine.FIsRaiseUpDown then begin ConnectedConn.LockMove := True; ConnectedConn.LockModify := True; end; end; if TConnectorObject(TOrthoLine(CurrLine.JoinConnector2)) = AConnector then begin CurrLine.JoinConnector2 := nil; ConnectedConn := TConnectorObject.Create(CurrLine.ActualPoints[2].x, CurrLine.ActualPoints[2].y, AConnector.ActualZOrder[1], LHandle, mydsNormal, GCadForm.PCad); ConnectedConn.ConnectorType := ct_Clear; GCadForm.PCad.AddCustomFigure (GLN(LHandle), ConnectedConn, False); CurrLine.SetJConnector2(ConnectedConn); APointObject.JoinedConnectorsList.Add(ConnectedConn); ConnectedConn.JoinedConnectorsList.Add(APointObject); TempNewConnList.Add(ConnectedConn); if CurrLine.FIsRaiseUpDown then begin ConnectedConn.LockMove := True; ConnectedConn.LockModify := True; end; end; end; if Assigned(CurrLine) then CurrLine := nil; if RememberI <> -1 then begin CurrLine := TOrthoLine(AConnector.JoinedOrtholinesList[RememberI]); j := 0; end else j := 1; while j < AConnector.JoinedOrtholinesList.Count do begin if TOrthoLine(AConnector.JoinedOrtholinesList[j]) <> CurrLine then AConnector.JoinedOrtholinesList.Delete(j) else inc(j); end; end; // получить точки пересечения линии с обьектом if CanMoveConns then for i := 0 to GTempJoinedLinesConnectors.Count - 1 do begin if i = 0 then ConnectedConn := AConnector else if i > 0 then ConnectedConn := TConnectorObject(TempNewConnList[i - 1]); SideConn := TConnectorObject(GTempJoinedLinesConnectors[i]); if (APointObject.DrawFigure.InFigures.Count = 1) and CheckFigureByClassName(TFigure(APointObject.DrawFigure.InFigures[0]), 'TWMFObject') then begin ComponWidth := APointObject.DrawFigure.GetBoundRect.Right - APointObject.DrawFigure.GetBoundRect.Left; AddDeltaX := 0.04 * ComponWidth; AddDeltaY := APointObject.GrpSizeY * 0.04; end else begin AddDeltaX := 0; AddDeltaY := 0; end; //Внутри делает то, что ниже FillPOintsForConnect(SideConn,APointObject,ConnectedConn,AddDeltaX, AddDeltaY,Points,CrossPoints); // создать регион точек точечного обьекта MinLength := 0; CurrLength := 0; ConnectToPoint.x := 0; ConnectToPoint.y := 0; isInRegion := PtInPolygon(Points, CrossPoints[1]); if isInRegion then begin CurrLength := SQRT(SQR(CrossPoints[1].x - SideConn.ActualPoints[1].x) + SQR(CrossPoints[1].y - SideConn.ActualPoints[1].y)); MinLength := CurrLength; ConnectToPoint := CrossPoints[1]; end; isInRegion := PtInPolygon(Points, CrossPoints[2]); if isInRegion then begin CurrLength := SQRT(SQR(CrossPoints[2].x - SideConn.ActualPoints[1].x) + SQR(CrossPoints[2].y - SideConn.ActualPoints[1].y)); if (CurrLength <= MinLength) or (MinLength = 0) then begin ConnectToPoint := CrossPoints[2]; MinLength := CurrLength; end; end; isInRegion := PtInPolygon(Points, CrossPoints[3]); if isInRegion then begin CurrLength := SQRT(SQR(CrossPoints[3].x - SideConn.ActualPoints[1].x) + SQR(CrossPoints[3].y - SideConn.ActualPoints[1].y)); if (CurrLength <= MinLength) or (MinLength = 0) then begin ConnectToPoint := CrossPoints[3]; MinLength := CurrLength; end; end; isInRegion := PtInPolygon(Points, CrossPoints[4]); if isInRegion then begin CurrLength := SQRT(SQR(CrossPoints[4].x - SideConn.ActualPoints[1].x) + SQR(CrossPoints[4].y - SideConn.ActualPoints[1].y)); if (CurrLength <= MinLength) or (MinLength = 0) then begin ConnectToPoint := CrossPoints[4]; MinLength := CurrLength; end; end; // подвинуть к месту соединения SaveFigureSnap := GFigureSnap; SavePrevFigureSnap := GPrevFigureSnap; GFigureSnap := nil; GPrevFigureSnap := nil; // !!! Подравнять по алгоритму если есть точка соединения if (ConnectToPoint.x <> 0) and (ConnectToPoint.y <> 0) then begin //!!! Tolik 23/11/2015 -- по False получим "улет" настроек, так как переменные для сохранения не проинициализированы!!! // там может быть мусор (и не 0 и не 1 а хз что...) {if GCadform.PCad.SnapToGrids then SnapGrids := true; if GCadform.PCad.SnapToGuides then SnapGuides := true;} if GCadform.PCad.SnapToGrids then SnapGrids := true else SnapGrids := false; if GCadform.PCad.SnapToGuides then SnapGuides := true else SnapGuides := false; // ------------------------------- GCadform.PCad.SnapToGrids := false; GCadform.PCad.SnapToGuides := false; //Tolik -- 20/03/2018 -- //if not CheckJoinVertical(ConnectedConn,) then if not CheckJoinVertical(ConnectedConn,) and CanMoveConns then // ConnectedConn.Move(ConnectToPoint.x - ConnectedConn.ActualPoints[1].x, ConnectToPoint.y - ConnectedConn.ActualPoints[1].y); if SnapGrids then GCadform.PCad.SnapToGrids := True; if SnapGuides then GCadform.PCad.SnapToGuides := True; end; if ConnectedConn.Selected then ConnectedConn.Deselect; // DELETE FROM PM DeleteObjectFromPM(ConnectedConn.ID, ConnectedConn.Name); GFigureSnap := SaveFigureSnap; GPrevFigureSnap := SavePrevFigureSnap; end; //Tolik GTempJoinedLinesConnectors.Clear; if CreatedList then FreeAndNil(GTempJoinedLinesConnectors); // AutoConnectObjectToConnectors(APointObject, AConnector, TempNewConnList); if TempNewConnList <> nil then FreeAndNil(TempNewConnList); ReCalcZCoordSnapObjects(APointObject); // Протокол GCadForm.mProtocol.Lines.Add(cEndPoints_Mes1 + APointObject.Name + cCommon_Mes1 + AConnector.Name + '"'); RefreshCAD(GCadForm.PCad); if GCadForm.PCad.SnapToGrids then begin for i := 0 to APointObject.JoinedConnectorsList.Count - 1 do begin JoinedConn := TConnectorObject(APointObject.JoinedConnectorsList[i]); for j := 0 to JoinedConn.JoinedOrtholinesList.Count - 1 do begin //JoinedLine := TOrthoLine(AConnector.JoinedOrtholinesList[j]); JoinedLine := TOrthoLine(JoinedConn.JoinedOrtholinesList[j]); ReAlignLine(JoinedLine); end; end; end; except on E: Exception do addExceptionToLogEx('U_Common.SnapPointObjectToConnector', E.Message); end; end; *) (* // ПРИВЯЗКА ПУСТОГО КОНЕКТОРА К ОБЬЕКТУ procedure SnapPointObjectToConnector(APointObject, AConnector: TConnectorObject; AOnRaise: Boolean = false); var i, j: integer; CurrLine: TOrthoLine; isExistInList: Boolean; isInRegion: Boolean; CurrConnector: TConnectorObject; SideConn: TConnectorObject; ConnectedConn: TConnectorObject; Points: TDoublePointArr; CrossPoints: array [1..4] of TDoublePoint; RegHandle: HRGN; MinLength: Double; CurrLength: Double; ConnectToPoint: TDoublePoint; SaveFigureSnap: TFigure; SavePrevFigureSnap: TFigure; LHandle: integer; FindRaise: TConnectorObject; TempNewConnList: TList; JoinedLine: TOrthoLine; JoinedConn: TConnectorObject; RaiseConn: TConnectorObject; RaiseLine: TOrthoLine; OtherList: TF_CAD; OtherRaise: TConnectorObject; AddDeltaX, AddDeltaY: Double; ComponWidth: Double; SnapGrids,SnapGuides: Boolean; //Tolik CreatedList: Boolean; // begin try ConnectedConn := nil; //#From Oleg# //Tolik CreatedList := False; // APointObject.ActualZOrder[1] := AConnector.ActualZOrder[1]; APointObject.FConnRaiseType := AConnector.FConnRaiseType; APointObject.FObjectFromRaise := AConnector.FObjectFromRaise; RaiseConn := GetRaiseConn(AConnector); if RaiseConn <> nil then begin RaiseConn.FObjectFromRaise := APointObject; RaiseLine := GetRaiseLine(RaiseConn); if RaiseLine <> nil then RaiseLine.FObjectFromRaisedLine := APointObject; end; if (AConnector.FConnRaiseType = crt_BetweenFloorUp) or (AConnector.FConnRaiseType = crt_BetweenFloorDown) or (AConnector.FConnRaiseType = crt_TrunkUp) or (AConnector.FConnRaiseType = crt_TrunkDown) then begin APointObject.FID_ConnToPassage := AConnector.FID_ConnToPassage; APointObject.FID_ListToPassage := AConnector.FID_ListToPassage; OtherList := GetListByID(AConnector.FID_ListToPassage); if OtherList <> nil then begin OtherRaise := TConnectorObject(GetFigureByID(OtherList, AConnector.FID_ConnToPassage)); if OtherRaise <> nil then OtherRaise.FID_ConnToPassage := APointObject.ID; end; end; AConnector.FConnRaiseType := crt_None; AConnector.FObjectFromRaise := nil; AConnector.FID_ConnToPassage := -1; AConnector.FID_ListToPassage := -1; FindRaise := GetRaiseConn(APointObject); if FindRaise <> nil then begin SnapConnectorToConnector(AConnector, FindRaise); Exit; end; SaveFigureSnap := GFigureSnap; SavePrevFigureSnap := GPrevFigureSnap; GFigureSnap := nil; GPrevFigureSnap := nil; APointObject.Move(AConnector.ActualPoints[1].x - APointObject.ActualPoints[1].x, AConnector.ActualPoints[1].y - APointObject.ActualPoints[1].y); GFigureSnap := SaveFigureSnap; GPrevFigureSnap := SavePrevFigureSnap; TempNewConnList := TList.Create; LHandle := GCadForm.PCad.GetLayerHandle(2); isExistInList := False; for i := 0 to APointObject.JoinedConnectorsList.Count - 1 do begin CurrConnector := TConnectorObject(APointObject.JoinedConnectorsList[i]); if CurrConnector = AConnector then isExistInList := True; end; if not isExistInList then begin APointObject.JoinedConnectorslist.Add(AConnector); AConnector.JoinedConnectorslist.Add(APointObject); end; // сохранить конекторы - начальные точки присоединенных линий // Tolik -- 25/03/2016 -- // GTempJoinedLinesConnectors.Clear; if GTempJoinedLinesConnectors <> nil then GTempJoinedLinesConnectors.Clear else begin GTempJoinedLinesConnectors := TList.Create; CreatedList := True; end; // for i := 0 to AConnector.JoinedOrtholinesList.Count - 1 do begin SideConn := TConnectorObject(TOrthoLine(AConnector.JoinedOrtholinesList[i]).JoinConnector1); if SideConn <> AConnector then GTempJoinedLinesConnectors.Add(SideConn); SideConn := TConnectorObject(TOrthoLine(AConnector.JoinedOrtholinesList[i]).JoinConnector2); if SideConn <> AConnector then GTempJoinedLinesConnectors.Add(SideConn); end; // если разветвление !!! if AConnector.JoinedOrtholinesList.Count > 1 then begin for i := 1 to AConnector.JoinedOrtholinesList.Count - 1 do begin CurrLine := TOrthoLine(AConnector.JoinedOrtholinesList[i]); if TConnectorObject(TOrthoLine(CurrLine.JoinConnector1)) = AConnector then begin CurrLine.JoinConnector1 := nil; ConnectedConn := TConnectorObject.Create(CurrLine.ActualPoints[1].x, CurrLine.ActualPoints[1].y, AConnector.ActualZOrder[1], LHandle, mydsNormal, GCadForm.PCad); ConnectedConn.ConnectorType := ct_Clear; GCadForm.PCad.AddCustomFigure (GLN(LHandle), ConnectedConn, False); CurrLine.SetJConnector1(ConnectedConn); APointObject.JoinedConnectorsList.Add(ConnectedConn); ConnectedConn.JoinedConnectorsList.Add(APointObject); TempNewConnList.Add(ConnectedConn); if CurrLine.FIsRaiseUpDown then begin ConnectedConn.LockMove := True; ConnectedConn.LockModify := True; end; end; if TConnectorObject(TOrthoLine(CurrLine.JoinConnector2)) = AConnector then begin CurrLine.JoinConnector2 := nil; ConnectedConn := TConnectorObject.Create(CurrLine.ActualPoints[2].x, CurrLine.ActualPoints[2].y, AConnector.ActualZOrder[1], LHandle, mydsNormal, GCadForm.PCad); ConnectedConn.ConnectorType := ct_Clear; GCadForm.PCad.AddCustomFigure (GLN(LHandle), ConnectedConn, False); CurrLine.SetJConnector2(ConnectedConn); APointObject.JoinedConnectorsList.Add(ConnectedConn); ConnectedConn.JoinedConnectorsList.Add(APointObject); TempNewConnList.Add(ConnectedConn); if CurrLine.FIsRaiseUpDown then begin ConnectedConn.LockMove := True; ConnectedConn.LockModify := True; end; end; end; j := 1; while j < AConnector.JoinedOrtholinesList.Count do begin AConnector.JoinedOrtholinesList.Delete(j); end; end; // получить точки пересечения линии с обьектом for i := 0 to GTempJoinedLinesConnectors.Count - 1 do begin if i = 0 then ConnectedConn := AConnector else if i > 0 then ConnectedConn := TConnectorObject(TempNewConnList[i - 1]); SideConn := TConnectorObject(GTempJoinedLinesConnectors[i]); if (APointObject.DrawFigure.InFigures.Count = 1) and CheckFigureByClassName(TFigure(APointObject.DrawFigure.InFigures[0]), 'TWMFObject') then begin ComponWidth := APointObject.DrawFigure.GetBoundRect.Right - APointObject.DrawFigure.GetBoundRect.Left; AddDeltaX := 0.04 * ComponWidth; AddDeltaY := APointObject.GrpSizeY * 0.04; end else begin AddDeltaX := 0; AddDeltaY := 0; end; //Внутри делает то, что ниже FillPOintsForConnect(SideConn,APointObject,ConnectedConn,AddDeltaX, AddDeltaY,Points,CrossPoints); // создать регион точек точечного обьекта MinLength := 0; CurrLength := 0; ConnectToPoint.x := 0; ConnectToPoint.y := 0; isInRegion := PtInPolygon(Points, CrossPoints[1]); if isInRegion then begin CurrLength := SQRT(SQR(CrossPoints[1].x - SideConn.ActualPoints[1].x) + SQR(CrossPoints[1].y - SideConn.ActualPoints[1].y)); MinLength := CurrLength; ConnectToPoint := CrossPoints[1]; end; isInRegion := PtInPolygon(Points, CrossPoints[2]); if isInRegion then begin CurrLength := SQRT(SQR(CrossPoints[2].x - SideConn.ActualPoints[1].x) + SQR(CrossPoints[2].y - SideConn.ActualPoints[1].y)); if (CurrLength <= MinLength) or (MinLength = 0) then begin ConnectToPoint := CrossPoints[2]; MinLength := CurrLength; end; end; isInRegion := PtInPolygon(Points, CrossPoints[3]); if isInRegion then begin CurrLength := SQRT(SQR(CrossPoints[3].x - SideConn.ActualPoints[1].x) + SQR(CrossPoints[3].y - SideConn.ActualPoints[1].y)); if (CurrLength <= MinLength) or (MinLength = 0) then begin ConnectToPoint := CrossPoints[3]; MinLength := CurrLength; end; end; isInRegion := PtInPolygon(Points, CrossPoints[4]); if isInRegion then begin CurrLength := SQRT(SQR(CrossPoints[4].x - SideConn.ActualPoints[1].x) + SQR(CrossPoints[4].y - SideConn.ActualPoints[1].y)); if (CurrLength <= MinLength) or (MinLength = 0) then begin ConnectToPoint := CrossPoints[4]; MinLength := CurrLength; end; end; // подвинуть к месту соединения SaveFigureSnap := GFigureSnap; SavePrevFigureSnap := GPrevFigureSnap; GFigureSnap := nil; GPrevFigureSnap := nil; // !!! Подравнять по алгоритму если есть точка соединения if (ConnectToPoint.x <> 0) and (ConnectToPoint.y <> 0) then begin //!!! Tolik 23/11/2015 -- по False получим "улет" настроек, так как переменные для сохранения не проинициализированы!!! // тут может быть значение которое и не False и не True {if GCadform.PCad.SnapToGrids then SnapGrids := true; if GCadform.PCad.SnapToGuides then SnapGuides := true;} if GCadform.PCad.SnapToGrids then SnapGrids := true else SnapGrids := false; if GCadform.PCad.SnapToGuides then SnapGuides := true else SnapGuides := false; // ------------------------------- GCadform.PCad.SnapToGrids := false; GCadform.PCad.SnapToGuides := false; if not CheckJoinVertical(ConnectedConn) then ConnectedConn.Move(ConnectToPoint.x - ConnectedConn.ActualPoints[1].x, ConnectToPoint.y - ConnectedConn.ActualPoints[1].y); if SnapGrids then GCadform.PCad.SnapToGrids := True; if SnapGuides then GCadform.PCad.SnapToGuides := True; end; if ConnectedConn.Selected then ConnectedConn.Deselect; // DELETE FROM PM DeleteObjectFromPM(ConnectedConn.ID, ConnectedConn.Name); GFigureSnap := SaveFigureSnap; GPrevFigureSnap := SavePrevFigureSnap; end; //Tolik GTempJoinedLinesConnectors.Clear; if CreatedList then FreeAndNil(GTempJoinedLinesConnectors); // AutoConnectObjectToConnectors(APointObject, AConnector, TempNewConnList); if TempNewConnList <> nil then FreeAndNil(TempNewConnList); ReCalcZCoordSnapObjects(APointObject); // Протокол GCadForm.mProtocol.Lines.Add(cEndPoints_Mes1 + APointObject.Name + cCommon_Mes1 + AConnector.Name + '"'); RefreshCAD(GCadForm.PCad); if GCadForm.PCad.SnapToGrids then begin for i := 0 to APointObject.JoinedConnectorsList.Count - 1 do begin JoinedConn := TConnectorObject(APointObject.JoinedConnectorsList[i]); for j := 0 to JoinedConn.JoinedOrtholinesList.Count - 1 do begin JoinedLine := TOrthoLine(AConnector.JoinedOrtholinesList[j]); ReAlignLine(JoinedLine); end; end; end; except on E: Exception do addExceptionToLogEx('U_Common.SnapPointObjectToConnector', E.Message); end; end; *) // ОТВЯЗКА ПУСТОГО КОНЕКТОРА ОТ ОБЬЕКТУ procedure UnsnapConnectorFromPointObject(AConnector, APointObject: TConnectorObject; AOnRaise: Boolean = false); var i, j: integer; SaveFigureSnap: TFigure; JoinedLine: TOrthoLine; JoinedConn: TConnectorObject; isDisconnected: Boolean; ptrInterfRecord1, ptrInterfRecord2: PConnectObjectParam; ParamsList1, ParamsList2: TList; // Tolik 20/10/2016 -- SavedGFigureSnap, SavedGPrevFigureSnap: TFigure; // begin // Tolik 09/02/2017 -- ParamsList1 := nil; ParamsList2 := nil; // BaseBeginUpdate; // Tolik 20/16/2016 -- SavedGFigureSnap := GFigureSnap; SavedGPrevFigureSnap := GPrevFigureSnap; // try if (aConnector <> nil) and (APointObject <> nil) and (not aConnector.deleted) and (not aPointObject.deleted) then begin AConnector.JoinedConnectorsList.Remove(APointObject); APointObject.JoinedConnectorsList.Remove(AConnector); // Tolik -- 11/05/2016 -- выравнять отсоединенный коннектор по точечному объекту // автоматический Unsnap сбросит текущие координаты коннектора GFigureSnap := nil;//APointObject; // Tolik -- 19/04/2017 -- если на райзе - выровнять райз по поинту (на всякий) if AOnRaise then if APointObject.ConnectorType = ct_NB then //AConnector.MoveP(APointObject.ActualPoints[1].x - AConnector.ActualPoints[1].x, APointObject.ActualPoints[1].y - AConnector.ActualPoints[1].y, True); AConnector.Move(APointObject.ActualPoints[1].x - AConnector.ActualPoints[1].x, APointObject.ActualPoints[1].y - AConnector.ActualPoints[1].y); // if Not AOnRaise then begin ParamsList1 := TList.create; ParamsList2 := TList.create; for i := 0 to AConnector.JoinedOrtholinesList.Count - 1 do begin JoinedLine := TOrthoLine(AConnector.JoinedOrtholinesList[i]); JoinedLine.UpdateLengthTextBox(false, true); New(ptrInterfRecord1); ptrInterfRecord1.IDObject := JoinedLine.ID; if AConnector = JoinedLine.JoinConnector1 then ptrInterfRecord1.Side := 1; if AConnector = JoinedLine.JoinConnector2 then ptrInterfRecord1.Side := 2; ParamsList1.Add(ptrInterfRecord1); end; // занести данные с ТО New(ptrInterfRecord2); ptrInterfRecord2.IDObject := APointObject.ID; ptrInterfRecord2.Side := -1; ParamsList2.Add(ptrInterfRecord2); // занести данные с присоединенных линий for i := 0 to APointObject.JoinedConnectorsList.Count - 1 do begin JoinedConn := TConnectorObject(APointObject.JoinedConnectorsList[i]); if JoinedConn <> AConnector then begin for j := 0 to JoinedConn.JoinedOrtholinesList.Count - 1 do begin JoinedLine := TOrthoLine(JoinedConn.JoinedOrtholinesList[j]); New(ptrInterfRecord2); ptrInterfRecord2.IDObject := JoinedLine.ID; if JoinedConn = JoinedLine.JoinConnector1 then ptrInterfRecord2.Side := 1; if JoinedConn = JoinedLine.JoinConnector2 then ptrInterfRecord2.Side := 2; ParamsList2.Add(ptrInterfRecord2); end; end; end; isDisconnected := DisconnectObjectsInPM(ParamsList1, ParamsList2); // Tolik 09/02/2017 -- if ParamsList1 <> nil then begin for i := 0 to ParamsList1.Count - 1 do begin Dispose(PConnectObjectParam(ParamsList1[i])); end; FreeAndNil(ParamsList1); end; if ParamsList2 <> nil then begin for i := 0 to ParamsList2.Count - 1 do begin Dispose(PConnectObjectParam(ParamsList2[i])); end; FreeAndNil(ParamsList2); end; // end; //Tolik 20/11/2019 -- //AConnector.Name := cCadClasses_Mes12; // AddConnObjectInPM(AConnector.ID, AConnector.FCabinetID, AConnector.Name); // Commented By Tolik 20/04/2016 -- не понятно нах нужно ... то ли не дописано, то ли ни х не дает, // то ли не удалось смоделировать подходящую ситуацию, чтобы отработало правмльно //Если к соеденителю подключена трасса, ставим ему высоту трассы {if AConnector.JoinedOrtholinesList.Count > 0 then begin if (APointObject.ActualZOrder[1] >= TOrtholine(AConnector.JoinedOrtholinesList[0]).ActualZOrder[1]) and(APointObject.ActualZOrder[1] >= TOrtholine(AConnector.JoinedOrtholinesList[0]).ActualZOrder[2])then begin if TOrtholine(AConnector.JoinedOrtholinesList[0]).ActualZOrder[1] < TOrtholine(AConnector.JoinedOrtholinesList[0]).ActualZOrder[2] then AConnector.ActualZOrder[1] := TOrtholine(AConnector.JoinedOrtholinesList[0]).ActualZOrder[1] else AConnector.ActualZOrder[1] := TOrtholine(AConnector.JoinedOrtholinesList[0]).ActualZOrder[2]; end else begin if TOrtholine(AConnector.JoinedOrtholinesList[0]).ActualZOrder[1] < TOrtholine(AConnector.JoinedOrtholinesList[0]).ActualZOrder[2] then AConnector.ActualZOrder[1] := TOrtholine(AConnector.JoinedOrtholinesList[0]).ActualZOrder[2] else AConnector.ActualZOrder[1] := TOrtholine(AConnector.JoinedOrtholinesList[0]).ActualZOrder[1]; end; end else } //иначе оставляем на такой же высоте AConnector.ActualZOrder[1] := APointObject.ActualZOrder[1]; SetConFigureCoordZInPM(AConnector.ID, AConnector.ActualZOrder[1]); // удалить с-п if APointObject.FObjectFromRaise <> nil then begin // DestroyRaiseOnPointObject(APointObject.FObjectFromRaise); // APointObject.Delete; // RefreshCAD(GCadForm.PCad); end; for i := 0 to AConnector.JoinedOrtholinesList.Count - 1 do begin JoinedLine := TOrthoLine(AConnector.JoinedOrtholinesList[i]); JoinedLine.CalculLength := JoinedLine.LengthCalc; JoinedLine.LineLength := JoinedLine.CalculLength; JoinedLine.UpdateLengthTextBox(false, true); end; end; except on E: Exception do addExceptionToLogEx('U_Common.UnsnapConnectorFromPointObject', E.Message); end; // Tolik 20/16/2016 -- GFigureSnap := SavedGFigureSnap; GPrevFigureSnap := SavedGPrevFigureSnap; // BaseEndUpdate; end; function GetCrossPoint(X1_Line, Y1_Line, X2_Line, Y2_Line, X1_Object, Y1_Object, X2_Object, Y2_Object: Double): TDoublePoint; var A1, B1, C1: Double; A2, B2, C2: Double; x, y: Double; F1, F2: Double; begin try Result := DoublePoint(0, 0); x := 0; //#From Oleg# y := 0; //#From Oleg# A1 := Y2_Line - Y1_Line; if A1 = 0 then A1 := 0.001; B1 := - (X2_Line - X1_Line); if B1 = 0 then B1 := 0.001; C1 := - A1 * X1_Line - B1 * Y1_Line; A2 := Y2_Object - Y1_Object; B2 := - (X2_Object - X1_Object); C2 := - A2 * X1_Object - B2 * Y1_Object; //14.09.2010 F1 := A1 * x + B1 * y + C1; //14.09.2010 F2 := A2 * x + B2 * y + C2; try x := (B2 * C1 - B1 * C2) / (A2 * B1 - A1 * B2); except x := (B2 * C1 - B1 * C2); end; try y := (A1 * x + C1) / (- B1); except y := (A1 * x + C1); end; Result.x := x; Result.y := y; except on E: Exception do addExceptionToLogEx('U_Common.GetCrossPoint', E.Message); end; end; Procedure GetConnectedOrthoLinesListOnConn(aConn: TConnectorObject; var aLineList: TList); var i, j: Integer; NextConn, JoinedConn: TConnectorObject; vLine1, vLine2, RaiseLine: TOrthoLine; JoinedLine: TOrthoLine; begin vLine1 := nil; vLine2 := nil; if aLineList = nil then aLineList := TList.Create; if aConn.ConnectorType = ct_Clear then begin for i := 0 to aConn.JoinedOrthoLinesList.Count - 1 do begin JoinedLine := TOrthoLine(aConn.JoinedOrthoLinesList[i]); if aLineList.IndexOf(JoinedLine) = -1 then begin aLineList.Add(JoinedLine); if (JoinedLine.FIsVertical or JoinedLine.fisRaiseUpDown) then begin NextConn := TConnectorObject(JoinedLine.JoinConnector1); if NextConn.ID = aConn.Id then NextConn := TconnectorObject(JoinedLine.JoinConnector2); if NextConn.JoinedConnectorsList.Count > 0 then NextConn := TConnectorObject(NextConn.JoinedConnectorsList[0]); GetConnectedOrthoLinesListOnConn(NextConn, aLineList); end; end; end; end else if aConn.ConnectorType = ct_NB then begin for i := 0 to aConn.JoinedConnectorsList.Count - 1 do begin JoinedConn := TConnectorObject(AConn.JoinedconnectorsList[i]); for j := 0 to JoinedConn.JoinedOrthoLinesList.Count - 1 do begin JoinedLine := TOrthoLine(JoinedConn.JoinedOrthoLinesList[j]); if aLineList.IndexOf(JoinedLine) = -1 then begin aLineList.Add(JoinedLine); if (JoinedLine.FIsVertical or JoinedLine.fisRaiseUpDown) then begin NextConn := TConnectorObject(JoinedLine.JoinConnector1); if NextConn.ID = JoinedConn.ID then NextConn := TConnectorObject(JoinedLine.JoinConnector2); if NextConn.JoinedConnectorsList.Count > 0 then NextConn := TConnectorObject(NextConn.JoinedConnectorsList[0]); GetConnectedOrthoLinesListOnConn(NextConn, aLineList); end; end; end; end; end; end; // Tolik 23/04/2018 -- переписана совсем...старая закомменчена -- смотри ниже procedure CheckingSnapConnectorToOrtholine(AConnector: TConnectorObject; ASnapLine: TOrtholine); var i: integer; JoinedLine: TOrthoLine; SnapZ: Double; SnapConn: TConnectorObject; ObjParams: TObjectParams; ConnectedLineList: TList; begin // Tolik -- 23/04/2018 -- if AConnector.JoinedConnectorsList.Count > 0 then exit; // на всякий // если снапнулись на присоединенную линию(может даже где-то через вертикаль или райз, неважно как ...) - нах отсюда ConnectedLineList := TList.Create; GetConnectedOrthoLinesListOnConn(AConnector, ConnectedLineList); if ConnectedLineList.IndexOf(aSnapLine) <> -1 then begin ConnectedLineList.Free; GCadForm.mProtocol.Lines.Add(cCadClasses_Mes11_8); exit; end; ConnectedLineList.Free; // BaseBeginUpdate; try // получить высоту снапа if CompareValue(TConnectorObject(ASnapLine.JoinConnector1).ActualzOrder[1], TConnectorObject(ASnapLine.JoinConnector2).ActualZOrder[1]) = 0 then SnapZ := TConnectorObject(ASnapLine.JoinConnector1).ActualzOrder[1] else // если линая наклонная - вычислить высоту разделения линии SnapZ := GetCoordZ(ASnapLine, AConnector.ap1.x, AConnector.ap1.y); if CompareValue(AConnector.ActualZOrder[1], SnapZ) = 0 then // высоты совпадают SnapConnectorToOrtholine(AConnector, ASnapLine) else begin // высоты не совпадают SnapConn := TConnectorObject.Create(AConnector.ap1.x, AConnector.ap1.y, SnapZ, AConnector.LayerHandle, mydsNormal, GCadForm.PCad); SnapConn.ConnectorType := ct_Clear; GCadForm.PCad.AddCustomFigure (GLN(AConnector.LayerHandle), SnapConn, False); SnapConn.Name := cCadClasses_Mes12; SetNewObjectNameInPM(SnapConn.ID, SnapConn.Name); ObjParams := GetFigureParams(SnapConn.ID); SnapConn.Name := ObjParams.Name; SnapConn.FIndex := ObjParams.MarkID; SnapConnectorToOrtholine(SnapConn, ASnapLine); CheckingSnapConnectorToConnector(AConnector, SnapConn); end; except on E: Exception do addExceptionToLogEx('U_Common.CheckingSnapConnectorToOrtholine', E.Message); end; BaseEndUpdate; end; { procedure CheckingSnapConnectorToOrtholine(AConnector: TConnectorObject; ASnapLine: TOrtholine); var i: integer; LastObjectHeight: double; RaiseConn: TConnectorObject; RaiseLine: TOrthoLine; JoinedLine: TOrthoLine; ObjFromRaise: TConnectorObject; begin BaseBeginUpdate; try if AConnector.JoinedConnectorsList.Count = 0 then begin // пустой конектор к линии LastObjectHeight := AConnector.ActualZOrder[1]; // высоты не совпадают if LastObjectHeight <> ASnapLine.ActualZOrder[1] then begin CreateRaiseOnConnector(AConnector, ASnapLine.ActualZOrder[1]); RaiseConn := GetRaiseConn(AConnector); SnapConnectorToOrtholine(RaiseConn, ASnapLine); end else SnapConnectorToOrtholine(AConnector, ASnapLine); end; except on E: Exception do addExceptionToLogEx('U_Common.CheckingSnapConnectorToOrtholine', E.Message); end; BaseEndUpdate; end; } // Tolik 23/04/2018 -- переписана (совсем). старая закомменчена -- смотри ниже procedure CheckingSnapPointObjectToOrthoLine(APointObject: TConnectorObject; ASnapLine: TOrthoLine); var JoinedLine: TOrthoLine; SnapConn: TConnectorObject; TracesList: TList; SnapZ: Double; ObjParams: TObjectParams; begin if (IsSpecialTraceFigure(ASnapLine)) or (ASnapLine.FIsVertical) then exit; BaseBeginUpdate; BeginDevideLine; try // проверить, не попадаем ли на присоединенную линию .. если да -- нах отсюда TracesList := TList.Create; GetConnectedOrthoLinesListOnConn(APointObject, TracesList); if TracesList.IndexOf(aSnapLine) <> -1 then begin TracesList.Free; GCadForm.mProtocol.Lines.Add(cCadClasses_Mes11_8); EndDevideLine; BaseEndUpdate; exit; end; TracesList.Free; // получить высоту снапа if CompareValue(TConnectorObject(ASnapLine.JoinConnector1).ActualzOrder[1], TConnectorObject(ASnapLine.JoinConnector2).ActualZOrder[1]) = 0 then SnapZ := TConnectorObject(ASnapLine.JoinConnector1).ActualzOrder[1] else // если линая наклонная - вычислить высоту разделения линии SnapZ := GetCoordZ(ASnapLine, APointObject.ap1.x, APointObject.ap1.y); // создать коннектор и разделить линию ... SnapConn := TConnectorObject.Create(APointObject.ap1.x, APointObject.ap1.y, SnapZ, APointObject.LayerHandle, mydsNormal, GCadForm.PCad); SnapConn.ConnectorType := ct_Clear; GCadForm.PCad.AddCustomFigure (GLN(APointObject.LayerHandle), SnapConn, False); SnapConn.Name := cCadClasses_Mes12; SetNewObjectNameInPM(SnapConn.ID, SnapConn.Name); ObjParams := GetFigureParams(SnapConn.ID); SnapConn.Name := ObjParams.Name; SnapConn.FIndex := ObjParams.MarkID; SnapConnectorToOrtholine(SnapConn, ASnapLine); //Tolik 08/08/2021 -- APointObject.MoveP(SnapConn.ap1.x - APointObject.ap1.x, SnapConn.ap1.y - APointObject.ap1.y, False, False); // if CompareValue(APointObject.ActualZOrder[1], SnapZ) = 0 then // высоты совпадают begin SnapConn.JoinedConnectorsList.Insert(0, APointObject); APointObject.JoinedConnectorsList.Add(SnapConn); DeleteObjectFromPM(SnapConn.ID, SnapConn.Name); // Tolik 19/11/2019 -- end else // высоты не совпадают CheckingSnapPointObjectToConnector(APointObject, SnapConn); except on E: Exception do addExceptionToLogEx('U_Common.CheckingSnapPointObjectToOrthoLine', E.Message); end; EndDevideLine; BaseEndUpdate; end; (* procedure CheckingSnapPointObjectToOrthoLine(APointObject: TConnectorObject; ASnapLine: TOrthoLine); var i: integer; LastObjectHeight: double; RaiseConn: TConnectorObject; RaiseLine: TOrthoLine; JoinedLine: TOrthoLine; ObjFromRaise: TConnectorObject; SnapConn: TConnectorObject; TracesList: TList; begin if (IsSpecialTraceFigure(ASnapLine)) or (ASnapLine.FIsVertical) then exit; BaseBeginUpdate; BeginDevideLine; // Tolik -- 07/02/2017 -- TracesList := nil; // try if HaveObjectCorkComponent(APointObject.ID) then APointObject.ActualZOrder[1] := ASnapLine.ActualZOrder[1]; LastObjectHeight := APointObject.ActualZOrder[1]; // обьект к линии TracesList := GetAllConnectedTraces(APointObject); SnapPointObjectToOrthoLine(APointObject, ASnapLine); // высоты не совпадают //Tolik // if LastObjectHeight <> APointObject.ActualZOrder[1] then if (TConnectorObject(APointObject).Radius > 10000000) then begin if ( (LastObjectHeight <> APointObject.ActualZOrder[1]) or (((TConnectorObject(APointObject).Radius - 11000000) <> 999) and ((TConnectorObject(APointObject).Radius - 11000000) <> APointObject.ActualZOrder[1])) ) then begin //Tolik {if ( (not F_ProjMan.GSCSBase.CurrProject.CurrList.Setting.CADAutoPosTraceBetweenRM) and ((TConnectorObject(APointObject).Radius - 11000000) <> 999 ) ) then begin} // создать спуск/подъем // Tolik // CreateRaiseOnPointObject(APointObject, LastObjectHeight); // CreateRaiseOnPointObject(APointObject, TConnectorObject(APointObject).Radius - 11000000); CreateRaiseOnPointObject(APointObject, TConnectorObject(APointObject).ActualZOrder[1]); // вернуть ранее подключенные трассы на их высоту for i := 0 to TracesList.Count - 1 do begin JoinedLine := TOrthoLine(TracesList[i]); RaiseLineOnHeight(JoinedLine, TConnectorObject(APointObject).Radius - 11000000{LastObjectHeight}, TracesList); end; { end;} end; end else begin if LastObjectHeight <> APointObject.ActualZOrder[1] then begin CreateRaiseOnPointObject(APointObject, LastObjectHeight); // вернуть ранее подключенные трассы на их высоту for i := 0 to TracesList.Count - 1 do begin JoinedLine := TOrthoLine(TracesList[i]); RaiseLineOnHeight(JoinedLine, LastObjectHeight, TracesList); end; end; end; except on E: Exception do addExceptionToLogEx('U_Common.CheckingSnapPointObjectToOrthoLine', E.Message); end; EndDevideLine; BaseEndUpdate; // Tolik -- 07/02/2017 -- if TracesList <> nil then FreeAndNil(TracesList); // end; *) // Tolik 10/04/2018 -- //procedure CheckingSnapConnectorToConnector(AConnector, ASnapConnector: TConnectorObject); //function CheckingSnapConnectorToConnector(AConnector, ASnapConnector: TConnectorObject): TConnectorObject; function CheckingSnapConnectorToConnector(AConnector, ASnapConnector: TConnectorObject; aManual: Boolean = False): TConnectorObject; // // var i: integer; RaiseConn: TConnectorObject; RaiseLine: TOrthoLine; JoinedLine: TOrthoLine; ObjFromRaise: TConnectorObject; RaiseLine1, RaiseLine2: TOrthoLine; SnapConn: TConnectorObject; AConnHasRaise, ASnapConnHasRaise : Boolean; AConnHasVLines, ASnapConnHasVLines: Boolean; PassedList: TList; ConnIsUP: Boolean; Snap_Type: Integer; LineToSnap: TOrtholine; PointObj: TConnectorObject; AutoPosBetweenRM_Flag: Boolean; Function GetRaiseLineFromClearConn(AConn: TConnectorObject; var aFlag: Boolean): TOrthoLine; var i: Integer; begin Result := nil; aFlag := False; for i := 0 to AConn.JoinedOrtholinesList.Count - 1 do begin if TOrthoLine(AConn.JoinedOrtholinesList[i]).FIsRaiseUpDown then begin Result := TOrthoLine(AConn.JoinedOrtholinesList[i]); aFlag := True; break; end; end; end; Function CheckConnHasVLine(AConn: TConnectorObject): Boolean; var i : Integer; begin Result := False; for i := 0 to AConn.JoinedOrtholinesList.Count - 1 do begin if TOrthoLine(AConn.JoinedOrtholinesList[i]).FIsVertical then begin Result := True; break; end; end; end; //определить смотрит ли райз в направлении коннектора, на который снапимся и выставить второй коннектор райза function isRightRaiseDirection(aRaise: TOrthoLine; aConn: TConnectorObject; aDirection: Boolean) : Boolean; begin Result := False; RaiseConn := nil; if aRaise.JoinConnector1.ID = aConn.ID then RaiseConn := TConnectorObject(aRaise.JoinConnector2) else if aRaise.JoinConnector2.ID = aConn.ID then RaiseConn := TConnectorObject(aRaise.JoinConnector1); if RaiseConn <> nil then begin if aDirection then begin if CompareValue(RaiseConn.ActualZOrder[1], aConn.ActualZOrder[1]) = 1 then Result := True; end else if CompareValue(RaiseConn.ActualZOrder[1], aConn.ActualZOrder[1]) = -1 then Result := True; end; end; Function CheckSnapOnRaise(aRaise: TOrthoLine; aConn: TConnectorObject): Boolean; begin Result := False; if CompareValue(TConnectorObject(aRaise.JoinConnector1).ActualZOrder[1], aConn.ActualZOrder[1]) = 1 then if CompareValue(TConnectorObject(aRaise.JoinConnector2).ActualZOrder[1], aConn.ActualZOrder[1]) = -1 then begin Result := True; exit; end; if CompareValue(TConnectorObject(aRaise.JoinConnector2).ActualZOrder[1], aConn.ActualZOrder[1]) = 1 then if CompareValue(TConnectorObject(aRaise.JoinConnector1).ActualZOrder[1], aConn.ActualZOrder[1]) = -1 then Result := True; end; // проверить, не является ли райз межэтажным переходом или магистралью function CheckRaise(aRaise: TOrthoLine): Boolean; var Conn1, Conn2: TConnectorObject; begin Result := False; Conn1 := TConnectorObject(aRaise.JoinConnector1); Conn2 := TConnectorObject(aRaise.JoinConnector2); Result := ((Conn1.FConnRaiseType in [crt_BetweenFloorUp, crt_BetweenFloorDown, crt_TrunkUp, crt_TrunkDown]) or (Conn2.FConnRaiseType in [crt_BetweenFloorUp, crt_BetweenFloorDown, crt_TrunkUp, crt_TrunkDown])); if not Result then begin if Conn1.JoinedConnectorsList.Count > 0 then Conn1 := TConnectorObject(Conn1.JoinedConnectorsList[0]); if Conn2.JoinedConnectorsList.Count > 0 then Conn2 := TConnectorObject(Conn2.JoinedConnectorsList[0]); Result := ((Conn1.FConnRaiseType in [crt_BetweenFloorUp, crt_BetweenFloorDown, crt_TrunkUp, crt_TrunkDown]) or (Conn2.FConnRaiseType in [crt_BetweenFloorUp, crt_BetweenFloorDown, crt_TrunkUp, crt_TrunkDown])); end; end; // вернет высоту того коннектора райза, который ближе к коннектору снапа function GetSnapZFromRaise(aRaise: TOrthoLine; AConn:TConnectorObject): Double; var delta1, delta2: Double; begin Delta1 := ABS(TConnectorObject(aRaise.JoinConnector1).ActualZOrder[1] - AConn.ActualZOrder[1]); Delta2 := ABS(TConnectorObject(aRaise.JoinConnector2).ActualZOrder[1] - AConn.ActualZOrder[1]); Result := TConnectorObject(aRaise.JoinConnector1).ActualZOrder[1]; SnapConn := TConnectorObject(aRaise.JoinConnector1);// сразу же определим коннектор для снапа if CompareValue(Delta1, Delta2) = 1 then begin Result := TConnectorObject(aRaise.JoinConnector2).ActualZOrder[1]; SnapConn := TConnectorObject(aRaise.JoinConnector2); end; if SnapConn.JoinedConnectorsList.Count > 0 then SnapConn := TConnectorObject(SnapConn.JoinedConnectorsList[0]); end; Function SnapWithRaise(aDirection: Boolean; aRaise: TOrthoLine; AConn1, AConn2: TConnectorObject; ASnap: Integer): Boolean; var vLine: TOrthoLine; RConn1, RConn2: TConnectorObject; isSpecialRaise: Boolean; SnapZ: Double; i: Integer; JoinedLine: TOrthoLine; begin Result := False; isSpecialRaise := CheckRaise(aRaise); //если попала межэтажка или магистраль if isSpecialRaise then begin SnapZ := GetSnapZFromRaise(aRaise, AConn2); //здесь же выставится и SnapConn // опустить/поднять коннектор AConn2.ActualZOrder[1] := SnapZ; // присоединенные трассы (если есть) -- выставить высоту соотв. конца for i := 0 to AConn2.JoinedOrtholinesList.Count - 1 do begin JoinedLine := TOrtholine(AConn2.JoinedOrtholinesList[i]); if JoinedLine.JoinConnector1.ID = AConn2.ID then JoinedLine.ActualZOrder[1] := SnapZ else if JoinedLine.JoinConnector2.ID = AConn2.ID then JoinedLine.ActualZOrder[2] := SnapZ; //пересчитать длину трассы JoinedLine.CalculLength := JoinedLine.LengthCalc; JoinedLine.LineLength := JoinedLine.CalculLength; end; if SnapConn.ConnectorType = ct_Clear then begin Result := True; Snap_Type := aSnap; end else if SnapConn.ConnectorType = ct_NB then begin Result := True; PointObj := SnapConn; SnapConn := AConn2; Snap_Type := 3; end; exit; end; // // райз смотрит в сторону коннектора if isRightRaiseDirection(aRaise, AConn1, aDirection) then begin if RaiseConn <> nil then begin // если высоты вершины райза и коннектора совпадают if CompareValue(RaiseConn.ActualZorder[1], AConn2.ActualZOrder[1]) = 0 then begin SnapConn := RaiseConn; if SnapConn.JoinedConnectorsList.Count > 0 then begin PointObj := TConnectorObject(SnapConn.JoinedConnectorsList[0]); SnapConn := AConn2; Result := True; Snap_Type := 3; //найденный объект на коннектор exit; end else begin Result := True; Snap_Type := ASnap; // найденный коннектор на коннектор exit; end; end else begin //если не разрешено использование вертикальных трасс - нах if not GUseVerticalTraces then //если запрещено оспользование вертикальных трасс -- сообщение и нах... begin GCadForm.mProtocol.Lines.Add(cCadClasses_Mes11 + cCadClasses_Mes11_1); exit; end; ConvertRaiseToVertical(ARaise); //делаем из райза вертикаль // снап на райз if CheckSnapOnRaise(aRaise, AConn2) then begin LineToSnap := aRaise; SnapConn := AConn2; Result := True; Snap_Type := 4; exit; end; // если высоты коннекторов не совпали и снап на райз не проходит, значит нужно строить дополнительную вертикаль if RaiseConn.JoinedConnectorsList.Count = 0 then // на пустом коннекторе VLine := CreateVerticalOnConnector(RaiseConn, AConn2.ActualZOrder[1]) else // на объекте VLine := CreateVerticalOnPointObject(TConnectorObject(RaiseConn.JoinedConnectorsList[0]), AConn2.ActualZOrder[1]); if VLine <> nil then begin SnapConn := TConnectorObject(VLine.JoinConnector1); if CompareValue(SnapConn.ActualZOrder[1], AConn2.ActualZOrder[1]) <> 0 then SnapConn := TConnectorObject(vLine.JoinConnector2); Result := True; Snap_Type := aSnap; exit; end; end; end; end else // райз смотрит в противоположную сторону -- нужно создавать вертикали begin //если не разрешено использование вертикальных трасс - нах if not GUseVerticalTraces then //если запрещено оспользование вертикальных трасс -- сообщение и нах... begin GCadForm.mProtocol.Lines.Add(cCadClasses_Mes11 + cCadClasses_Mes11_1); exit; end; ConvertRaiseToVertical(aRaise); //делаем из райза вертикаль if RaiseConn.JoinedConnectorsList.Count = 0 then // на пустом коннекторе VLine := CreateVerticalOnConnector(AConn1, AConn2.ActualZOrder[1]); if VLine <> nil then begin SnapConn := TConnectorObject(VLine.JoinConnector1); if CompareValue(SnapConn.ActualZOrder[1], AConn2.ActualZOrder[1]) <> 0 then SnapConn := TConnectorObject(vLine.JoinConnector2); Result := True; Snap_Type := aSnap; //коннектор на коннектор exit; end; end; end; Function SnapWithVerticalLine(aConn1, aConn2: TConnectorObject; aDirection: Boolean; aSnap: Integer): Boolean; var vLine1, vLine2: TOrthoLine; i, j: Integer; PassedList: TList; JoinedConn, NextConn: TConnectorObject; CanSeekVline: Boolean; begin Result := False; vLine1 := Nil; vLine2 := Nil; for i := 0 to aConn1.JoinedOrtholinesList.Count - 1 do begin if TOrthoLine(aConn1.JoinedOrtholinesList[i]).FIsVertical then begin if isRightRaiseDirection(TOrthoLine(aConn1.JoinedOrtholinesList[i]), aConn1, aDirection) then //если вертикаль направлена всторону коннектора begin vLine1 := TOrthoLine(aConn1.JoinedOrtholinesList[i]); break; end; end end; if vLine1 <> nil then // если есть вертикать в сторону коннектора begin // снап на вертикаль if CheckSnapOnRaise(vLine1, aConn2) then begin Result := True; LineToSnap := vLine1; SnapConn := AConn2; Snap_Type := 4; // коннектор на вертикаль exit; end; // на второй коннектор вертикали if vLine1.JoinConnector1.ID = aConn1.ID then JoinedConn := TConnectorObject(vLine1.JoinConnector2) else JoinedConn := TConnectorObject(vLine1.JoinConnector1); if JoinedConn.JoinedConnectorsList.Count > 0 then JoinedConn := TConnectorObject(JoinedConn.JoinedConnectorsList[0]); if CompareValue(JoinedConn.ActualZOrder[1], aConn2.ActualZOrder[1]) = 0 then begin if JoinedConn.ConnectorType = ct_NB then begin PointObj := JoinedConn; SnapConn := AConn2; Snap_type := 3; // объект на коннектор Result := True; exit; end else begin SnapConn := JoinedConn; Snap_type := aSnap; // коннектор на коннектор Result := True; exit; end; end; // не попали ни на вертикаль ни на коннектор -- смотрим, может в данном направлении еще вертикали есть ... PassedList := TList.create; PassedList.Add(vLine1); CanSeekVline := True; while CanSeekVLine do begin CanSeekVLine := False; vLine1 := Nil; if JoinedConn.ConnectorType = ct_NB then begin for i := 0 to JoinedConn.JoinedConnectorsList.Count - 1 do begin for j := 0 to TConnectorObject(JoinedConn.JoinedConnectorsList[i]).JoinedOrtholinesList.Count - 1 do begin vLine1 := TOrthoLine(TConnectorObject(JoinedConn.JoinedConnectorsList[i]).JoinedOrtholinesList[j]); if vLine1.FIsVertical then begin if PassedList.IndexOf(vLine1) = -1 then // нашли вертикаль begin // сразу определим второй коннектор вертикали if TConnectorObject(vLine1.JoinConnector1).ID = TConnectorObject(JoinedConn.JoinedConnectorsList[i]).ID then NextConn := TConnectorObject(vLine1.JoinConnector2) else NextConn := TConnectorObject(vLine1.JoinConnector1); break; end else vLine1 := nil; end else vLine1 := nil; end; if vLine1 <> nil then break; end; end else begin for i := 0 to JoinedConn.JoinedOrtholinesList.Count - 1 do begin vLine1 := TOrthoLine(JoinedConn.JoinedOrtholinesList[i]); if vLine1.FIsVertical then begin if PassedList.IndexOf(vLine1) = -1 then // нашли вертикаль begin if TConnectorObject(vLine1.JoinConnector1).ID = JoinedConn.ID then NextConn := TConnectorObject(vLine1.JoinConnector2) else NextConn := TConnectorObject(vLine1.JoinConnector1); break; end else vLine1 := nil; end else vLine1 := nil; end; end; if vLine1 <> nil then begin // снап на вертикаль if CheckSnapOnRaise(vLine1, aConn2) then begin PassedList.Free; Result := True; LineToSnap := vLine1; SnapConn := AConn2; Snap_Type := 4; // коннектор на вертикаль exit; end; // снап на второй коннектор вертикали JoinedConn := NextConn; if JoinedConn.JoinedConnectorsList.Count > 0 then JoinedConn := TConnectorObject(JoinedConn.JoinedConnectorsList[0]); if CompareValue(JoinedConn.ActualZOrder[1], aConn2.ActualZOrder[1]) = 0 then begin PassedList.Free; if JoinedConn.ConnectorType = ct_NB then begin PointObj := JoinedConn; SnapConn := AConn2; Snap_type := 3; // объект на коннектор Result := True; exit; end else begin SnapConn := JoinedConn; Snap_type := aSnap; // коннектор на коннектор Result := True; exit; end; end else begin PassedList.Add(vLine1); CanSeekVLine := True; end; end; end; PassedList.Free; // не нашли вертикаль - нужно создавать на последнем коннекторе к коннектору if JoinedConn.ConnectorType = ct_NB then begin vLine1 := CreateVerticalOnPointObject(JoinedConn, aConn2.ActualZOrder[1]); if vLine1 <> nil then begin if TConnectorObject(vLine1.JoinConnector1).JoinedConnectorsList.IndexOf(JoinedConn) = -1 then SnapConn := TConnectorObject(vLine1.JoinConnector1) else SnapConn := TConnectorObject(vLine1.JoinConnector2); end; end else begin vLine1 := CreateVerticalOnConnector(JoinedConn, aConn2.ActualZOrder[1]); if vLine1 <> nil then begin if TConnectorObject(vLine1.JoinConnector1).ID = JoinedConn.ID then SnapConn := TConnectorObject(vLine1.JoinConnector2) else SnapConn := TConnectorObject(vLine1.JoinConnector1); end; end; Result := True; Snap_Type := aSnap; exit; end // нужно создавать вертикаль на коннекторе (вертикаль только одна и направлена не в ту сторону) else begin vLine1 := CreateVerticalOnConnector(aConn1, aConn2.ActualZOrder[1]); if vLine1 <> nil then begin SnapConn := TConnectorObject(vLine1.JoinConnector1); if SnapConn.ID = aConn1.ID then SnapConn := TConnectorObject(vLine1.JoinConnector2); Snap_Type := aSnap; // коннектор на коннектор Result := True; exit; end; end; end; Function CheckCanSnap : Boolean; var i: Integer; VLine: TOrthoLine; cadMess: String; canProceed: boolean; // Tolik 21/07/2022 -- begin Result := False; canProceed := false; // Tolik 21/07/2022 -- cadMess := ''; // на всякий canProceed := (GPlugSwitch <> nil); if not canProceed then if AConnector.ConnectorType = ct_Clear then if ASnapConnector.ConnectorType = ct_Clear then if AConnector.JoinedConnectorsList.Count = 0 then if ASnapConnector.JoinedConnectorsList.Count = 0 then canProceed := true;// Tolik 21/07/2022 -- // if CanProceed then begin AConnHasRaise := False; ASnapConnHasRaise := False; AConnHasVLines := False; ASnapConnHasVLines := False; RaiseLine1 := GetRaiseLineFromClearConn(AConnector, AConnHasRaise); RaiseLine2 := GetRaiseLineFromClearConn(ASnapConnector, ASnapConnHasRaise); AConnHasVLines := CheckConnHasVLine(AConnector); ASnapConnHasVLines := CheckConnHasVLine(ASnapConnector); if (AConnHasRaise and ASnapConnHasRaise) or (AConnHasVLines and ASnapConnHasVLines) or (AConnHasRaise and ASnapConnHasVLines) or (AConnHasVLines and ASnapConnHasRaise) then begin GCadForm.mProtocol.Lines.Add(cCadClasses_Mes11_5); exit; end; if RaiseLine1 = nil then // если нет ни райзов ни вертикалей if RaiseLine2 = nil then if not AConnHasVLines then if not ASnapConnHasVLines then begin RaiseLine := Nil; SnapConn := Nil; //Tolik 06/08/2025 -- тут дядим возможность создать наклонную трассу if GCadForm.FAutoPosTraceBetweenRM then // если разрешены наклонные трассы begin Result := True; SnapConn := ASnapConnector; Snap_Type := 1; // просто коннектор на коннектор -- как есть exit; end; // if compareValue(AConnector.ActualZOrder[1], ASnapConnector.ActualZOrder[1]) <> 0 then begin CreateRaiseOnConnector(AConnector, ASnapConnector.ActualZOrder[1]); // создать райз на коннекторе for i := 0 to aConnector.JoinedOrtholinesList.Count - 1 do begin if TOrthoLine(aConnector.JoinedOrtholinesList[i]).FIsRaiseUpDown then begin RaiseLine := TOrthoLine(aConnector.JoinedOrtholinesList[i]); if RaiseLine.JoinConnector1.ID = AConnector.ID then SnapConn := TConnectorObject(RaiseLine.JoinConnector2) else SnapConn := TConnectorObject(RaiseLine.JoinConnector1); break; end; end; if SnapConn <> nil then begin Result := True; Snap_Type := 2; //коннектор райза на коннектор exit; end; end; end; //Если высоты совпадают if CompareValue(AConnector.ActualZOrder[1], ASnapConnector.ActualZOrder[1]) = 0 then begin Result := True; SnapConn := ASnapConnector; Snap_Type := 1; // просто коннектор на коннектор -- как есть exit; end else if GCadForm.FAutoPosTraceBetweenRM then // если разрешены наклонные трассы begin if AConnector.JoinedConnectorsList.Count = 0 then if not AConnHasRaise then if not AConnHasVLines then begin AConnector.ActualZOrder[1] := aSnapConnector.ActualZOrder[1]; // выравнять высоты и выставить высоты концов присоединенных трасс for i := 0 to AConnector.JoinedOrtholinesList.Count - 1 do begin if TOrthoLine(AConnector.JoinedOrtholinesList[i]).JoinConnector1 <> nil then if TOrthoLine(AConnector.JoinedOrtholinesList[i]).JoinConnector1.ID = AConnector.ID then begin TConnectorObject(TOrthoLine(AConnector.JoinedOrtholinesList[i]).JoinConnector1).ActualZOrder[1] := AConnector.ActualZOrder[1]; TOrthoLine(AConnector.JoinedOrtholinesList[i]).ActualZOrder[1] := AConnector.ActualZOrder[1]; end; if TOrthoLine(AConnector.JoinedOrtholinesList[i]).JoinConnector2 <> nil then if TOrthoLine(AConnector.JoinedOrtholinesList[i]).JoinConnector2.ID = AConnector.ID then begin TConnectorObject(TOrthoLine(AConnector.JoinedOrtholinesList[i]).JoinConnector2).ActualZOrder[1] := AConnector.ActualZOrder[1]; TOrthoLine(AConnector.JoinedOrtholinesList[i]).ActualZOrder[2] := AConnector.ActualZOrder[1]; end; end; SnapConn := ASnapConnector; Result := True; Snap_Type := 1; // просто коннектор на коннектор -- как есть exit; end; end; // сода придем ТОЛЬКО ЕСЛИ райз или вертикаль(и) есть ТОЛЬКО НА ОДНОМ ИЗ КОННЕКТОРОВ // если высоты не совпадают ConnIsUp := (CompareValue(AConnector.ActualZOrder[1], ASnapConnector.ActualZOrder[1]) = -1); if AConnHasRaise then begin Result := SnapWithRaise(ConnisUP, RaiseLine1, AConnector, ASnapConnector, 2); exit; end; if ASnapConnHasRaise then begin Result := SnapWithRaise(not ConnisUP, RaiseLine2, ASnapConnector, AConnector, 1); exit; end; if AConnHasVLines then begin Result := SnapWithVerticalLine(AConnector, ASnapConnector, ConnIsUP, 2); exit; end; if ASnapConnHasVLines then begin Result := SnapWithVerticalLine(ASnapConnector, AConnector, not ConnIsUP, 1); exit; end; end; end; // получить список трасс, подключенных со второго конца к трассе function GetLineListFromNextConn(aConn: TConnectorObject): TList; var NextSideConn, JoinedConn: TConnectorObject; JoinedLine: TOrthoLine; i, j: Integer; begin Result := nil; NextSideConn := nil; if aConn.ConnectorType = ct_Clear then begin for i := 0 to aConn.JoinedOrtholinesList.Count - 1 do begin JoinedLine := TorthoLine(aConn.JoinedOrtholinesList[i]); if JoinedLine.JoinConnector1.ID = aConn.ID then NextSideConn := TConnectorObject(JoinedLine.JoinConnector2) else if JoinedLine.JoinConnector2.ID = aConn.ID then NextSideConn := TConnectorObject(JoinedLine.JoinConnector1); if NextSideConn <> nil then break; end; end; if aConn.ConnectorType = ct_NB then begin for i := 0 to aConn.JoinedConnectorsList.Count - 1 do begin JoinedConn := TConnectorObject(aConn.JoinedConnectorsList[i]); for j := 0 to JoinedConn.JoinedOrtholinesList.Count - 1 do begin JoinedLine := TOrthoLine(JoinedConn.JoinedOrtholinesList[j]); if JoinedLine.JoinConnector1.ID = JoinedConn.ID then NextSideConn := TConnectorObject(JoinedLine.JoinConnector2) else if JoinedLine.JoinConnector2.ID = JoinedConn.ID then NextSideConn := TConnectorObject(JoinedLine.JoinConnector1); if NextSideConn <> nil then break; end; if NextSideConn <> nil then break; end; end; if NextSideConn <> nil then begin Result := TList.Create; if NextSideConn.JoinedConnectorsList.Count > 0 then NextSideConn := TConnectorObject(NextSideConn.JoinedConnectorsList[0]); if NextSideConn.ConnectorType = ct_Clear then begin for i := 0 to NextSideConn.JoinedOrtholinesList.Count - 1 do begin JoinedLine := TOrthoLine(NextSideConn.JoinedOrtholinesList[i]); if Result.IndexOf(JoinedLine) = -1 then Result.Add(JoinedLine); end; end else if NextSideConn.ConnectorType = ct_NB then begin for i := 0 to NextSideConn.JoinedConnectorsList.Count - 1 do begin JoinedConn := TConnectorObject(NextSideConn.JoinedConnectorsList[i]); For j := 0 to JoinedConn.JoinedOrtholinesList.Count - 1 do begin JoinedLine := TOrthoLine(JoinedConn.JoinedOrtholinesList[j]); if Result.IndexOf(JoinedLine) = -1 then Result.Add(JoinedLine); end; end; end; if Result.Count = 0 then begin Result.Free; Result := nil; end; end; end; // ОЧЕНЬ ВАЖНО!!! проверка, чтобы не снапнуть оба конца одной трассы на другую на одной и той же высоте !!! Function CheckSameLine(aConn1,aConn2: TConnectorObject): Boolean; var Line1, Line2: TOrthoLine; i,j: Integer; LineList1, LineList2: TList; begin Result := False; if GisOrthoLineHadow then // Tolik 27/08/2021 -- разрешить снапы концов одинаковых трасс при создании трасс exit; LineList1 := GetLineListFromNextConn(aConn1); LineList2 := GetLineListFromNextConn(aConn2); if LineList1 <> nil then if LineList2 <> nil then begin for i := 0 to LineList1.Count - 1 do begin Line1 := TOrthoLine(LineList1[i]); for j := 0 to LineList2.Count - 1 do begin Line2 := TOrthoLine(LineList2[j]); if Line1.ID = Line2.ID then begin Result := True; break; end end; if Result then break; end; end; if LineList1 <> nil then LineList1.Free; if LineList2 <> nil then LineList2.Free; end; Function CheckSnapToSameLine: Boolean; // 20/04/2018 -- var LineList1, LineList2: TList; i: Integer; JoinedLine: TOrthoLine; begin Result := False; LineList1 := TList.Create; LineList2 := TList.Create; // на первом коннекторе GetConnectedOrthoLinesListOnConn(ASnapConnector, LineList1); // на втором коннекторе GetConnectedOrthoLinesListOnConn(aConnector, LineList2); for i := 0 to LineList1.Count - 1 do begin JoinedLine := TOrthoLine(LineList1[i]); if LineList2.IndexOf(JoinedLine) <> - 1 then begin Result := True; break; end; end; LineList1.free; LineList2.free; end; begin // Tolik 08/11/2017 -- на всякий if AConnector.ID = aSnapConnector.ID then exit; // if CheckSnapToSameLine then // если притащили снап на второй конец трассы -- нах отсюда!!! exit; BaseBeginUpdate; // выставить один к одному //Tolik 03/08/2021 -- //AConnector.MoveP(ASnapConnector.Ap1.x - AConnector.Ap1.x,ASnapConnector.Ap1.y - AConnector.Ap1.y, False); AConnector.MoveP(ASnapConnector.Ap1.x - AConnector.Ap1.x,ASnapConnector.Ap1.y - AConnector.Ap1.y, False, False); // try Snap_Type := -1; if CheckCanSnap then begin // снап Result := AConnector; Case Snap_Type of 1: begin if CheckSameLine(AConnector, SnapConn) then GCadForm.mProtocol.Lines.Add(cCadClasses_Mes11_6) else begin AConnector := SnapConnectorToConnector(AConnector, SnapConn); // как есть Result := AConnector; end; end; 2: begin if CheckSameLine(ASnapConnector, SnapConn) then GCadForm.mProtocol.Lines.Add(cCadClasses_Mes11_6) else begin ASnapConnector := SnapConnectorToConnector(ASnapConnector, SnapConn); Result := ASnapConnector; end; end; 3: begin if CheckSameLine(PointObj, SnapConn) then GCadForm.mProtocol.Lines.Add(cCadClasses_Mes11_6) else begin SnapPointObjectToConnector(PointObj, SnapConn); Result := SnapConn; end; end; 4: begin //SnapConnectorToVertical(SnapConn, LineToSnap, False, True); SnapConnectorToVertical(SnapConn, LineToSnap, not GCadForm.FAutoPosTraceBetweenRM, True); Result := SnapConn; end; end; end else begin if aManual then begin try AutoPosBetweenRM_Flag := false; AutoPosBetweenRM_Flag := GCadForm.FAutoPosTraceBetweenRM; GCadForm.FAutoPosTraceBetweenRM := True; CheckingSnapConnectorToConnector(AConnector, ASnapConnector); GCadForm.FAutoPosTraceBetweenRM := AutoPosBetweenRM_Flag; except on E: Exception do GCadForm.FAutoPosTraceBetweenRM := AutoPosBetweenRM_Flag; end; end; end; except on E: Exception do addExceptionToLogEx('U_Common.CheckingSnapConnectorToConnector', E.Message); end; BaseEndUpdate; end; (* procedure CheckingSnapConnectorToConnector(AConnector, ASnapConnector: TConnectorObject); var i: integer; RaiseConn: TConnectorObject; RaiseLine: TOrthoLine; JoinedLine: TOrthoLine; ObjFromRaise: TConnectorObject; //Tolik 15/03/2017 -- function isRaiseConnector (AConn: TConnectorObject): Boolean; var i: Integer; begin Result := False; for i := 0 to aConn.JoinedOrthoLinesList.Count - 1 do begin if TOrthoLine(aConn.JoinedOrthoLinesList[i]).FisRaiseUpDown then begin Result := True; Break; //// BREAK ////; end; end; end; // begin // Tolik 08/11/2017 -- на всякий if AConnector.ID = aSnapConnector.ID then exit; // BaseBeginUpdate; try RaiseLine := nil; //#From Oleg# RaiseConn := GetRaiseConn(ASnapConnector); if RaiseConn <> nil then RaiseLine := GetRaiseLine(RaiseConn); // НЕТ С-П if (ASnapConnector.FConnRaiseType = crt_None) and (RaiseConn = nil) then begin if AConnector.ActualZOrder[1] <> ASnapConnector.ActualZOrder[1] then begin //15.09.2010 CreateRaiseOnConnector(ASnapConnector, AConnector.ActualZOrder[1]); //15.09.2010 ASnapConnector := GetRaiseConn(ASnapConnector); //15.09.//#From Oleg# if Not CheckJoinVertical(ASnapConnector) then begin // Если нету подключенных вертикальных трасс, создаем С-П CreateRaiseOnConnector(ASnapConnector, AConnector.ActualZOrder[1]); ASnapConnector := GetRaiseConn(ASnapConnector); end else begin // Ищем соединитель между В-Т (вертикальн. трассами) подходящий по высоте ASnapConnector := GetJoinedVerticalConnectorByCoordZ(ASnapConnector, AConnector.ActualZOrder[1]); // Если не соединитель, то не подключаем if (ASnapConnector <> nil) and (TConnectorObject(ASnapConnector).ConnectorType <> ct_Clear) then ASnapConnector := nil; end; end; //14.09.2010 SnapConnectorToConnector(AConnector, ASnapConnector); if ASnapConnector <> nil then // SnapConnectorToConnector(AConnector, ASnapConnector); // Tolik 15/03/2017 -- begin if isRaiseConnector(aSnapConnector) then AConnector.Move(aSnapConnector.ActualPoints[1].x - AConnector.ActualPoints[1].x, aSnapConnector.ActualPoints[1].y - AConnector.ActualPoints[1].y) else if isRaiseConnector(AConnector) then ASnapConnector.Move(AConnector.ActualPoints[1].x - ASnapConnector.ActualPoints[1].x, AConnector.ActualPoints[1].y - ASnapConnector.ActualPoints[1].y); // AConnector := SnapConnectorToConnector(AConnector, ASnapConnector); end; end else // ЭТО ВЕРШИНА С-П if ASnapConnector.FConnRaiseType <> crt_None then begin // SnapConnectorToConnector(AConnector, ASnapConnector); AConnector := SnapConnectorToConnector(AConnector, ASnapConnector); end else // ЭТО ОБЪЕКТ НА КОТOРОМ С-П if RaiseConn <> nil then begin if (AConnector.ActualZOrder[1] = RaiseConn.ActualZOrder[1]) then begin if RaiseConn.ConnectorType = ct_Clear then //SnapConnectorToConnector(AConnector, RaiseConn) AConnector := SnapConnectorToConnector(AConnector, RaiseConn) else SnapConnectorToPointObject(AConnector, RaiseConn); end else begin // SnapConnectorToConnector(AConnector, ASnapConnector); Aconnector := SnapConnectorToConnector(AConnector, ASnapConnector); if RaiseConn <> nil then RaiseConn.FObjectFromRaise := AConnector; if RaiseLine <> nil then RaiseLine.FObjectFromRaisedLine := AConnector; end; end; except on E: Exception do addExceptionToLogEx('U_Common.CheckingSnapConnectorToConnector', E.Message); end; BaseEndUpdate; end; *) // Tolik 03/04/2018 -- старая закомменчена -- смотри ниже procedure CheckingSnapConnectorToPointObject(AConnector, APointObject: TConnectorObject; aUseBaseConnector: Boolean); begin CheckingSnapPointObjectToConnector(APointObject, AConnector, False, True); // вот и все... end; (* procedure CheckingSnapConnectorToPointObject(AConnector, APointObject: TConnectorObject; aUseBaseConnector: Boolean); var LastObjectHeight: double; RaiseConn: TConnectorObject; RaiseLine: TOrthoLine; i, j: integer; JoinedLine: TOrthoLine; SnapObject: TConnectorObject; // Tolik 20/04/2016 -- PObjectJoinConnList : TList; TmpConn: TConnectorObject; // begin BaseBeginUpdate; try // Tolik 20/04/2016 - PObjectJoinConnList := nil; if AConnector.ActualZOrder[1] <> APointObject.ActualZOrder[1] then begin PObjectJoinConnList := TList.Create; for i := 0 to APointObject.JoinedConnectorsList.Count - 1 do begin PObjectJoinConnList.Add(TConnectorObject(APointObject.JoinedConnectorsList[i])); end; end; // RaiseLine := nil; //#From Oleg# RaiseConn := GetRaiseConn(APointObject); if RaiseConn <> nil then RaiseLine := GetRaiseLine(RaiseConn); // НЕТ С-П if (APointObject.FConnRaiseType = crt_None) and (RaiseConn = nil) then begin LastObjectHeight := APointObject.ActualZOrder[1]; //#From Oleg# 15.09.2010 //SnapConnectorToPointObject(AConnector, APointObject); // высоты не совпадают //if LastObjectHeight <> APointObject.ActualZOrder[1] then //begin // if aUseBaseConnector then // CreateRaiseOnPointObject(APointObject, LastObjectHeight, AConnector) // else // CreateRaiseOnPointObject(APointObject, LastObjectHeight, nil); //end; //#From Oleg# //15.09.2010 SnapObject := nil; // Если не совпадают высоты и APointObject подключен к вертикальной трассе, ищем соединитель по высоте AConnector if (AConnector.ActualZOrder[1] <> APointObject.ActualZOrder[1]) then if CheckJoinVertical(APointObject) then SnapObject := GetJoinedVerticalConnectorByCoordZ(APointObject, AConnector.ActualZOrder[1]); if SnapObject = nil then begin SnapConnectorToPointObject(AConnector, APointObject); // высоты не совпадают if LastObjectHeight <> APointObject.ActualZOrder[1] then begin // Tolik 20/04/2016 for i := 0 to PObjectJoinConnList.Count - 1 do begin TmpConn := TConnectorObject(PObjectJoinConnList[i]); APointObject.JoinedConnectorsList.Remove(TConnectorObject(TmpConn)); end; // if aUseBaseConnector then CreateRaiseOnPointObject(APointObject, LastObjectHeight, AConnector) else CreateRaiseOnPointObject(APointObject, LastObjectHeight, nil); // Tolik 20/04/2016 for i := PObjectJoinConnList.Count - 1 downto 0 do begin TmpConn := TConnectorObject(PObjectJoinConnList[i]); APointObject.JoinedConnectorsList.Insert(0,TConnectorObject(TmpConn)); end; // end; end else begin if SnapObject.ConnectorType = ct_Clear then // SnapConnectorToConnector(AConnector, SnapObject) //Tolik 29/03/2018 -- //AConnector := SnapConnectorToConnector(AConnector, SnapObject) CheckingSnapConnectorToConnector(AConnector, SnapObject) // else SnapConnectorToPointObject(AConnector, SnapObject); end; end else // ЭТО ВЕРШИНА С-П if APointObject.FConnRaiseType <> crt_None then begin SnapConnectorToPointObject(AConnector, APointObject); end else // ЭТО ОБЪЕКТ НА КОТОРОМ С-П if RaiseConn <> nil then begin if (AConnector.ActualZOrder[1] = RaiseConn.ActualZOrder[1]) then begin if RaiseConn.ConnectorType = ct_Clear then // SnapConnectorToConnector(AConnector, RaiseConn) //Tolik 29/03/2018 -- //AConnector := SnapConnectorToConnector(AConnector, RaiseConn) CheckingSnapConnectorToConnector(AConnector, RaiseConn) // else SnapConnectorToPointObject(AConnector, RaiseConn); end else begin AConnector.ActualZOrder[1] := APointObject.ActualZOrder[1]; SnapConnectorToPointObject(AConnector, APointObject); if RaiseConn <> nil then RaiseConn.FObjectFromRaise := APointObject; if RaiseLine <> nil then RaiseLine.FObjectFromRaisedLine := APointObject; end; end; // Tolik 20/04/2016 -- if PObjectJoinConnList <> nil then FreeAndNil(PObjectJoinConnList); // except on E: Exception do addExceptionToLogEx('U_Common.CheckingSnapConnectorToPointObject', E.Message); end; BaseEndUpdate; end; *) // Tolik 03/04/2018 -- //Procedure MoveConnToConn(aConn1, aConn2: TConnectorObject); // 03/04/2018 -- Procedure MoveConnToConn(aConn1, aConn2: TConnectorObject; AlignConn: Boolean = true); begin // if aConn1.FConnRaiseType = crt_None then aConn1.MoveP(aConn2.Ap1.x - aConn1.Ap1.x, aConn2.Ap1.y - aConn1.Ap1.y, False, AlignConn); end; function CheckAllowTracesBetweenRM(AConn: TConnectorObject): Boolean; // размещать трассы на высоте РМ (из настроек када) -- 03/04/2018 -- Begin Result := False; if aConn.Owner <> nil then if aConn.Owner.Owner <> nil then Result := TF_CAD(TPowerCad(aConn.Owner).Owner).FAutoPosTraceBetweenRM; end; // Старая закомменчена -- смотри ниже // Tolik 21/03/2018 -- //procedure CheckingSnapPointObjectToConnector(APointObject, AConnector: TConnectorObject); //procedure CheckingSnapPointObjectToConnector(APointObject, AConnector: TConnectorObject; APointObjectDroppedFromNB: Boolean = False; aConnToPoint: Boolean = False); procedure CheckingSnapPointObjectToConnector(APointObject, AConnector: TConnectorObject; APointObjectDroppedFromNB: Boolean = False; aConnToPoint: Boolean = False; aManual: Boolean = False); var LastObjectHeight: double; RaiseConn: TConnectorObject; ObjFromRaise: TConnectorObject; RaiseLine: TOrthoLine; i, j: integer; JoinedLine: TOrthoLine; JoinedConn: TConnectorObject; RaiseType: TConnRaiseType; RaiseLength: Double; VLine: TOrthoLine; ClearConnHasRaise, ClearConnHasVLine: Boolean; PointHasRaise, PointHasVLine: Boolean; Snap_Type: Integer; VPointLine1, VPointLine2, VClearConnLine1, VClearConnLine2, VLineToSnap: TOrthoLine; SnapConn: TConnectorObject; NeedSnapToLine: Boolean; ConnIsUP: Boolean; PassedList: TList; // список пройденных трасс (чтобы не пойти назад при поиске) AutoPosBetweenRM_Flag: Boolean; Function CheckSnapConnToVLine(aLine: TOrthoLine; aConn: TConnectorObject): Boolean; begin Result := (((CompareValue(TConnectorObject(aLine.JoinConnector1).ActualZOrder[1], aConn.ActualZOrder[1]) = -1) and (CompareValue(TConnectorObject(aLine.JoinConnector2).ActualZOrder[1], aConn.ActualZOrder[1]) = 1)) or ((CompareValue(TConnectorObject(aLine.JoinConnector1).ActualZOrder[1], aConn.ActualZOrder[1]) = 1) and (CompareValue(TConnectorObject(aLine.JoinConnector2).ActualZOrder[1], aConn.ActualZOrder[1]) = -1))); end; function CheckCanSnapLineConnToConn(aLine: TOrthoLine; ACheckConn, ASnapConn: TConnectorObject): Boolean; begin SnapConn := Nil; Result := False; if ACheckConn.ConnectorType = ct_NB then begin if CompareValue(TConnectorObject(aLine.JoinConnector1).ActualZOrder[1], ASnapConn.ActualZorder[1]) = 0 then if TConnectorObject(aLine.JoinConnector1).JoinedConnectorsList.IndexOf(ACheckConn) = -1 then SnapConn := TConnectorObject(aLine.JoinConnector1); if SnapConn = nil then if CompareValue(TConnectorObject(aLine.JoinConnector2).ActualZOrder[1], ASnapConn.ActualZorder[1]) = 0 then if TConnectorObject(aLine.JoinConnector2).JoinedConnectorsList.IndexOf(ACheckConn) = -1 then SnapConn := TConnectorObject(aLine.JoinConnector2); end else if ACheckConn.ConnectorType = ct_Clear then begin if CompareValue(TConnectorObject(aLine.JoinConnector1).ActualZOrder[1], ASnapConn.ActualZorder[1]) = 0 then if TConnectorObject(aLine.JoinConnector1).ID <> ACheckConn.ID then SnapConn := TConnectorObject(aLine.JoinConnector1); if SnapConn = nil then if CompareValue(TConnectorObject(aLine.JoinConnector2).ActualZOrder[1], ASnapConn.ActualZorder[1]) = 0 then if TConnectorObject(aLine.JoinConnector2).ID <> ACheckConn.ID then SnapConn := TConnectorObject(aLine.JoinConnector2); end; if SnapConn <> nil then begin if SnapConn.JoinedConnectorsList.Count > 0 then SnapConn := TConnectorObject(SnapConn.JoinedConnectorsList[0]); Result := True; end; end; // Вернет коннектор вертикали (верхний или нижний) -- в зависимости от направления function GetConnFromVLineByDirection(DirectionUP: Boolean; aLine: TOrthoLine): TConnectorObject; var VCon: TConnectorObject; begin Result := Nil; VCon := Nil; if aLine.FIsVertical then begin if DirectionUP then begin if CompareValue(TConnectorObject(aLine.JoinConnector1).ActualZOrder[1], TConnectorObject(aLine.JoinConnector2).ActualZOrder[1]) = 1 then Result := TConnectorObject(TConnectorObject(aLine.JoinConnector1)) else if CompareValue(TConnectorObject(aLine.JoinConnector1).ActualZOrder[1], TConnectorObject(aLine.JoinConnector2).ActualZOrder[1]) = -1 then Result := TConnectorObject(aLine.JoinConnector2); end else begin if CompareValue(TConnectorObject(aLine.JoinConnector1).ActualZOrder[1], TConnectorObject(aLine.JoinConnector2).ActualZOrder[1]) = -1 then Result := TConnectorObject(TConnectorObject(aLine.JoinConnector1)) else if CompareValue(TConnectorObject(aLine.JoinConnector1).ActualZOrder[1], TConnectorObject(aLine.JoinConnector2).ActualZOrder[1]) = 1 then Result := TConnectorObject(aLine.JoinConnector2); end; end; end; Procedure buildVList(AConn: TConnectorObject; aDirection: Boolean); // построить список вертикалей var currVLine: TOrtholine; i,j: Integer; LineFinded: boolean; currConn, NextConn: TConnectorObject; begin currConn := nil; NextConn := Nil; LineFinded := False; PassedList.Clear; if AConn.ConnectorType = ct_clear then // на пустом коннекторе begin if TConnectorObject(VClearConnLine1.JoinConnector1).ID <> AConn.ID then currConn := TconnectorObject(VClearConnLine1.JoinConnector1) else currConn := TConnectorObject(VClearConnLine1.JoinConnector2); if ConnIsUP then //если коннектор выше объекта (значит с коннектора смотрим вниз) begin if Comparevalue(currConn.ActualZOrder[1], AConn.ActualZOrder[1]) = -1 then begin PassedList.Add(VClearConnLine1); LineFinded := True; end else begin if VClearConnLine2 <> nil then begin if TConnectorObject(VClearConnLine2.JoinConnector1).ID <> AConn.ID then currConn := TconnectorObject(VClearConnLine2.JoinConnector1) else currConn := TConnectorObject(VClearConnLine2.JoinConnector2); if Comparevalue(currConn.ActualZOrder[1], AConn.ActualZOrder[1]) = -1 then begin PassedList.Add(VClearConnLine1); LineFinded := True; end end; end; end else // если коннектор ниже объекта (смотрим с коннектора вверх) begin if Comparevalue(currConn.ActualZOrder[1], AConn.ActualZOrder[1]) = 1 then begin PassedList.Add(VClearConnLine1); LineFinded := True; end else begin if VClearConnLine2 <> nil then begin if TConnectorObject(VClearConnLine2.JoinConnector1).ID <> AConn.ID then currConn := TconnectorObject(VClearConnLine2.JoinConnector1) else currConn := TConnectorObject(VClearConnLine2.JoinConnector2); if Comparevalue(currConn.ActualZOrder[1], AConn.ActualZOrder[1]) = 1 then begin PassedList.Add(VClearConnLine1); LineFinded := True; end end; end; end; end else if AConn.ConnectorType = ct_NB then // на объекте begin if TConnectorObject(VPointLine1.JoinConnector1).JoinedConnectorsList.IndexOf(AConn) = -1 then currConn := TConnectorObject(VPointLine1.JoinConnector1) else currConn := TConnectorObject(VPointLine1.JoinConnector2); if ConnIsUP then //если коннектор выше объекта (значит с объекта смотрим верх) begin if Comparevalue(currConn.ActualZOrder[1], AConn.ActualZOrder[1]) = 1 then begin PassedList.Add(VPointLine1); LineFinded := True; end else begin if VPointLine2 <> nil then begin if TConnectorObject(VPointLine2.JoinConnector1).JoinedConnectorsList.IndexOf(AConn) = -1 then currConn := TconnectorObject(VPointLine2.JoinConnector1) else currConn := TConnectorObject(VPointLine2.JoinConnector2); if Comparevalue(currConn.ActualZOrder[1], AConn.ActualZOrder[1]) = 1 then begin PassedList.Add(VPointLine2); LineFinded := True; end end; end; end else // если коннектор ниже объекта (смотрим с объекта вниз) begin if Comparevalue(currConn.ActualZOrder[1], AConn.ActualZOrder[1]) = -1 then begin PassedList.Add(VPointLine1); LineFinded := True; end else begin if VPointLine2 <> nil then begin if TConnectorObject(VPointLine2.JoinConnector1).JoinedConnectorsList.IndexOf(AConn) = -1 then currConn := TconnectorObject(VPointLine2.JoinConnector1) else currConn := TConnectorObject(VPointLine2.JoinConnector2); if Comparevalue(currConn.ActualZOrder[1], AConn.ActualZOrder[1]) = -1 then begin PassedList.Add(VPointLine2); LineFinded := True; end end; end; end; end; While LineFinded do begin LineFinded := False; if currConn.JoinedConnectorsList.Count = 0 then begin for i := 0 to currConn.JoinedOrtholinesList.Count - 1 do begin currVLine := TOrthoLine(currConn.JoinedOrtholinesList[i]); if currVLine.FIsVertical then if PassedList.IndexOf(currVLine) = -1 then begin LineFinded := True; PassedList.Add(currVLine); if TConnectorObject(currVLine.JoinConnector1).ID <> currConn.ID then currConn := TConnectorObject(currVLine.JoinConnector1) else currConn := TConnectorObject(currVLine.JoinConnector2); if currConn.JoinedConnectorsList.Count > 0 then currConn := TconnectorObject(currConn.JoinedConnectorsList[0]); break; end; end; end else if currConn.ConnectorType = ct_NB then begin for i := 0 to currConn.JoinedConnectorsList.Count - 1 do begin for j := 0 to TConnectorObject(currConn.JoinedConnectorsList[i]).JoinedOrtholinesList.Count - 1 do begin currVLine := TOrthoLine(TConnectorObject(currConn.JoinedConnectorsList[i]).JoinedOrtholinesList[j]); if currVLine.FIsVertical then if PassedList.IndexOf(currVLine) = -1 then begin LineFinded := True; PassedList.Add(currVLine); if TConnectorObject(currVLine.JoinConnector1).JoinedConnectorsList.IndexOf(currConn) = -1 then currConn := TConnectorObject(currVLine.JoinConnector1) else currConn := TConnectorObject(currVLine.JoinConnector2); if currConn.JoinedConnectorsList.Count > 0 then currConn := TConnectorObject(currConn.JoinedConnectorsList[0]); break; end; end; if LineFinded then break; end; end; end; end; function isRaiseDirectionRight(aRaiseLine: TOrthoLine; AConn: TConnectorObject; aDirection: Boolean): Boolean; var NextConn: TConnectorObject; begin Result := False; NextConn := TConnectorObject(aRaiseLine.JoinConnector1); if AConn.ConnectorType = ct_Clear then begin if NextConn.ID = AConn.ID then NextConn := TConnectorObject(aRaiseLine.JoinConnector2); end else begin if AConn.JoinedConnectorsList.IndexOf(NextConn) <> -1 then NextConn := TConnectorObject(ARaiseLine.JoinConnector2); end; if ADirection then // смотрим вверх begin if CompareValue(NextConn.ActualZOrder[1], AConn.ActualZOrder[1]) = 1 then Result := True; end else// смотрим вниз begin if CompareValue(NextConn.ActualZOrder[1], AConn.ActualZOrder[1]) = -1 then Result := True; end; end; Procedure SetConnHeight(AConn: TConnectorObject; AHeight : Double); var i, j: Integer; JConn: TConnectorObject; JLine: TOrthoLine; begin aConn.ActualZOrder[1] := aHeight; begin for i := 0 to aConn.JoinedConnectorsList.Count - 1 do begin JConn := TConnectorObject(aConn.JoinedConnectorsList[i]); JConn.ActualZOrder[1] := aHeight; end; end; end; Function CheckSnapToSameLine: Boolean; // 20/04/2018 -- var LineList1, LineList2: TList; i: Integer; JoinedLine: TOrthoLine; begin Result := False; LineList1 := TList.Create; LineList2 := TList.Create; // на поинте GetConnectedOrthoLinesListOnConn(aPointObject, LineList1); // на коннекторе GetConnectedOrthoLinesListOnConn(aConnector, LineList2); for i := 0 to LineList1.Count - 1 do begin JoinedLine := TOrthoLine(LineList1[i]); if LineList2.IndexOf(JoinedLine) <> - 1 then begin Result := True; break; end; end; LineList1.free; LineList2.free; end; Function CanSnapConns: Boolean; var i, j: Integer; JoinedConn: TConnectorObject; NearestVerticalConn: TConnectorObject; // Ближайший по высоте коннектор вертикали CadMess: String; AutoPosBetweenRMFlag: boolean; begin Result := False; if CheckSnapToSameLine then // если притащили снап на второй конец трассы -- нах отсюда!!! exit; CadMess := ''; ClearConnHasRaise := False; ClearConnHasVLine := False; PointHasRaise := False; PointHasVLine := False; VPointLine1 := Nil; VPointLine2 := Nil; VClearConnLine1 := Nil; VClearConnLine2 := Nil; RaiseLine := Nil; SnapConn := Nil; if APointObjectDroppedFromNB then // если снап пришел при дропе из Нормативной Базы (только создали) begin if aPointObject.ActualZOrder[1] <> AConnector.ActualZOrder[1] then begin try AutoPosBetweenRMFlag := F_ProjMan.GSCSBase.CurrProject.CurrList.Setting.CADAutoPosTraceBetweenRM; F_ProjMan.GSCSBase.CurrProject.CurrList.Setting.CADAutoPosTraceBetweenRM := False; if AConnector.ConnectorType = ct_NB then begin JoinedConn := TConnectorObject.Create(aPointObject.ap1.x, aPointObject.ap1.y, aPointObject.ActualZOrder[1], GCadForm.PCad.GetLayerHandle(GCadForm.PCad.ActiveLayer), mydsNormal, GCadForm.PCad); GCadForm.PCad.AddCustomFigure (GLN(GCadForm.PCad.GetLayerHandle(2)), JoinedConn, False); NearestVerticalConn := TConnectorObject.Create(AConnector.ap1.x, AConnector.ap1.y, AConnector.ActualZOrder[1], GCadForm.PCad.GetLayerHandle(GCadForm.PCad.ActiveLayer), mydsNormal, GCadForm.PCad); GCadForm.PCad.AddCustomFigure (GLN(GCadForm.PCad.GetLayerHandle(2)), NearestVerticalConn, False); JoinedConn.JoinedConnectorsList.Add(APointObject); NearestVerticalConn.JoinedConnectorsList.Add(AConnector); AConnector.JoinedConnectorsList.Add(NearestVerticalConn); APointObject.JoinedConnectorsList.Add(JoinedConn); // JoinedConn := SnapConnectorToConnector(JoinedConn, NearestVerticalConn); CheckingSnapConnectorToConnector(JoinedConn, NearestVerticalConn); // { SnapPointObjectToConnector(AConnector, JoinedConn, False); SnapPointObjectToConnector(APointObject, JoinedConn, False); } Snap_Type := -1; Result := True; exit; end; finally F_ProjMan.GSCSBase.CurrProject.CurrList.Setting.CADAutoPosTraceBetweenRM := AutoPosBetweenRMFlag; end; end; end; // ЕСЛИ СНАП ПРИШЕЛ С КАДА (передвижение коннектора) //это на всякий... если вдруг как-то получится, что на коннекторе есть поинт -- сразу нах! // нельзя снапнуть объект на объект if AConnector.JoinedConnectorsList.Count > 0 then begin GCadForm.mProtocol.Lines.Add(cCadClasses_Mes11_4); exit; end; try // райз на поинте for i := 0 to APointObject.JoinedConnectorsList.Count - 1 do begin JoinedConn := TConnectorObject(APointObject.JoinedConnectorsList[i]); if Not JoinedConn.Deleted then begin for j := 0 to JoinedConn.JoinedOrthoLinesList.Count - 1 do begin if TOrthoLine(JoinedConn.JoinedOrthoLinesList[j]).FIsRaiseUpDown then begin RaiseLine := TOrthoLine(JoinedConn.JoinedOrthoLinesList[j]); PointHasRaise := True; break; end; end; if PointHasRaise then break; end; end; // райз на коннекторе for i := 0 to AConnector.JoinedOrthoLinesList.Count - 1 do begin if TOrthoLine(AConnector.JoinedOrtholinesList[i]).FIsRaiseUpDown then begin RaiseLine := TOrthoLine(AConnector.JoinedOrtholinesList[i]); ClearConnHasRaise := True; break; end; end; // есть ли вертикали? // на поинте for i := 0 to APointObject.JoinedConnectorsList.Count - 1 do begin if APointObject.JoinedConnectorsList[i] <> nil then begin JoinedConn := TConnectorObject(APointObject.JoinedConnectorsList[i]); if not JoinedConn.Deleted then begin for j := 0 to JoinedConn.JoinedOrtholinesList.Count - 1 do begin if JoinedConn.JoinedOrtholinesList <> nil then begin JoinedLine := TOrthoLine(JoinedConn.JoinedOrtholinesList[j]); if not JoinedLine.deleted then begin if JoinedLine.FIsVertical then begin if VPointLine1 = nil then VPointLine1 := JoinedLine else begin VPointLine2 := JoinedLine; break; // вертикалей может быть всего 2 (одна вниз, другая вверх) end; end; end; end; end; end; end; if VPointLine2 <> nil then break; end; if VPointLine1 <> nil then PointHasVLine := True; for i := 0 to AConnector.JoinedOrtholinesList.Count - 1 do begin if AConnector.JoinedOrtholinesList[i] <> nil then begin JoinedLine := TOrthoLine(AConnector.JoinedOrtholinesList[i]); if not JoinedLine.deleted then if JoinedLine.FIsVertical then begin if VClearConnLine1 = nil then VClearConnLine1 := JoinedLine else begin VClearConnLine2 := JoinedLine; // вертикалей может быть всего 2 (одна вниз, другая вверх) break; end; end; end; if VClearConnLine2 <> nil then break; end; if VClearConnLine1 <> nil then ClearConnHasVLine := True; //если там и там есть райз(или и там и там есть вертикали, или на одном - райз а на втором - вертикаль) -- вообще нельзя соединять if (PointHasRaise and ClearConnHasRaise) or (PointHasVLine and ClearConnHasVLine) or (PointHasRaise and ClearConnHasVLine) or (PointHasVLine and ClearConnHasRaise) then begin GCadForm.mProtocol.Lines.Add(cCadClasses_Mes11_3); GCadForm.PCad.Refresh; // чтобы снять выделение с коннектора, на который наехали, а то так и будет красная рамка до следующего обновления... exit; end; // если разрешены наклоные трассы и на коннекторе нет ни райза ни вертикали -- соединить их на высоте поинта //(коннектор упадет на высоту поинта и присоединится к нему) //21/07/2022 Tolik //if GCadForm.FAutoPosTraceBetweenRM then if GCadForm.FAutoPosTraceBetweenRM and (GPlugSwitch = nil) then // if not ClearConnHasRaise then if not ClearConnHasVLine then begin AConnector.ActualZOrder[1] := APointObject.ActualZOrder[1]; for i := 0 to AConnector.JoinedOrtholinesList.Count - 1 do begin if TOrthoLine(AConnector.JoinedOrtholinesList[i]).JoinConnector1 <> nil then if TOrthoLine(AConnector.JoinedOrtholinesList[i]).JoinConnector1.ID = AConnector.ID then begin TConnectorObject(TOrthoLine(AConnector.JoinedOrtholinesList[i]).JoinConnector1).ActualZOrder[1] := AConnector.ActualZOrder[1]; TOrthoLine(AConnector.JoinedOrtholinesList[i]).ActualZOrder[1] := AConnector.ActualZOrder[1]; end; if TOrthoLine(AConnector.JoinedOrtholinesList[i]).JoinConnector2 <> nil then if TOrthoLine(AConnector.JoinedOrtholinesList[i]).JoinConnector2.ID = AConnector.ID then begin TConnectorObject(TOrthoLine(AConnector.JoinedOrtholinesList[i]).JoinConnector2).ActualZOrder[1] := AConnector.ActualZOrder[1]; TOrthoLine(AConnector.JoinedOrtholinesList[i]).ActualZOrder[2] := AConnector.ActualZOrder[1]; end; end; Result := True; Snap_Type := 1; exit; end; // если нет ни райзов ни вертикалей -- снапаем как есть if RaiseLine = nil then if not PointHasVLine then if not ClearConnHasVLine then begin // если на одной высоте -- как есть if (CompareValue(APointObject.ActualZOrder[1], AConnector.ActualZOrder[1]) = 0) then begin Result := True; Snap_Type := 1; exit; end else // если на разных высотах создаем райз на том объекте, который в данный момент тащим begin if CheckAllowTracesBetweenRM(AConnector) then // если разрешены наклонные трассы, то коннектор, который тащим begin // должен "приклеиться" к коннектору, на который упадем, на той же высоте, if AConnToPoint then // на которую попали begin //AConnector.ActualZOrder[1] := APointObject.ActualZOrder[1]; SetConnHeight(AConnector, APointObject.ActualZOrder[1]); for i := 0 to AConnector.JoinedOrtholinesList.Count - 1 do begin JoinedLine := TOrthoLine(AConnector.JoinedOrtholinesList[i]); JoinedLine.CalculLength := JoinedLine.LengthCalc; JoinedLine.LineLength := JoinedLine.CalculLength; SetLineFigureLengthInPM(JoinedLine.ID, JoinedLine.LineLength); JoinedLine.UpdateLengthTextBox(True, false); JoinedLine.ReCreateDrawFigureBlock; end; { end else begin SetConnHeight(APointObject, AConnector.ActualZOrder[1]); for i := 0 to APointObject.JoinedConnectorsList.Count - 1 do begin JoinedConn := TConnectorObject(APointObject.JoinedConnectorsList); for j := 0 to JoinedConn.JoinedOrtholinesList.Count - 1 do begin JoinedLine := TOrtholine(JoinedConn.JoinedOrtholinesList[j]); JoinedLine := TOrthoLine(AConnector.JoinedOrtholinesList[i]); JoinedLine.CalculLength := JoinedLine.LengthCalc; JoinedLine.LineLength := JoinedLine.CalculLength; SetLineFigureLengthInPM(JoinedLine.ID, JoinedLine.LineLength); JoinedLine.UpdateLengthTextBox(True, false); JoinedLine.ReCreateDrawFigureBlock; end; end;} Result := True; Snap_Type := 1; exit; end; end; if aConnToPoint then // если снапаем коннектор на поинт begin CreateRaiseOnConnector(AConnector, APointObject.ActualZOrder[1]); for i := 0 to AConnector.JoinedOrtholinesList.Count - 1 do begin if TOrthoLine(AConnector.JoinedOrtholinesList[i]).FIsRaiseUpDown then begin RaiseLine := TOrthoLine(AConnector.JoinedOrtholinesList[i]); break; end; end; if RaiseLine <> nil then begin //AConnector.FObjectFromRaise := Nil; { if RaiseLine.JoinConnector1.ID = AConnector.ID then begin TConnectorObject(RaiseLine.JoinConnector2).FObjectFromRaise := AConnector; end else if RaiseLine.JoinConnector2.ID = AConnector.ID then begin TConnectorObject(RaiseLine.JoinConnector1).FObjectFromRaise := AConnector; end; RaiseLine.FObjectFromRaisedLine := AConnector; } if RaiseLine.JoinConnector1.ID = AConnector.ID then SnapConn := TConnectorObject(RaiseLine.JoinConnector2) else if RaiseLine.JoinConnector2.ID = AConnector.ID then SnapConn := TConnectorObject(RaiseLine.JoinConnector1); if SnapConn <> nil then begin Result := True; Snap_Type := 2; //поинт на коннектор райза exit; end; end; end else begin // если снапаем поинт на коннектор CreateRaiseOnPointObjectNew(APointObject, AConnector.ActualZOrder[1]); for i := 0 to APointObject.JoinedConnectorsList.Count - 1 do begin JoinedConn := TConnectorObject(APointObject.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; end; if RaiseLine <> nil then begin if RaiseLine.JoinConnector1.ID = JoinedConn.ID then SnapConn := TConnectorObject(RaiseLine.JoinConnector2) else if RaiseLine.JoinConnector2.ID = JoinedConn.ID then SnapConn := TConnectorObject(RaiseLine.JoinConnector1); if SnapConn <> nil then begin Result := True; Snap_Type := 3; // коннектор райза на коннектор exit; end; exit; // это на всякий случай (если что пойдет не так, чтобы все равно вывалилось из процедуры) end; end; end; end; end; // !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! // сюда дойдем только, если райз/вертикаль (или вертикали) ТОЛЬКО на одном из коннекторов // причем тут должно получиться так: есть райз -- нет вертикали и наоборот, есть вертикаль -- нет райза // если высоты коннекторов совпадают -- можно соединять if CompareValue(APointObject.ActualZorder[1], AConnector.ActualZOrder[1]) = 0 then begin Result := True; Snap_Type := 1; exit; end; // если высоты не совпадают, прикинем расположение коннектора относительно объекта по высоте (выше или ниже) -- потом пригодится ConnIsUP := (CompareValue(AConnector.ActualZOrder[1], APointObject.ActualZOrder[1]) = 1); // ИЩЕМ СОВПАДЕНИЕ ВЫСОТЫ РАСПОЛОЖЕНИЯ ВТОРОЙ ВЕРШИНЫ РАЙЗА И КОННЕКТОРА // если высоты объектов не совпадают if RaiseLine <> nil then begin SnapConn := Nil; // смотрим попадание одного из объектов на вершину райза if PointHasRaise then //если райз на поинте begin if CheckCanSnapLineConnToConn(RaiseLine, APointObject, AConnector) then if SnapConn <> nil then begin Result := True; if SnapConn.ConnectorType = ct_Clear then Snap_Type := 3 // коннектор на коннектор else Snap_Type := 4; // найденный объект на коннектор exit; end; end else // если райз на пустом коннекторе if ClearConnHasRaise then begin if CheckCanSnapLineConnToConn(RaiseLine, AConnector, APointObject) then begin if SnapConn <> nil then begin if SnapConn.ConnectorType = ct_Clear then begin Result := True; Snap_Type := 2; // коннектор райза, что на коннекторе, на объект exit end else // на коннекторе уже есть поинт, соединять нельзя!!! begin Snap_Type := -1; GCadForm.mProtocol.Lines.Add(cCadClasses_Mes11_4); exit; end; end; end; end; if CheckRaiseIsNotBetweenFloorOrMagistral(RaiseLine, CadMess) then // если снап на мжэтажку или магистраль, или нужно их преобразовать в вертикаль - нах отсюда, не снапим begin // проверить, если нужно сделать снап на райз if PointHasRaise then // райз на поинте NeedSnapToLine := CheckSnapConnToVLine(RaiseLine, AConnector) else // райз на пустом коннекторе NeedSnapToLine := CheckSnapConnToVLine(RaiseLine, APointObject); if NeedSnapToLine then// если нужно сделать снап на райз begin if not GUseVerticalTraces then //если запрещено оспользование вертикальных трасс -- сообщение и нах... begin GCadForm.mProtocol.Lines.Add(cCadClasses_Mes11 + cCadClasses_Mes11_1); exit; end else // использование вертикальных трасс разрешено begin ConvertRaiseToVertical(RaiseLine); // преобразовать райз в вертикаль VLineToSnap := RaiseLine; Result := True; if PointHasRaise then Snap_Type := 5 // выставить, чтобы снапнулся коннектор на вертикаль else Snap_Type := 6; // выставить, чтобы снапнулся объект на вертикаль exit; end end; // на райз не попадаем никак, нужно преобразовать райз в вертикаль и строить еще одну вертикаль if not GUseVerticalTraces then //если запрещено оспользование вертикальных трасс -- сообщение и нах... begin GCadForm.mProtocol.Lines.Add(cCadClasses_Mes11 + cCadClasses_Mes11_1); exit; end; ConvertRaiseToVertical(RaiseLine); if PointHasRaise then begin if isRaiseDirectionRight(RaiseLine, APointObject, ConnisUp) then // если райз смотрит в нужном направлении begin JoinedConn := GetConnFromVLineByDirection(ConnisUp, RaiseLine); if JoinedConn.JoinedConnectorsList.Count = 0 then JoinedLine := CreateVerticalOnConnector(JoinedConn, AConnector.ActualZOrder[1]) else begin JoinedConn := TConnectorObject(JoinedConn.JoinedConnectorsList[0]); JoinedLine := CreateVerticalOnPointObject(JoinedConn, AConnector.ActualZOrder[1]); end; end else begin // строим вертикаль в противоположную сторону от райза к коннектору JoinedLine := CreateVerticalOnPointObject(APointObject, AConnector.ActualZOrder[1]); end; SnapConn := GetConnFromVLineByDirection(ConnisUp, JoinedLine); Result := True; Snap_Type := 3; // коннектор на коннектор exit; end else if ClearConnHasRaise then begin if isRaiseDirectionRight(RaiseLine, AConnector, not ConnisUp) then // если райз смотрит в нужном направлении begin JoinedConn := GetConnFromVLineByDirection(not ConnisUp, RaiseLine); if JoinedConn.JoinedConnectorsList.Count = 0 then JoinedLine := CreateVerticalOnConnector(JoinedConn, APointObject.ActualZOrder[1]) else begin JoinedConn := TConnectorObject(JoinedConn.JoinedConnectorsList[0]); JoinedLine := CreateVerticalOnPointObject(JoinedConn, APointObject.ActualZOrder[1]); end; end else begin // строим вертикаль в противоположную сторону от райза к объекту JoinedLine := CreateVerticalOnConnector(AConnector, APointObject.ActualZOrder[1]); SnapConn := GetConnFromVLineByDirection(not ConnisUp, JoinedLine); Result := True; Snap_Type := 2; // объект на коннектор exit; end; end; end else begin // выдать сообщение, что нельзя преобразовывать межэтажку/магистраль в вертикаль и -- нах GCadForm.mProtocol.Lines.Add(CadMess); exit; end; end /////////////////////////////////////////////////////////////////////////////////////////////// ENd RAISE else begin // райза нет, проверяем снапы на вертикали if PointHasVLine then begin if not GUseVerticalTraces then //если запрещено оспользование вертикальных трасс -- сообщение и нах... begin GCadForm.mProtocol.Lines.Add(cCadClasses_Mes11 + cCadClasses_Mes11_1); exit; end; buildVList(APointObject, ConnIsUP); // построить список вертикалей if PassedList.Count = 0 then // нужно строить вертикаль прямо от объекта до коннектора begin JoinedLine := CreateVerticalOnPointObject(aPointObject, AConnector.ActualZOrder[1]); if CompareValue(TConnectorObject(JoinedLine.JoinConnector1).ActualZOrder[1], AConnector.ActualZOrder[1]) = 0 then SnapConn := TConnectorObject(JoinedLine.JoinConnector1) else SnapConn := TConnectorObject(JoinedLine.JoinConnector2); Result := True; Snap_Type := 3; // коннектор на коннектор exit; end else // нужно пройтись по вертикалям и определить, как будем подключаться (строить вертикаль или снапить на коннектор или снапить на вертикаль ) begin SnapConn := Nil; VLineToSnap := nil; for i := 0 to PassedList.Count - 1 do begin JoinedLine := TOrthoLine(PassedList[i]); if CheckSnapConnToVLine(JoinedLine, AConnector) then begin Result := True; VLineToSnap := JoinedLine; Snap_Type := 5; // коннектор на вертикаль exit; end else if CheckCanSnapLineConnToConn(JoinedLine, APointObject, AConnector) then begin if SnapConn <> nil then begin Result := True; if SnapConn.ConnectorType = ct_Clear then Snap_Type := 3 // коннектор на коннектор else Snap_Type := 4; // найденный объект на коннектор exit; end; end; end; // если ничего не нашли -- строим вертикаль от самого верхнего(нижнего) коннектора последней вертикали JoinedLine := TOrthoLine(PassedList[PassedList.Count - 1]); // последняя вертикаль JoinedConn := GetConnFromVLineByDirection(ConnIsUP, JoinedLine); if JoinedConn.JoinedConnectorsList.Count = 0 then // коннектор пустой begin JoinedLine := CreateVerticalOnConnector(JoinedConn, AConnector.ActualZOrder[1]) end else begin JoinedConn := TconnectorObject(JoinedConn.JoinedConnectorsList[0]); JoinedLine := CreateVerticalOnPointObject(JoinedConn, AConnector.ActualZOrder[1]); end; SnapConn := GetConnFromVLineByDirection(ConnIsUP, JoinedLine); Result := True; Snap_Type := 3; // коннектор на коннектор exit; end; end else if ClearConnHasVLine then // если вертикаль есть на пустом коннекторе begin if not GUseVerticalTraces then //если запрещено оспользование вертикальных трасс -- сообщение и нах... begin GCadForm.mProtocol.Lines.Add(cCadClasses_Mes11 + cCadClasses_Mes11_1); exit; end; buildVList(AConnector, not ConnIsUP); if PassedList.Count = 0 then // нужно строить вертикаль прямо от объекта до коннектора begin JoinedLine := CreateVerticalOnConnector(aConnector, APointObject.ActualZOrder[1]); if JoinedLine.JoinConnector1.ID = AConnector.ID then SnapConn := TConnectorObject(JoinedLine.JoinConnector2) else SnapConn := TConnectorObject(JoinedLine.JoinConnector1); Result := True; Snap_Type := 2; // точечный на коннектор вертикали exit; end else // нужно пройтись по вертикалям и определить, как будем подключаться (строить вертикаль или снапить на коннектор или снапить на вертикаль ) begin SnapConn := Nil; VLineToSnap := nil; for i := 0 to PassedList.Count - 1 do begin JoinedLine := TOrthoLine(PassedList[i]); if CheckSnapConnToVLine(JoinedLine, APointObject) then begin Result := True; VLineToSnap := JoinedLine; Snap_Type := 6; // объект на вертикаль exit; end else if CheckCanSnapLineConnToConn(JoinedLine, AConnector, APointObject) then begin if SnapConn <> nil then begin if SnapConn.ConnectorType = ct_Clear then begin Result := True; Snap_Type := 2 // объект на коннектор end else begin //объект на объект нельзя Snap_Type := -1; GCadForm.mProtocol.Lines.Add(cCadClasses_Mes11_4); end; exit; end; end; end; // если ничего не нашли -- строим вертикаль от самого верхнего(нижнего) коннектора последней вертикали JoinedLine := TOrthoLine(PassedList[PassedList.Count - 1]); // последняя вертикаль JoinedConn := GetConnFromVLineByDirection(not ConnIsUP, JoinedLine); if JoinedConn.JoinedConnectorsList.Count = 0 then // коннектор пустой begin JoinedLine := CreateVerticalOnConnector(JoinedConn, APointObject.ActualZOrder[1]) end else begin JoinedConn := TConnectorObject(JoinedConn.JoinedConnectorsList[0]); JoinedLine := CreateVerticalOnPointObject(JoinedConn, AConnector.ActualZOrder[1]); end; SnapConn := GetConnFromVLineByDirection(not ConnisUP, JoinedLine); Result := True; Snap_Type := 2; // объект на коннектор exit; end; end; end; except end; end; begin VLine := Nil; PassedList := TList.Create; // список пройденных трасс (чтобы не пойти назад при поиске) if aConnToPoint then // если снапаем коннектор на поинт -- придвигаем коннектор к поинту и наоборот, begin if ((GConnectTraceOnClickPoint = false) and (GMoveRouteToPointObject = false)) then begin // нет флажков -- выравнивание по-любому будет... if CheckCanMovePointOnSnap(aPointObject, aConnector) then //Tolik 03/08/2021 -- // MoveConnToConn(APointObject, AConnector) MoveConnToConn(APointObject, AConnector, False) else //Tolik 03/08/2021 -- //MoveConnToConn(AConnector, APointObject); MoveConnToConn(AConnector, APointObject, False); // end else begin if GCadForm.PCad.TraceFigure <> nil then begin if GCadForm.PCad.TraceFigure is TOrthoLine then // создание трассы begin if CompareValue(APointObject.ActualZOrder[1], AConnector.ActualZorder[1]) <> 0 then // на разной высоте //Tolik 03/08/2021 -- //MoveConnToConn(AConnector, APointObject) MoveConnToConn(AConnector, APointObject, False) // else begin // на одной высоте if not GConnectTraceOnClickPoint then //Tolik 03/08/2021 -- //MoveConnToConn(AConnector, APointObject); MoveConnToConn(AConnector, APointObject, False); // end; end else begin if GCadForm.PCad.TraceFigure is TConnectorObject then // дроп коннектора ортолинии на объект begin if CompareValue(APointObject.ActualZOrder[1], AConnector.ActualZorder[1]) <> 0 then // на разной высоте begin if GConnectTraceOnClickPoint then begin if CheckCanMovePointOnSnap(aPointObject, aConnector) then begin if GMoveRouteToPointObject then //Tolik 03/08/2021 -- //MoveConnToConn(AConnector, APointObject) MoveConnToConn(AConnector, APointObject, False) // else //Tolik 03/08/2021 -- //MoveConnToConn(APointObject, AConnector); MoveConnToConn(APointObject, AConnector, False); // end else //Tolik 03/08/2021 -- //MoveConnToConn(AConnector, APointObject) MoveConnToConn(AConnector, APointObject, False) // end else // Tolik 03/08/2021 -- //MoveConnToConn(AConnector, APointObject) MoveConnToConn(AConnector, APointObject, False) // end else begin if not GConnectTraceOnClickPoint then //if GMoveRouteToPointObject then //Tolik 03/08/2021 -- //MoveConnToConn(AConnector, APointObject); MoveConnToConn(AConnector, APointObject, False); // end; end; end; end; end; { if CompareValue(APointObject.ActualZOrder[1], aConnector.ActualZOrder[1]) = 0 then begin //на одной высоте if GMoveRouteToPointObject then MoveConnToConn(AConnector, APointObject); end else begin // на разных высотах if GMoveRouteToPointObject then MoveConnToConn(AConnector, APointObject) else begin if CheckCanMovePointOnSnap(aPointObject, aConnector) then MoveConnToConn(APointObject, AConnector) else MoveConnToConn(AConnector, APointObject); end; end; end; } end else //Tolik 03/08/2021 -- //MoveConnToConn(APointObject, AConnector); // если поинт -- на коннектор, придвигаем поинт к коннектору (что вроде бы как и логично...) MoveConnToConn(APointObject, AConnector, False); // если поинт -- на коннектор, придвигаем поинт к коннектору (что вроде бы как и логично...) // BaseBeginUpdate; try Snap_Type := -1; if CanSnapConns then begin if Snap_Type <> -1 then begin Case Snap_Type of 1: begin // как есть //SnapPointObjectToConnector(APointObject, AConnector); SnapPointObjectToConnector(APointObject, AConnector, aConnToPoint); end; 2: begin // на коннектор присоединенного райза/вертикали SnapPointObjectToConnector(APointObject, SnapConn, aConnToPoint); end; 3: begin // пустой коннектор райза/вертикали, что на поинте -- на коннектор //AConnector := SnapConnectorToConnector(SnapConn, AConnector); AConnector := SnapConnectorToConnector(AConnector, SnapConn); end; 4: begin //объект, который сидит на втором конце райза/вертикали, присоединенноко к APointObject -- на текущий коннектор (AConnector) SnapPointObjectToConnector(SnapConn, AConnector); end; 5: begin // коннектор на вертикаль или райз (здесь райз уже преобразован в вертикаль ) SnapConnectorToVertical(AConnector, VLineToSnap, not GCadForm.FAutoPosTraceBetweenRM, true); end; 6: begin // объект на вертикаль или райз (здесь райз уже преобразован в вертикаль ) SnapPointObjectToVertical(APointObject, VLineToSnap); end; end; end; end else begin if aManual then // ручная прокладка трассы begin try AutoPosBetweenRM_Flag := false; AutoPosBetweenRM_Flag := GCadForm.FAutoPosTraceBetweenRM; GCadForm.FAutoPosTraceBetweenRM := True; CheckingSnapPointObjectToConnector(APointObject, AConnector); GCadForm.FAutoPosTraceBetweenRM := AutoPosBetweenRM_Flag; except on E: Exception do GCadForm.FAutoPosTraceBetweenRM := AutoPosBetweenRM_Flag; end; end; end; except on E: Exception do addExceptionToLogEx('U_Common.CheckingSnapPointObjectToConnector', E.Message); end; BaseEndUpdate; PassedList.Free; end; (* procedure CheckingSnapPointObjectToConnector(APointObject, AConnector: TConnectorObject); var LastObjectHeight: double; RaiseConn: TConnectorObject; ObjFromRaise: TConnectorObject; RaiseLine: TOrthoLine; i, j: integer; JoinedLine: TOrthoLine; JoinedConn: TConnectorObject; RaiseType: TConnRaiseType; TracesList: TList; begin // Tolik 07/02/2017 TracesList := nil; // BaseBeginUpdate; try RaiseLine := nil; //#From Oleg# RaiseConn := GetRaiseConn(AConnector); ObjFromRaise := AConnector.FObjectFromRaise; if RaiseConn <> nil then RaiseLine := GetRaiseLine(RaiseConn); // Заглушка if HaveObjectCorkComponent(APointObject.ID) then APointObject.ActualZOrder[1] := AConnector.ActualZOrder[1]; // НЕТ С-П if (AConnector.FConnRaiseType = crt_None) and (RaiseConn = nil) then begin LastObjectHeight := APointObject.ActualZOrder[1]; TracesList := getAllConnectedTraces(APointObject); SnapPointObjectToConnector(APointObject, AConnector); // высоты не совпадают if LastObjectHeight <> APointObject.ActualZOrder[1] then begin CreateRaiseOnPointObject(APointObject, LastObjectHeight); for i := 0 to TracesList.Count - 1 do begin JoinedLine := TOrthoLine(TracesList[i]); RaiseLineOnHeight(JoinedLine, LastObjectHeight, TracesList); end;} end; end else // ЭТО ВЕРШИНА С-П if (AConnector.FConnRaiseType <> crt_None) then begin RaiseType := AConnector.FConnRaiseType; SnapPointObjectToConnector(APointObject, AConnector); ObjFromRaise.FConnRaiseType := crt_None; ObjFromRaise.FObjectFromRaise := nil; AConnector.FConnRaiseType := crt_None; AConnector.FObjectFromRaise := nil; APointObject.FConnRaiseType := RaiseType; APointObject.FObjectFromRaise := ObjFromRaise; if AConnector.LockMove = True then AConnector.LockMove := False; end else // ЭТО ОБЪЕКТ НА КОТОРОМ С-П if RaiseConn <> nil then begin if (APointObject.ActualZOrder[1] = RaiseConn.ActualZOrder[1]) then begin // пересоединить к с-п if RaiseConn.ConnectorType = ct_clear then begin SnapPointObjectToConnector(APointObject, RaiseConn); AConnector.FConnRaiseType := crt_None; AConnector.FObjectFromRaise := nil; RaiseConn.FConnRaiseType := crt_None; RaiseConn.FObjectFromRaise := nil; APointObject.FConnRaiseType := crt_OnFloor; APointObject.FObjectFromRaise := AConnector; end; end else begin AConnector.ActualZOrder[1] := APointObject.ActualZOrder[1]; SnapPointObjectToConnector(APointObject, AConnector); if RaiseConn <> nil then RaiseConn.FObjectFromRaise := APointObject; if RaiseLine <> nil then RaiseLine.FObjectFromRaisedLine := APointObject; end; end; except on E: Exception do addExceptionToLogEx('U_Common.CheckingSnapPointObjectToConnector', E.Message); end; BaseEndUpdate; // Tolik --07/02/2017 -- if TracesList <> nil then FreeAndNil(TracesList); // end; *) // Tolik 04/09/2017 -- Procedure ClearOrthoLinesCrossInfo(aCad: TF_CAD); var i: Integer; begin for i := 0 to aCad.FSCSFigures.Count - 1 do begin if CheckFigureByClassName(TFigure(aCad.FSCSFigures[i]), cTOrthoLine) then begin if TOrthoLine(aCad.FSCSFigures[i]).CrossList.Count > 0 then begin TOrthoLine(aCad.FSCSFigures[i]).CrossList.Clear; end; if not TOrthoLine(aCad.FSCSFigures[i]).FisVertical then if not TOrthoLine(aCad.FSCSFigures[i]).FIsRaiseUpDown then TOrthoLine(aCad.FSCSFigures[i]).ReCreateDrawFigureBlock; end; end; end; // Tolik -- 13/09/2017 -- function CheckForNearPoints(aTrace: TOrthoLine; aPoint: TDoublePoint): Boolean; var i: Integer; begin Result := False; if aTrace.CrossList.Count > 0 then begin for i := 0 to aTrace.CrossList.Count - 1 do begin if PointNear(POrthoLineCrossInfo(aTrace.CrossList[i]).StartPoint, aPoint, 2) then Result := True else if PointNear(POrthoLineCrossInfo(aTrace.CrossList[i]).EndPoint, aPoint, 2) then Result := True; if Result then break; end; end else begin if PointNear(aTrace.JoinConnector1.ap1, aPoint, 2) then Result := True else begin if PointNear(aTrace.JoinConnector2.ap1, aPoint, 2) then Result := True; end; end; end; Procedure AddPointtoLine(aLine, CrossLine: TOrthoLine; aPoint: TDoublePoint; aPointColor: Integer; aIsCrit: byte); var FirstLinePoint: TDoublePoint; dist1, dist2: Double; CrossInfo: POrthoLineCrossInfo; begin dist1 := Sqrt(sqr(aLine.AP1.x) + sqr(aLine.AP1.y)); dist2 := Sqrt(sqr(aLine.AP2.x) + sqr(aLine.AP2.y)); //начальная точка ортолинии if CompareValue(dist1, dist2) = -1 then FirstLinePoint := aLine.AP1 else FirstLinePoint := aLine.AP2; New(CrossInfo); CrossInfo.CrossLineID := CrossLine.ID; CrossInfo.StartPoint.x := aPoint.x; CrossInfo.StartPoint.y := aPoint.y; CrossInfo.StartPoint.z := aPoint.z; CrossInfo.isDrawPoint := True; CrossInfo.isCritical := aIsCrit; if aPointColor = 0 then CrossInfo.DrawColor := aLine.FDrawColor else begin CrossInfo.DrawColor := aPointColor; end; CrossInfo.disttoFirstPoint := SQRT(Sqr(aPoint.x - FirstLinePoint.x) +Sqr(aPoint.y - FirstLinePoint.y)); if aLine.CrossList.Count = 0 then begin aLine.CrossList.Add(CrossInfo); end else begin aLine.CrossList.Add(CrossInfo); end; // Здесь пересечение не рисуем, но точку учитываем, чтобы не прорисовывать над ней УГО // трассы, если есть ложемент, гофра и т.п., чтобы было видно, что здесь будут проблемы с его установкой New(CrossInfo); CrossInfo.CrossLineID := aLine.ID; CrossInfo.StartPoint.x := aPoint.x; CrossInfo.StartPoint.y := aPoint.y; CrossInfo.StartPoint.z := aPoint.z; CrossInfo.isDrawPoint := False; //CrossInfo.DrawColor := aPointColor; dist1 := Sqrt(sqr(CrossLine.AP1.x) + sqr(CrossLine.AP1.y)); dist2 := Sqrt(sqr(CrossLine.AP2.x) + sqr(CrossLine.AP2.y)); //начальная точка ортолинии if CompareValue(dist1, dist2) = -1 then FirstLinePoint := CrossLine.AP1 else FirstLinePoint := CrossLine.AP2; CrossInfo.disttoFirstPoint := SQRT(Sqr(aPoint.x - FirstLinePoint.x) +Sqr(aPoint.y - FirstLinePoint.y)); CrossLine.CrossList.Add(CrossInfo); end; Procedure GetPointStatus(aTrace1, aTrace2: TOrthoLine; aCrossPoint: TDoublePoint; var aPointColor: Integer; var aIsCrit: byte; aZ1, aZ2: Double); var //z1, z2: Double; CrossPointsDist: Double; LineCatalog1, LineCatalog2: TSCSCatalog; Line1Width, Line2Width: Double; i: integer; currCad: TF_Cad; CadList: TSCSCatalog; SCSComponent: TSCSComponent; ComponProp: PProperty; BetweenLineDelta, ComponHeight: Double; FirstLineHasCableChannel, SecondLineHasCableChannel: Boolean; begin BetweenLineDelta := 0.02;// 2 см FirstLineHasCableChannel := False; SecondLineHasCableChannel := False; // высота первой точки пересечения { LineKoeff := (aCrossPoint.x - aTrace1.AP1.x)/(aTrace1.Ap2.x - aTrace1.Ap1.x); z1 := LineKoeff*(aTrace1.ActualZOrder[2] - aTrace1.ActualZOrder[1]) + aTrace1.ActualZOrder[1]; // высота первой точки пересечения LineKoeff := (aCrossPoint.x - aTrace2.AP1.x)/(aTrace2.Ap2.x - aTrace2.Ap1.x); z2 := LineKoeff*(aTrace2.ActualZOrder[2] - aTrace2.ActualZOrder[1]) + aTrace2.ActualZOrder[1]; } if CompareValue(aZ1, aZ2) = 0 then begin aPointColor := 255; aIsCrit := 1; end; CrossPointsDist := ABS(az2 - az1);// расстояние между точками по Z currCad := Nil; // КАД, на котором сидят трассы if aTrace1.Owner <> nil then if TPowerCad(aTrace1.Owner).Owner <> nil then currCad := TF_Cad(TPowerCad(aTrace1.Owner).Owner); if currCad = nil then exit; CadList := Nil; // лист (в ПМ) CadList := F_ProjMan.GSCSBase.CurrProject.GetCatalogFromReferencesBySCSID(currCaD.FCADListID); if CadList = nil then exit; LineCatalog1 := CadList.GetCatalogFromReferencesBySCSID(aTrace1.ID); LineCatalog2 := CadList.GetCatalogFromReferencesBySCSID(aTrace2.ID); if LineCatalog1 = nil then exit; if LineCatalog2 = nil then exit; //если хоть одна трасса пустая - точку добавлять не нужно if LineCatalog1.ComponentReferences.Count = 0 then exit; if LineCatalog2.ComponentReferences.Count = 0 then exit; Line1Width := 0.01; Line2Width := 0.01; for i := 0 to LineCatalog1.ComponentReferences.Count - 1 do begin SCSComponent := TSCSComponent(LineCatalog1.ComponentReferences[i]); if SCSComponent.ComponentType.SysName = ctsnCableChannel then FirstLineHasCableChannel := true; // есть каб канал на трассе ComponProp := SCSComponent.GetPropertyBySysName(pnHeight); // если есть высота каб канала/гофры и т.п. if ComponProp <> nil then begin ComponHeight := UOMToMetre(StrToFloat_My(ComponProp.Value))/2; if CompareValue(Line1Width, ComponHeight) = -1 then Line1Width := ComponHeight; end; // если нет высоты -- смотрим сечения if ComponProp = nil then begin ComponProp := SCSComponent.GetPropertyBySysName(pnOutSection); // внешнее сечение if ComponProp = nil then ComponProp := SCSComponent.GetPropertyBySysName(pnInSection); // внутр сечение if ComponProp <> nil then begin ComponHeight := Sqrt(StrToFloat_My(ComponProp.Value))/200; if CompareValue(Line1Width, ComponHeight) = -1 then Line1Width := ComponHeight; end; end; // если нет сечений -- смотрим диаметры {if ComponProp = nil then begin ComponProp := SCSComponent.GetPropertyBySysName(pnOutDiametr) // внешнее сечение if ComponProp = nil then ComponProp := SCSComponent.GetPropertyBySysName(pnInDiametr) // внутр сечение end; } end; for i := 0 to LineCatalog2.ComponentReferences.Count - 1 do begin SCSComponent := TSCSComponent(LineCatalog2.ComponentReferences[i]); if SCSComponent.ComponentType.SysName = ctsnCableChannel then SecondLineHasCableChannel := true; // есть каб канал на трассе ComponProp := SCSComponent.GetPropertyBySysName(pnHeight); if ComponProp <> nil then begin ComponHeight := UOMToMetre(StrToFloat_My(ComponProp.Value))/2; if CompareValue(Line2Width, ComponHeight) = -1 then Line2Width := ComponHeight; end; // если нет высоты -- смотрим сечения if ComponProp = nil then begin ComponProp := SCSComponent.GetPropertyBySysName(pnOutSection); // внешнее сечение if ComponProp = nil then ComponProp := SCSComponent.GetPropertyBySysName(pnInSection); // внутр сечение if ComponProp <> nil then begin ComponHeight := Sqrt(StrToFloat_My(ComponProp.Value))/200; if CompareValue(Line2Width, ComponHeight) = -1 then Line2Width := ComponHeight; end; end; end; if CompareValue(UOMToMetre(ABS(az1-az2)), (Line1Width + Line2Width)) = -1 then begin if FirstLineHasCableChannel then begin if SecondLineHasCableChannel then begin aPointColor := 255; aIsCrit := 1; end; end else aPointColor := clFuchsia; end else if CompareValue(UOMToMetre(ABS(az1-az2)) - (Line1Width + Line2Width), BetweenLineDelta) = -1 then aPointColor := clFuchsia; // если между трассами end; // Добавить точку пересечения в трассы (в зависимости от того, на которой страссе ) // будем отрисовывать пересечение Procedure AddCrossPointToTraces(aTrace1, aTrace2: TOrthoLine; aCrossPoint: TDoublePoint); var UpLine, DownLine: TOrthoLine; PointColor: Integer; LineKoeff: Double; z1,z2: Double; CanAddPoint: Boolean; isCritPoint: byte; begin if Assigned(aTrace1.JoinConnector1) and Assigned(aTrace1.JoinConnector2) and Assigned(aTrace2.JoinConnector1) and Assigned(aTrace2.JoinConnector2) then if (not aTrace1.JoinConnector1.Deleted) and (not aTrace1.JoinConnector2.deleted) and (not aTrace2.JoinConnector1.Deleted) and (not aTrace2.JoinConnector2.deleted) then begin // высота первой точки пересечения if CompareValue(aTrace1.Ap1.x, aTrace1.Ap2.x) <> 0 then LineKoeff := (aCrossPoint.x - aTrace1.AP1.x)/(aTrace1.ap2.x - aTrace1.AP1.x) else if CompareValue(aTrace1.ap1.y, aTrace1.ap2.y) <> 0 then LineKoeff := (aCrossPoint.y - aTrace1.AP1.y)/(aTrace1.ap2.y - aTrace1.AP1.y); z1 := LineKoeff*(aTrace1.ActualZOrder[2] - aTrace1.ActualZOrder[1]) + aTrace1.ActualZOrder[1]; // высота первой точки пересечения //LineKoeff := (aCrossPoint.x - aTrace2.JoinConnector1.AP1.x)/(aTrace2.Joinconnector2.Ap1.x - aTrace2.JoinConnector1.Ap1.x); if CompareValue(aTrace2.Ap1.x, aTrace2.Ap2.x) <> 0 then LineKoeff := (aCrossPoint.x - aTrace2.AP1.x)/(aTrace2.ap2.x - aTrace2.AP1.x) else if CompareValue(aTrace2.ap1.y, aTrace2.ap2.y) <> 0 then LineKoeff := (aCrossPoint.y - aTrace2.AP1.y)/(aTrace2.ap2.y - aTrace2.AP1.y); z2 := LineKoeff*(aTrace2.ActualZOrder[2] - aTrace2.ActualZOrder[1]) + aTrace2.ActualZOrder[1]; CanAddPoint := False; UpLine := aTrace1; DownLine := aTrace2; aCrossPoint.z := z1; if comparevalue(z1, z2) = -1 then begin UpLine := aTrace2; DownLine := aTrace1; aCrossPoint.z := z2; end; if checkForNearPoints(UpLine, aCrossPoint) then begin if not CheckForNearPoints(DownLine, aCrossPoint) then begin if UpLine = aTrace1 then begin UpLine := aTrace2; DownLine := aTrace1; end else begin UpLine := aTrace1; DownLine := aTrace2; end; CanAddPoint := True; end; end else CanAddPoint := True; if CanAddPoint then // можно добавить точку begin PointColor := UpLine.FDrawColor; // черный - по умолчанию isCritPoint := 0; GetPointStatus(UpLine, DownLine, aCrossPoint, PointColor, isCritPoint, z1,z2); AddPointToLine(UpLine, DownLine, aCrossPoint, PointColor, isCritPoint); end; end; end; Procedure SortCrossList(aLine: TOrthoLine); var CansortList: Boolean; i, CheckIndex: Integer; TempCrossInfo, CrossSortInfo: POrthoLineCrossInfo; StartPoint: TDoublePoint; begin CanSortList := True; StartPoint := aLine.JoinConnector1.AP1; // выбираем конец линии, относительно которого будем выполнять сортировку if CompareValue(Sqrt(sqr(aLine.JoinConnector1.AP1.x)+ sqr(aLine.JoinConnector1.AP1.y)), Sqrt(sqr(aLine.JoinConnector2.AP1.x)+ sqr(aLine.JoinConnector2.AP1.y))) = 1 then StartPoint := aLine.JoinConnector2.AP1; if aLine.CrossList.Count > 1 then begin While CanSortList do begin CanSortList := False; CheckIndex := 0; for i := 1 to aLine.CrossList.Count - 1 do begin if CompareValue(Sqrt(sqr(POrthoLineCrossInfo(aLine.CrossList[i-1]).StartPoint.x - StartPoint.x)+ sqr(POrthoLineCrossInfo(aLine.CrossList[i-1]).StartPoint.y - StartPoint.y)), Sqrt(sqr(POrthoLineCrossInfo(aLine.CrossList[i]).StartPoint.x - StartPoint.x)+ sqr(POrthoLineCrossInfo(aLine.CrossList[i]).StartPoint.y - StartPoint.y))) = 1 then begin CanSortList := True; CrossSortInfo := POrthoLineCrossInfo(aLine.CrossList[i-1]); aLine.CrossList[i-1] := aLine.CrossList[i]; aLine.CrossList[i] := CrossSortInfo; CheckIndex := i; end; end; end; end; end; Procedure ShowTracesIntersections(aCrossType: Integer; aCrossSett: Byte); var LinesCrossPoint: TDoublePoint; i,j: Integer; PointList, LineList, CrossLineList: TList; CurrLine, CrossLine: TOrthoLine; //CrossInfo: POrthoLineCrossInfo; RefreshFlag: Boolean; //CanAddPoint: Boolean; //Z1, Z2: Double; CadForm, oldGCadForm: Tf_Cad; CurListParams: TListParams; begin RefreshFlag := GCanRefreshCad; GCanRefreshCad := False; oldGCadForm := GCadForm; CrossLineList := Nil; try Case aCrossType of 1: // если на проекте begin for i := 0 to F_ProjMan.GSCSBase.CurrProject.ChildCatalogs.Count - 1 do begin GCadForm := GetListByID(F_ProjMan.GSCSBase.CurrProject.ChildCatalogs[i].SCSID); if GCadForm <> nil then begin //if GCadForm.FListSettings.ShowTracesCrossPoints then begin GCadForm.FListSettings.ShowTracesCrossPoints := aCrossSett;//True; // настройка на Каде CurListParams := GetListParams(GCadForm.FCADListID); // !!! теперь - для самого листа, а то не сохранится CurListParams.Settings.ShowTracesCrossPoints := GCadForm.FListSettings.ShowTracesCrossPoints; SaveCADListParams(GCadForm.FCADListID, CurListParams); end; ClearOrthoLinesCrossInfo(GCadForm); LineList := TList.Create; PointList := TList.Create; for j := 0 to GCadForm.FSCSFigures.Count - 1 do // Collect OrthoLines begin if checkFigureByClassName(TFigure(GCadForm.FSCSFigures[j]), cTOrthoLine) then if not TFigure(GCadForm.FSCSFigures[j]).Deleted then if not TorthoLine(TFigure(GCadForm.FSCSFigures[j])).FIsVertical then // исключить вертикали if not TorthoLine(TFigure(GCadForm.FSCSFigures[j])).FIsRaiseUpDown then // исключить райзы if LineList.IndexOf(TFigure(GCadForm.FSCSFigures[j])) = -1 then LineList.Add(TFigure(GCadForm.FSCSFigures[j])); end; if LineList.Count > 1 then begin CrossLineList := TList.Create; //определяем точки пересечения While LineList.Count > 0 do begin CurrLine := TOrthoLine(LineList[0]); LineList.Remove(CurrLine); for j := 0 to LineList.Count - 1 do begin CrossLine := TOrthoLine(LineList[j]); if GetIntersectionPoint(CurrLine.ActualPoints[1], CurrLine.ActualPoints[2], CrossLine.ActualPoints[1], CrossLine.ActualPoints[2], LinesCrossPoint,false) then //если есть точка пересечения begin //ShowMessage('There is Linear Intersection!!!'); AddCrossPointToTraces(CurrLine, CrossLine, LinesCrossPoint); end; end; if CurrLine.CrossList.Count > 1 then SortCrossList(CurrLine); if CurrLine.CrossList.Count > 0 then CurrLine.ReCreateDrawFigureBlock; end; end; LineList.Free; PointList.Free; if CrossLineList <> nil then CrossLineList.Free; { if GCadForm <> CadForm then begin oldGCadForm := GCadForm; GCadForm := CadForm; GCanRefreshCad := True; GCadForm.PCad.Refresh; GCanRefreshCad := False; GCadForm := OldGCadForm; end; } //GCanRefreshCad := RefreshFlag; GCanRefreshCad := True; GCadForm.PCad.Refresh; GCanRefreshCad := False; end; end; GCadform := OldGCadForm; GCanRefreshCad := RefreshFlag; end; 2: // если на листе begin if GCadForm <> nil then begin //if not GCadForm.FListSettings.ShowTracesCrossPoints then begin GCadForm.FListSettings.ShowTracesCrossPoints := aCrossSett;//True; // настройка на Каде CurListParams := GetListParams(GCadForm.FCADListID); // !!! теперь - для самого листа, а то не сохранится CurListParams.Settings.ShowTracesCrossPoints := GCadForm.FListSettings.ShowTracesCrossPoints; SaveCADListParams(GCadForm.FCADListID, CurListParams); end; ClearOrthoLinesCrossInfo(GCadForm); LineList := TList.Create; PointList := TList.Create; for i := 0 to GCadForm.FSCSFigures.Count - 1 do // Collect OrthoLines begin if checkFigureByClassName(TFigure(GCadForm.FSCSFigures[i]), cTOrthoLine) then if not TFigure(GCadForm.FSCSFigures[i]).Deleted then if not TorthoLine(TFigure(GCadForm.FSCSFigures[i])).FIsVertical then // исключить вертикали if not TorthoLine(TFigure(GCadForm.FSCSFigures[i])).FIsRaiseUpDown then // исключить райзы if LineList.IndexOf(TFigure(GCadForm.FSCSFigures[i])) = -1 then LineList.Add(TFigure(GCadForm.FSCSFigures[i])); end; if LineList.Count > 1 then begin CrossLineList := TList.Create; //определяем точки пересечения While LineList.Count > 0 do begin CurrLine := TOrthoLine(LineList[0]); LineList.Remove(CurrLine); for i := 0 to LineList.Count - 1 do begin CrossLine := TOrthoLine(LineList[i]); if GetIntersectionPoint(CurrLine.ActualPoints[1], CurrLine.ActualPoints[2], CrossLine.ActualPoints[1], CrossLine.ActualPoints[2], LinesCrossPoint,false) then //если есть точка пересечения begin //ShowMessage('There is Linear Intersection!!!'); AddCrossPointToTraces(CurrLine, CrossLine, LinesCrossPoint); end; end; if CurrLine.CrossList.Count > 1 then SortCrossList(CurrLine); if CurrLine.CrossList.Count > 0 then CurrLine.ReCreateDrawFigureBlock; end; end; LineList.Free; PointList.Free; end; if CrossLineList <> nil then CrossLineList.Free; end; // На листе (финиш) end; Except on E: Exception do; end; GCanRefreshCad := RefreshFlag; {GCadForm.PCad.Refresh;} end; Procedure DropCalcCrosses(aCheckLine: TOrthoLine; aCheckOtherLines: Boolean); var LinesCrossPoint: TDoublePoint; i,j: Integer; PointList, LineList, CrossLineList: TList; CurrLine, CrossLine: TOrthoLine; CrossInfo: POrthoLineCrossInfo; RefreshFlag: Boolean; //CanAddPoint: Boolean; //LineKoeff: Double; //Z1, Z2: Double; CadForm, oldGCadForm: Tf_Cad; PointDeleted: Boolean; begin RefreshFlag := GCanRefreshCad; GCanRefreshCad := False; try CrossLineList := Nil; if GCadForm <> nil then begin LineList := TList.Create; for i := 0 to GCadForm.FSCSFigures.Count - 1 do // Collect OrthoLines begin if checkFigureByClassName(TFigure(GCadForm.FSCSFigures[i]), cTOrthoLine) then if not TFigure(GCadForm.FSCSFigures[i]).Deleted then if not (TorthoLine(TFigure(GCadForm.FSCSFigures[i])).Id = aCheckLine.ID) then if not TorthoLine(TFigure(GCadForm.FSCSFigures[i])).FIsVertical then // исключить вертикали if not TorthoLine(TFigure(GCadForm.FSCSFigures[i])).FIsRaiseUpDown then // исключить райзы if LineList.IndexOf(TFigure(GCadForm.FSCSFigures[i])) = -1 then LineList.Add(TFigure(GCadForm.FSCSFigures[i])); end; if LineList.Count > 0 then begin // сбросить пересечения с другими трассами if aCheckOtherLines then begin for i := 0 to LineList.Count - 1 do begin CurrLine := TOrthoLine(LineList[i]); PointDeleted := False; if CurrLine.CrossList.Count > 0 then begin for j := CurrLine.CrossList.Count - 1 downto 0 do begin CrossInfo := POrthoLineCrossInfo(CurrLine.CrossList[j]); if CrossInfo.CrossLineID = aCheckLine.ID then begin CurrLine.CrossList.Remove(CrossInfo); //FreeMem(CrossInfo); // память не забываем освобождать Dispose(CrossInfo); // память не забываем освобождать PointDeleted := True; end; end; if PointDeleted then CurrLine.ReCreateDrawFigureBlock; end; end; end; // CrossLineList := TList.Create; CrossLineList.Add(aCheckLine); //определяем точки пересечения for i := 0 to LineList.Count - 1 do begin CrossLine := TOrthoLine(LineList[i]); if GetIntersectionPoint(aCheckLine.ActualPoints[1], aCheckLine.ActualPoints[2], CrossLine.ActualPoints[1], CrossLine.ActualPoints[2], LinesCrossPoint,false) then //если есть точка пересечения -- регистрируем ее begin AddCrossPointToTraces(aCheckLine, CrossLine, LinesCrossPoint); if CrossLineList.IndexOf(CrossLine) = -1 then CrossLineList.Add(CrossLine); end; end; // if aCheckLine.CrossList.Count > 0 then if CrossLineList.IndexOf(aCheckLine) = -1 then CrossLineList.Add(aCheckLine); for i := 0 to CrossLineList.Count - 1 do begin if TOrthoLine(CrossLineList[i]).CrossList.Count > 1 then SortCrossList(TOrthoLine(CrossLineList[i])); // сортанет точки относительно начала линии TOrthoLine(CrossLineList[i]).ReCreateDrawFigureBlock; // отрисовка пересечений end; end; LineList.Free; end; Except on E: Exception do; end; if CrossLineList <> nil then CrossLineList.Free; GCanRefreshCad := RefreshFlag; GCadForm.PCad.Refresh; end; // function AutoDivideLine(ALine: TOrthoLine): TConnectorObject; var Conn1, Conn2: TConnectorObject; JoinConn1, JoinConn2: TConnectorObject; begin Result := nil; Conn1 := TConnectorObject(ALine.JoinConnector1); Conn2 := TConnectorObject(ALine.JoinConnector2); if (Conn1.JoinedConnectorsList.Count > 0) and (Conn2.JoinedConnectorsList.Count > 0) then begin JoinConn1 := TConnectorObject(Conn1.JoinedConnectorsList[0]); JoinConn2 := TConnectorObject(Conn2.JoinedConnectorsList[0]); if (JoinConn1.FHouse <> nil) and (JoinConn2.FHouse <> nil) and (JoinConn1.FHouse = JoinConn2.FHouse) then Result := DivideLineSimple(ALine); end; end; { function DivideLine(ALine: TOrthoLine): TConnectorObject; //var // DivideConn: TConnectorObject; // DividePoints: TDoublePoint; // i: integer; // JoinedLine: TOrthoLine; begin Result := nil; BaseBeginUpdate; BeginDevideLine; //31.01.2011 try // DividePoints.x := (ALine.ActualPoints[1].x + ALine.ActualPoints[2].x) / 2; // DividePoints.y := (ALine.ActualPoints[1].y + ALine.ActualPoints[2].y) / 2; // DivideConn := TConnectorObject.Create(DividePoints.x, DividePoints.y, ALine.ActualZOrder[1], ALine.LayerHandle, mydsNormal, GCadForm.PCad); // DivideConn.ConnectorType := ct_Clear; // GCadForm.PCad.AddCustomFigure (GLN(ALine.LayerHandle), DivideConn, false); // SnapConnectorToOrtholine(DivideConn, ALine); // ALine.CalculLength := ALine.LengthCalc; // ALine.LineLength := ALine.CalculLength; // ALine.UpdateLengthTextBox(false, true); // ALine.ReCreateNotesGroup; // ALine.ReCreateDrawFigureBlock; // RefreshCAD(GCadForm.PCad); // Result := DivideConn; // except // on E: Exception do addExceptionToLogEx('U_Common.DivideLine', E.Message); // end; Result := DivideLineSimple(ALine); EndDevideLine; BaseEndUpdate; end; } //Tolik 06/11/2015 --- старая закомменчена -- смотри выше function DivideLine(ALine: TOrthoLine): TConnectorObject; begin if Assigned(ALine) then begin try TF_Cad(TF_CAD(ALine.Owner).Owner).GisDivideLine := True; // идет разделение линии Result := nil; BaseBeginUpdate; BeginDevideLine; try Result := DivideLineSimple(ALine); Except on E: Exception do addExceptionToLogEx('U_Common.DivideLine', E.Message); end; finally EndDevideLine; BaseEndUpdate; TF_Cad(TF_CAD(ALine.Owner).Owner).GisDivideLine := False; end; end; end; function DivideLineSimple(ALine: TOrthoLine; ADivPt: PDoublePoint): TConnectorObject; var DivideConn: TConnectorObject; DividePoints: TDoublePoint; i: integer; JoinedLine: TOrthoLine; FigureSnap: TFigure; begin Result := nil; try if ADivPt <> nil then DividePoints := ADivPt^ else begin DividePoints.x := (ALine.ActualPoints[1].x + ALine.ActualPoints[2].x) / 2; DividePoints.y := (ALine.ActualPoints[1].y + ALine.ActualPoints[2].y) / 2; end; FigureSnap := GFigureSnap; //Tolik -- 06/08/2021 -- FormatFloat(ffMask, MetreToUOM(AListParams.Settings.HeightCorob)); //DivideConn := TConnectorObject.Create(DividePoints.x, DividePoints.y, ALine.ActualZOrder[1], ALine.LayerHandle, mydsNormal, GCadForm.PCad); DivideConn := TConnectorObject.Create(DividePoints.x, DividePoints.y, StrToFloat_My(FormatFloat(ffMask, MetreToUOM(GCadForm.FListSettings.HeightCorob))), ALine.LayerHandle, mydsNormal, GCadForm.PCad); //выставить высоту коннектора для разделения трассы if ((not aLine.FisRaiseUpDown) and (not aLine.FIsVertical)) then begin //если трасса горизонтальная if (CompareValue(TConnectorObject(aLine.JoinConnector1).ActualZOrder[1], TConnectorObject(aLine.JoinConnector2).ActualZOrder[1]) = 0) then DivideConn.ActualZOrder[1] := TConnectorObject(aLine.JoinConnector1).ActualZOrder[1] else //если трасса наклонная DivideConn.ActualZOrder[1] := GetCoordZ(aLine, DivideConn.ap1.x, DivideConn.ap1.y); end; // DivideConn.ConnectorType := ct_Clear; GCadForm.PCad.AddCustomFigure (GLN(ALine.LayerHandle), DivideConn, false); SnapConnectorToOrtholine(DivideConn, ALine); ALine.CalculLength := ALine.LengthCalc; ALine.LineLength := ALine.CalculLength; ALine.UpdateLengthTextBox(false, true); ALine.ReCreateNotesGroup; ALine.ReCreateDrawFigureBlock; //Tolik 05/11/2015 -- выравниваем надписи, а то для первой линии "уплывает" ALine.Move(0.01, 0.01); ALine.Move(-0.01, -0.01); // RefreshCAD(GCadForm.PCad); Result := DivideConn; GFigureSnap := FigureSnap; //29.07.2013 на SnapConnectorToOrtholine бівает сбрасівается GFigureSnap except on E: Exception do addExceptionToLogEx('U_Common.DivideLineSimple', E.Message); end; end; procedure ReCalcZCoordSnapObjects(AConnector: TConnectorObject); var i, j: integer; JoinedConn: TConnectorObject; JoinedLine: TOrthoLine; // Tolik -- 22/04/2017 -*- JoinedLinesList: TList; function GetJoinedtoConnLinesList(aConn: TConnectorObject): TList; var i :integer; begin Result := TList.Create; for i := 0 to aConn.JoinedOrthoLinesList.Count - 1 do begin if aConn.JoinedOrthoLinesList[i] <> nil then if ((not TOrthoLine(aConn.JoinedOrthoLinesList[i]).deleted) and (Result.IndexOf(TOrthoLine(aConn.JoinedOrthoLinesList[i])) = -1)) then Result.Add(TOrthoLine(aConn.JoinedOrthoLinesList[i])); end; end; // begin //Tolik 22/04/2017 -- if ((AConnector = nil) or AConnector.deleted) then exit; // try // Tolik -- 22/14/2017 -- if AConnector.ConnectorType = ct_Clear then begin JoinedLinesList := GetJoinedtoConnLinesList(AConnector); for i := 0 to JoinedLinesList.Count - 1 do begin JoinedLine := TOrthoLine(JoinedLinesList[i]); if JoinedLine.JoinConnector1 = AConnector then JoinedLine.ActualZOrder[1] := AConnector.ActualZOrder[1]; if JoinedLine.JoinConnector2 = AConnector then JoinedLine.ActualZOrder[2] := AConnector.ActualZOrder[1]; JoinedLine.UpdateLengthTextBox(false, true); end; JoinedLinesList.free; end else // РТ begin for i := 0 to AConnector.JoinedConnectorsList.Count - 1 do begin JoinedConn := TConnectorObject(AConnector.JoinedConnectorsList[i]); if not JoinedConn.deleted then begin JoinedConn.ActualZOrder[1] := AConnector.ActualZOrder[1]; JoinedLinesList := GetJoinedtoConnLinesList(AConnector); for j := 0 to JoinedLinesList.Count - 1 do begin JoinedLine := TOrthoLine(JoinedLinesList[j]); if JoinedLine.JoinConnector1 = AConnector then JoinedLine.ActualZOrder[1] := AConnector.ActualZOrder[1]; if JoinedLine.JoinConnector2 = AConnector then JoinedLine.ActualZOrder[2] := AConnector.ActualZOrder[1]; JoinedLine.UpdateLengthTextBox(false, true); end; JoinedLinesList.free; end; end; end; { // соединитель if AConnector.ConnectorType = ct_Clear then begin for i := 0 to AConnector.JoinedOrtholinesList.Count - 1 do begin JoinedLine := TOrthoLine(AConnector.JoinedOrtholinesList[i]); if JoinedLine.JoinConnector1 = AConnector then JoinedLine.ActualZOrder[1] := AConnector.ActualZOrder[1]; if JoinedLine.JoinConnector2 = AConnector then JoinedLine.ActualZOrder[2] := AConnector.ActualZOrder[1]; JoinedLine.UpdateLengthTextBox(false, true); end; end else // РТ begin for i := 0 to AConnector.JoinedConnectorsList.Count - 1 do begin JoinedConn := TConnectorObject(AConnector.JoinedConnectorsList[i]); // Tolik JoinedConn.ActualZOrder[1] := AConnector.ActualZOrder[1]; // JoinedConn.ActualZOrder[1] := TConnectorObject(AConnector.JoinedConnectorsList[i]).ActualZOrder[1]; for j := 0 to JoinedConn.JoinedOrtholinesList.Count - 1 do begin JoinedLine := TOrthoLine(JoinedConn.JoinedOrtholinesList[j]); if JoinedLine.JoinConnector1 = JoinedConn then JoinedLine.ActualZOrder[1] := JoinedConn.ActualZOrder[1]; if JoinedLine.JoinConnector2 = JoinedConn then JoinedLine.ActualZOrder[2] := JoinedConn.ActualZOrder[1]; JoinedLine.UpdateLengthTextBox(false, true); end; end; end; } except on E: Exception do addExceptionToLogEx('U_Common.ReCalcZCoordSnapObjects', E.Message); end; end; Function OrthoLineDetect(AOrthoLine: TFigure): Boolean; begin //02.11.2011 try Result := False; if CheckFigureByClassName(AOrthoLine, cTOrthoLine) then Result := True; //02.11.2011 except //02.11.2011 Result := False; //02.11.2011 end; end; Function ConnectorDetect(AConnector: TFigure): Boolean; begin try Result := False; if CheckFigureByClassName(AConnector, cTConnectorObject) then Result := True; except Result := False; end; end; function SCSClassDetect(ASCSObject: TFigure): Boolean; begin Result := False; if CheckFigureByClassName(ASCSObject, cTOrthoLine) then Result := True else if CheckFigureByClassName(ASCSObject, cTConnectorObject) then Result := True else if CheckFigureByClassName(ASCSObject, cTTextMod) then Result := True else if CheckFigureByClassName(ASCSObject, cTFigureGrpMod) then Result := True else if CheckFigureByClassName(ASCSObject, cTFigureGrpNotMod) then Result := True else if CheckFigureByClassName(ASCSObject, cTFrame) then Result := True else if CheckFigureByClassName(ASCSObject, cTRichTextMod) then Result := True else if CheckFigureByClassName(ASCSObject, cTCabinet) then Result := True else if CheckFigureByClassName(ASCSObject, cTCabinetExt) then Result := True else if CheckFigureByClassName(ASCSObject, cTCabinetNumber) then Result := True else if CheckFigureByClassName(ASCSObject, cTPlanObject) then Result := True else if CheckFigureByClassName(ASCSObject, cTPlanConnector) then Result := True else if CheckFigureByClassName(ASCSObject, cTPlanTrace) then Result := True; end; // точ. объектов Procedure SetFullnessTypeForConnector(AID_List, AID_Figure: Integer; AFullnessType: TComponInterfacesFullness); var i: integer; vList: TF_CAD; vFigure: TConnectorObject; begin try vList := GetListByID(AID_List); if vList <> nil then begin vFigure := TConnectorObject(GetFigureByID(vList, AID_Figure)); if vFigure <> nil then begin vFigure.FConnFullness := AFullnessType; end else begin vFigure := TConnectorObject(GetFigureByIDInSCSFigureGroups(vList, AID_Figure)); if vFigure <> nil then vFigure.FConnFullness := AFullnessType; end; end; except on E: Exception do addExceptionToLogEx('U_Common.SetFullnessTypeForConnector', E.Message); end; end; // кабелей Procedure SetFullnessTypeForCable(AID_List, AID_Figure: Integer; ASide: Integer; AFullnessType: TComponInterfacesFullness); var i: integer; vList: TF_CAD; vFigure: TOrthoLine; begin try vList := GetListByID(AID_List); if vList <> nil then begin vFigure := TOrthoLine(GetFigureByID(vList, AID_Figure)); if vFigure <> nil then begin if ASide = 1 then vFigure.FCableFullnessSide1 := AFullnessType; if ASide = 2 then vFigure.FCableFullnessSide2 := AFullnessType; end else begin vFigure := TOrthoLine(GetFigureByIDInSCSFigureGroups(vList, AID_Figure)); if vFigure <> nil then begin if ASide = 1 then vFigure.FCableFullnessSide1 := AFullnessType; if ASide = 2 then vFigure.FCableFullnessSide2 := AFullnessType; end; end; end; except on E: Exception do addExceptionToLogEx('U_Common.SetFullnessTypeForCable', E.Message); end; end; Procedure SetClosedTypeForCableChannel(AID_List, AID_Figure: Integer; ASide: Integer; AClosedType: TComponInterfacesFullness); var i: integer; vList: TF_CAD; vFigure: TOrthoLine; begin try vList := GetListByID(AID_List); if vList <> nil then begin vFigure := TOrthoLine(GetFigureByID(vList, AID_Figure)); if vFigure <> nil then begin if ASide = 1 then vFigure.FCableChannelClosedSide1 := AClosedType; if ASide = 2 then vFigure.FCableChannelClosedSide2 := AClosedType; end else begin vFigure := TOrthoLine(GetFigureByIDInSCSFigureGroups(vList, AID_Figure)); if vFigure <> nil then begin if ASide = 1 then vFigure.FCableChannelClosedSide1 := AClosedType; if ASide = 2 then vFigure.FCableChannelClosedSide2 := AClosedType; end; end; end; except on E: Exception do addExceptionToLogEx('U_Common.SetClosedTypeForCableChannel', E.Message); end; end; Procedure SetTraceStyle(AID_List, AID_Figure: Integer; ATraceStyle: TTraceStyle); var i: integer; vLine: TOrthoLine; vList: TF_CAD; begin try vList := GetListByID(AID_List); if vList <> nil then begin vLine := TOrthoLine(GetFigureByID(vList, AID_Figure)); if vLine <> nil then begin vLine.FLineType := ATraceStyle; end else begin vLine := TOrthoLine(GetFigureByIDInSCSFigureGroups(vList, AID_Figure)); if vLine <> nil then vLine.FLineType := ATraceStyle; end; end; except on E: Exception do addExceptionToLogEx('U_Common.SetTraceStyle', E.Message); end; end; // кабельных каналов Procedure SetFullnessTypeForCableChannel(AID_List, AID_Figure: Integer; AFullnessType: TComponInterfacesFullness); var i: integer; vList: TF_CAD; vFigure: TOrthoLine; begin try vList := GetListByID(AID_List); if vList <> nil then begin vFigure := TOrthoLine(GetFigureByID(vList, AID_Figure)); if vFigure <> nil then begin vFigure.FCableChannelFullness := AFullnessType; end else begin vFigure := TOrthoLine(GetFigureByIDInSCSFigureGroups(vList, AID_Figure)); if vFigure <> nil then vFigure.FCableChannelFullness := AFullnessType; end; end; except on E: Exception do addExceptionToLogEx('U_Common.SetFullnessTypeForCableChannel', E.Message); end; end; // РЕЖИМ КЛИКА - СОЗДАВАТЬ ОБЪЕКТ/КОМПЛЕКТУЮЩУЮ procedure CreateOnClickMode(ASnapFigure: TFigure; ALastSCSCompon: TSCSComponent; X, Y: Double); var DropFigure: TFigure; StateType: TCompStateType; ComponID: integer; i, j: integer; JoinedTrace: TOrthoLine; JoinedConn: TConnectorObject; JoinedLine: TOrthoLine; isConnected: Boolean; NBComponent: TSCSComponent; SavedDragX, SavedDragY: Double; ConnComponID: Integer; PortCount: integer; begin if GIsProgress then begin exit; end; //LockWindowUpdate(GCadForm.Handle); DropFigure := nil; NBComponent := nil; StateType := stProjectible; BeginProgress; try // убрать выделеные обьекты со слоя подложки //GCadForm.PCad.DeselectAll(1); // при тпускании компоненты - воссоздать ее на CAD GListNode := Nil; ComponID := 0; ConnComponID := 0; // *UNDO* if GCadForm.FCanSaveForUndo then begin GCadForm.SaveForUndo(uat_None, True, False); GCadForm.FCanSaveForUndo := False; end; NBComponent := F_NormBase.GSCSBase.SCSComponent; // создать фигуру на CAD DropFigure := GetComponentFromNormBase(X, Y, NBComponent, ASnapFigure, StateType); // скопирование компоненту NormBase -> ProjectManager if DropFigure <> nil then begin ComponID := CopyComponentToPrjManager(GListNode, DropFigure.ID, GCadForm.FCADListID, ALastSCSCompon, True, True); // Дропнулся точечный обьект! if CheckFigureByClassName(DropFigure, cTConnectorObject) then begin ConnComponID := ComponID; // положить точечный объект на другой обьект if ASnapFigure <> Nil then begin // на ортолинию if CheckFigureByClassName(ASnapFigure, cTOrthoLine) then begin CheckingSnapPointObjectToOrthoLine(TConnectorObject(DropFigure), TOrthoLine(ASnapFigure)); end // на пустой конектор else if CheckFigureByClassName(ASnapFigure, cTConnectorObject) then begin CheckingSnapPointObjectToConnector(TConnectorObject(DropFigure), TConnectorObject(ASnapFigure)); end; end else begin if (GDropComponent <> nil) and (GDropComponent.IsLine <> 1) and (ASnapFigure = 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); {TODO - may be electrick componenta see code in procedure TF_CAD.PCadSurfaceDragDrop(Sender, Source: TObject; X, Y: Double);} if CheckNeedDrawGuides(PortCount) 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} GCadForm.DrawGuidesOnDrop(X, Y, True) end; end; end; SetConnObjectSelectHightPriority(TConnectorObject(DropFigure)); //#From Oleg# //29.09.2010 end; end else // компонента(ы) (ортолиния!!!) вбрасываеться в трассу! if (DropFigure = Nil) and (ASnapFigure <> nil) then begin if CheckFigureByClassName(ASnapFigure, cTConnectorObject) and (TConnectorObject(ASnapFigure).ConnectorType <> ct_clear) then ComponID := CopyComponentToSCSObject(ASnapFigure.ID, TSCSComponent(ALastSCSCompon).ID, True); if CheckFigureByClassName(ASnapFigure, cTOrthoLine) then begin ComponID := CopyComponentToSCSObject(ASnapFigure.ID, TSCSComponent(ALastSCSCompon).ID, True); AutoConnectOnAppendCable(GCadForm.FCADListID, TOrthoLine(ASnapFigure).ID); end; end; // *UNDO* GCadForm.FCanSaveForUndo := True; // убрать выделение всех выделенных фигур! if GPrevFigureSnap <> nil then begin TConnectorObject(DropFigure).DrawSnapFigures(GPrevFigureSnap, False); for i := 0 to GCadForm.PCad.SelectedCount - 1 do begin if SCSClassDetect(TFigure(GCadForm.PCad.Selection[i])) then if CheckFigureByClassName(TFigure(GCadForm.PCad.Selection[i]), cTOrthoLine) and (TFigure(GCadForm.PCad.Selection[i]).Selected) then TConnectorObject(DropFigure).DrawSnapFigures(TFigure(GCadForm.PCad.Selection[i]), False); end; end; if DropFigure <> nil then DropFigure.Select else if ASnapFigure <> nil then ASnapFigure.Select; ASnapFigure := Nil; GPrevFigureSnap := Nil; RefreshCAD(GCadForm.PCad); GListNode := Nil; GDraggedFigureZOrder := -1; // DestroyShadowObject; except on E: Exception do addExceptionToLogEx('U_Common.CreateOnClickMode', E.Message); end; EndProgress; if ConnComponID <> 0 then AskMarkInCreateObjectOnClick(GCadForm, ConnComponID); //30.06.2010 if (DropFigure = nil) and IsArchComponByIsLine(NBComponent.IsLine) then begin SavedDragX := GCadForm.DragX; SavedDragY := GCadForm.DragY; try GCadForm.DragX := X; GCadForm.DragY := Y; CreateArchObjWizard(GCadForm.FCADListID, NBComponent, GCadForm, nil); finally GCadForm.DragX := SavedDragX; GCadForm.DragY := SavedDragY; end; end; //LockWindowUpdate(0); //Tolik 24/12/2021 -- if DropFigure <> nil then begin if DropFigure is TConnectorObject then begin if ASnapFigure = nil then begin if (GCadForm.cbMagnetToWalls.Down and (not (ssShift in GGlobalShiftState))) then begin CalcShadowPoint(TConnectorObject(DropFigure).Ap1.x, TConnectorObject(DropFigure).AP1.y); if Assigned(GShadowObject) then begin if GShadowMagnetPoint.x <> -100 then begin GShadowObject.ShadowCP.x := GShadowMagnetPoint.x; GShadowObject.ShadowCP.y := GShadowMagnetPoint.y; GShadowObject.Draw(GCadForm.PCad.DEngine, false); end; end; MagnetConnectorToNearestWall(TConnectorObject(DropFigure)); end; end; end; end; // end; procedure AskMarkInCreateObjectOnClick(aCAD: TF_CAD; aComponID: Integer); var SCSList: TSCSList; SCSCompon: TSCSComponent; InputMarkRes: Integer; PrevMark: string; begin SCSList := F_ProjMan.GSCSBase.CurrProject.GetListBySCSID(aCAD.FCADListID); if SCSList <> nil then if SCSList.FNewComponNameMarkAsk then begin if GIsProgress then begin //PauseProgress(true); //Application.ProcessMessages; end; SCSCompon := F_ProjMan.GSCSBase.CurrProject.GetComponentFromReferences(aComponID); if SCSCompon <> nil then begin PrevMark := SCSCompon.NameMark; if SCSList.FNewComponNameMarkSaved = '' then SCSList.FNewComponNameMarkSaved := PrevMark; end; try InputMarkRes := InputMark(ApplicationName, cMain_Mes141, SCSList.FNewComponNameMarkSaved); finally if GIsProgress then ;//PauseProgress(false); end; if InputMarkRes = mrOk then begin if trim(PrevMark) <> trim(SCSList.FNewComponNameMarkSaved) then begin SCSList.FNewComponNameMark := SCSList.FNewComponNameMarkSaved; //SCSCompon := F_ProjMan.GSCSBase.CurrProject.GetComponentFromReferences(aComponID); 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; end; procedure SetIndexToFigure(AID_List, AID_Figure: Integer; AIndex: Integer); var CAD_Figure: TFigure; vList: TF_CAD; begin try vList := GetListByID(AID_List); if vList <> nil then begin CAD_Figure := GetFigureByID(vList, AID_Figure); if CAD_Figure <> nil then begin if CheckFigureByClassName(CAD_Figure, cTConnectorObject) then TConnectorObject(CAD_Figure).FIndex := AIndex else if CheckFigureByClassName(CAD_Figure, cTOrthoLine) then TOrthoLine(CAD_Figure).FIndex := AIndex; end; end; except on E: Exception do addExceptionToLogEx('U_Common.SetIndexToFigure', E.Message); end; end; // Tolik -- 28/06/2016 -- procedure SetShowNameTypeInCAD; var i: integer; CADFigure: TFigure; ObjParams: TObjectParams; SCSCatalog: TSCSCatalog; // 07/11/2018 -- begin try for i := 0 to GCadForm.FSCSFigures.Count - 1 do begin CADFigure := TFigure(GCadForm.FSCSFigures[i]); if CADFigure <> nil then begin if CheckFigureByClassName(CADFigure, cTConnectorObject) then begin // !!!!!!!!!!!!!!!!!! // 07/11/2018 -- Если не проверить каталог, то для пустого коннектора, присоединенного к точечному объекту // каталога в ПМ не найдет и тогда сбросит имя и индекс коннектора !!!!!! SCSCatalog := F_ProjMan.GSCSBase.CurrProject.GetCatalogFromReferencesBySCSID(CADFigure.ID); if Assigned(SCSCatalog) then begin ObjParams := GetFigureParams(CADFigure.ID, SCSCatalog); TConnectorObject(CADFigure).Name := ObjParams.Name; TConnectorObject(CADFigure).FIndex := ObjParams.MarkID; end; end; end; end; except on E: Exception do addExceptionToLogEx('U_Common.SetShowNameTypeInCAD', E.Message); end; end; procedure SetShowNameTypeInCAD(AShowType: TShowType); var i: integer; CADFigure: TFigure; ObjParams: TObjectParams; begin try for i := 0 to GCadForm.PCad.FigureCount - 1 do begin CADFigure := TFigure(GCadForm.PCad.Figures[i]); if CADFigure <> nil then begin if CheckFigureByClassName(CADFigure, cTConnectorObject) then begin ObjParams := GetFigureParams(CADFigure.ID); TConnectorObject(CADFigure).Name := ObjParams.Name; TConnectorObject(CADFigure).FIndex := ObjParams.MarkID; end; end; end; except on E: Exception do addExceptionToLogEx('U_Common.SetShowNameTypeInCAD', E.Message); end; end; // установить подпись к точечному обьекту procedure SetConnCaptionsInCAD(AID_List, AConnID: Integer; ACaption: TStringList); var i: integer; AFigure: TFigure; SavedCadForm: TF_CAD; vList: TF_CAD; FName: string; // Tolik -- 01/12/2015 CaptList: TstringList; j: Integer; // begin try CaptList := nil; vList := GetListByID(AID_List); if vList <> nil then begin SavedCadForm := GCadForm; GCadForm := vList; AFigure := GetFigureByID(vList, AConnID); if AFigure <> nil then begin if CheckFigureByClassName(AFigure, cTConnectorObject) then begin // если выноска не менялась юзером if not TConnectorObject(AFigure).FIsCaptionsChanged then begin if TConnectorObject(AFigure).OutTextCaptions.Count > 0 then FName := TConnectorObject(AFigure).OutTextCaptions[0] else FName := ''; TConnectorObject(AFigure).OutTextCaptions.Clear; TConnectorObject(AFigure).OutTextCaptions.Add(FName); for i := 0 to ACaption.Count - 1 do TConnectorObject(AFigure).OutTextCaptions.Add(ACaption[i]); TConnectorObject(AFigure).ReCreateCaptionsGroup(false, true); end; end else if CheckFigureByClassName(AFigure, cTOrthoLine) then //28.08.2013 - Предусмаотриваем подписи с маркрировкой линейных компонентов begin // Запоминаем длину FName := ''; if TOrthoLine(AFigure).OutTextCaptions.Count > 0 then FName := TOrthoLine(AFigure).OutTextCaptions[0]; // Tolik -- 01/12/2015 -- if TOrthoLine(AFigure).CaptionsGroup <> nil then begin if TOrthoLine(AFigure).CaptionsGroup.InFigures.Count > 1 then begin CaptList := TStringList.Create; for i := 0 to TRichText(TOrthoLine(AFigure).CaptionsGroup.InFigures[1]).re.Lines.Count - 1 do begin CaptList.Add(TRichText(TOrthoLine(AFigure).CaptionsGroup.InFigures[1]).re.Lines[i]); end; end; end; // TOrthoLine(AFigure).OutTextCaptions.Assign(ACaption); // Восстановить длину TOrthoLine(AFigure).OutTextCaptions.Insert(0, FName); //если пустая длина, до все равно добавляем пустую строку, чтобы не накладывался текст на УГО // Tolik if ((CaptList <> nil) and (CaptList.Count > 0)) then // TOrthoLine(AFigure).ReCreateCaptionsGroup(false, true, CaptList) //TOrthoLine(AFigure).ReCreateCaptionsGroup(false, TOrthoLine(AFigure).FCaptionsViewType <> cv_Center, CaptList) // Tolik 30/10/2017 -- //TOrthoLine(AFigure).ReCreateCaptionsGroup(True, TOrthoLine(AFigure).FCaptionsViewType <> cv_Center, CaptList) TOrthoLine(AFigure).ReCreateCaptionsGroup(False, TOrthoLine(AFigure).FCaptionsViewType <> cv_Center, CaptList) // else // для центра возврат на позицию не делаем //TOrthoLine(AFigure).ReCreateCaptionsGroup(false, true); TOrthoLine(AFigure).ReCreateCaptionsGroup(false, TOrthoLine(AFigure).FCaptionsViewType = cv_Center); end; end; GCadForm := SavedCadForm; // Tolik if CaptList <> nil then FreeAndNil(CaptList); // end; except on E: Exception do addExceptionToLogEx('U_Common.SetConnCaptionsInCAD', E.Message); end; end; // установить выноску на точечном объекте procedure SetConnNotesInCAD(AID_List, AConnID: Integer; ANote: TStringList); var i: integer; AFigure: TFigure; vList: TF_CAD; SavedCadForm: TF_CAD; begin try vList := GetListByID(AID_List); if vList <> nil then begin SavedCadForm := GCadForm; GCadForm := vList; AFigure := GetFigureByID(GCadForm, AConnID); if AFigure <> nil then begin if CheckFigureByClassName(AFigure, cTConnectorObject) then begin // если выноска не менялась юзером if not TConnectorObject(AFigure).FIsNotesChanged then begin TConnectorObject(AFigure).OutTextNotes.Clear; for i := 0 to ANote.Count - 1 do TConnectorObject(AFigure).OutTextNotes.Add(ANote[i]); TConnectorObject(AFigure).ReCreateNotesGroup; end; end; end; GCadForm := SavedCadForm; end; except on E: Exception do addExceptionToLogEx('U_Common.SetConnNotesInCAD', E.Message); end; end; // установить выноску на линейном объекте procedure SetLineNotesInCAD(AID_List, ALineID: Integer; ANote: TStringList); var i: integer; Line: TOrthoLine; vList: TF_CAD; SavedCadForm: TF_CAD; begin try vList := GetListByID(AID_List); if vList <> nil then begin SavedCadForm := GCadForm; GCadForm := vList; Line := TOrthoLine(GetFigureByID(GCadForm, ALineID)); if Line <> nil then begin // если выноска не менялась юзером if not Line.FIsNotesChanged then begin Line.OutTextNotes.Clear; for i := 0 to ANote.Count - 1 do Line.OutTextNotes.Add(ANote[i]); Line.ReCreateNotesGroup; end; end; GCadForm := SavedCadForm; end; except on E: Exception do addExceptionToLogEx('U_Common.SetLineNotesInCAD', E.Message); end; end; procedure SetLineCaptionsInCAD(AID_List, ALineID: Integer); var i: integer; Line: TOrthoLine; vList: TF_CAD; SavedCadForm: TF_CAD; PairStr: string; begin try vList := GetListByID(AID_List); if vList <> nil then begin SavedCadForm := GCadForm; GCadForm := vList; if GCadForm.FShowLineCaptionsType = skExternalSCS then begin Line := TOrthoLine(GetFigureByID(GCadForm, ALineID)); if Line <> nil then begin // если подпись не менялась юзером if not Line.FIsCaptionsChanged then begin if Line.OutTextCaptions.Count >= 1 then begin PairStr := GetPairCountFromTrace(GCadForm.FCADListID, Line.ID); Line.OutTextCaptions[0] := PairStr; end; Line.ReCreateCaptionsGroup(True, true); end; end; end; GCadForm := SavedCadForm; end; except on E: Exception do addExceptionToLogEx('U_Common.SetLineCaptionsInCAD', E.Message); end; end; procedure TraceCableChannelBySelectedLines(CableChannelID: Integer; aIsCable: Boolean = False); var i, j, k, lcount: Integer; ComponID: Integer; SelFigure: TFigure; SelLine: TOrthoLine; mess: string; WithRaise: Boolean; JoinConn1, JoinConn2: TConnectorObject; JoinedConn: TConnectorObject; JoinedLine: TOrthoLine; PointObject: TConnectorObject; RaiseLine: TOrthoLine; LinesList, SelList, RaisesList, ListOfLists: TList; vList: TF_CAD; SavedGcadForm: TF_CAD; QExist: Boolean; TraceIDs: TIntList; GetRaiseLine: TOrthoLine; begin BeginProgress; try // Tolik 09/02/2017 -- LinesList := nil; SelList := nil; RaisesList := nil; ListOfLists := nil; // // определить список листов где есть выделенные ListOfLists := TList.Create; for i := 0 to FSCS_Main.MDIChildCount - 1 do begin vList := TF_CAD(FSCS_Main.MDIChildren[i]); if vList.FListType = lt_Normal then begin for j := 0 to vList.PCad.SelectedCount - 1 do if CheckFigureByClassName(TFigure(vList.PCad.Selection[j]), cTOrthoLine) then begin ListOfLists.Add(vList); Break; end; end; end; // *UNDO* if ListOfLists.Count > 0 then begin if GCadForm.FCanSaveForUndo then begin if ListOfLists.Count = 1 then GCadForm.SaveForUndo(uat_None, True, False) else SaveForProjectUndo(ListOfLists, True, False); end; end; // проложить по выделенным по всем листам WithRaise := False; QExist := False; for lcount := 0 to ListOfLists.Count - 1 do begin vList := TF_CAD(ListOfLists[lcount]); SavedGcadForm := GCadForm; GCadForm := vList; if (GCadForm <> nil) and (GCadForm.PCad <> nil) then begin LinesList := TList.Create; SelList := TList.Create; RaisesList := TList.Create; for i := 0 to GCadForm.PCad.SelectedCount - 1 do begin SelFigure := TFigure(GCadForm.PCad.Selection[i]); if SelFigure.Selected then //25.06.2013 - после SelectAll выполняется TF_CAD.PCadSelectionChange, с которого вызывается UnSelectFiguresOnSelectedChange, //где происходит Deselect с-п. Если SelectAll вызван по Crtl-A, то все события успевают выполнится, если вручную был вызов SelectAll, //то PCad.Selection не соответствует действителности if CheckFigureByClassName(SelFigure, cTOrthoLine) then SelList.Add(SelFigure); end; // проверить есть ли с-п через которые можно прокладывать for k := 0 to SelList.Count - 1 do begin SelLine := TOrthoLine(SelList[k]); JoinConn1 := TConnectorObject(SelLine.JoinConnector1); JoinConn2 := TConnectorObject(SelLine.JoinConnector2); // JoinConn1 for i := 0 to JoinConn1.JoinedOrtholinesList.Count - 1 do if TOrthoLine(JoinConn1.JoinedOrtholinesList[i]).FIsRaiseUpDown then if CheckNoFigureInList(TOrthoLine(JoinConn1.JoinedOrtholinesList[i]), RaisesList) and CheckNoFigureInList(TOrthoLine(JoinConn1.JoinedOrtholinesList[i]), SelList) then RaisesList.Add(TOrthoLine(JoinConn1.JoinedOrtholinesList[i])); if JoinConn1.JoinedConnectorsList.Count > 0 then begin PointObject := TConnectorObject(JoinConn1.JoinedConnectorsList[0]); for i := 0 to PointObject.JoinedConnectorsList.Count - 1 do begin JoinedConn := TConnectorObject(PointObject.JoinedConnectorsList[i]); if JoinedConn <> JoinConn1 then begin for j := 0 to JoinedConn.JoinedOrtholinesList.Count - 1 do if TOrthoLine(JoinedConn.JoinedOrtholinesList[j]).FIsRaiseUpDown then if CheckNoFigureInList(TOrthoLine(JoinedConn.JoinedOrtholinesList[j]), RaisesList) and CheckNoFigureInList(TOrthoLine(JoinedConn.JoinedOrtholinesList[j]), SelList) then RaisesList.Add(TOrthoLine(JoinedConn.JoinedOrtholinesList[j])); end; end; end; // JoinConn2 for i := 0 to JoinConn2.JoinedOrtholinesList.Count - 1 do if TOrthoLine(JoinConn2.JoinedOrtholinesList[i]).FIsRaiseUpDown then if CheckNoFigureInList(TOrthoLine(JoinConn2.JoinedOrtholinesList[i]), RaisesList) and CheckNoFigureInList(TOrthoLine(JoinConn2.JoinedOrtholinesList[i]), SelList) then RaisesList.Add(TOrthoLine(JoinConn2.JoinedOrtholinesList[i])); if JoinConn2.JoinedConnectorsList.Count > 0 then begin PointObject := TConnectorObject(JoinConn2.JoinedConnectorsList[0]); for i := 0 to PointObject.JoinedConnectorsList.Count - 1 do begin JoinedConn := TConnectorObject(PointObject.JoinedConnectorsList[i]); if JoinedConn <> JoinConn2 then begin for j := 0 to JoinedConn.JoinedOrtholinesList.Count - 1 do if TOrthoLine(JoinedConn.JoinedOrtholinesList[j]).FIsRaiseUpDown then if CheckNoFigureInList(TOrthoLine(JoinedConn.JoinedOrtholinesList[j]), RaisesList) and CheckNoFigureInList(TOrthoLine(JoinedConn.JoinedOrtholinesList[j]), SelList) then RaisesList.Add(TOrthoLine(JoinedConn.JoinedOrtholinesList[j])); end; end; end; end; // c-п есть! if not QExist then begin if RaisesList.Count > 0 then begin mess := cCommon_Mes20; //if MessageBoxA(FSCS_Main.Handle, PAnsiChar(mess), cCommon_Mes21, MB_YESNO) = IDYes then if MessageBox(FSCS_Main.Handle, PChar(mess), PChar(cBaseCommon45), MB_YESNO) = IDYes then WithRaise := True else WithRaise := False; QExist := True; end; end; // вместе с с-п if WithRaise then begin for i := 0 to SelList.Count - 1 do begin SelLine := TOrthoLine(SelList[i]); LinesList.Add(SelLine); end; for i := 0 to RaisesList.Count - 1 do begin SelLine := TOrthoLine(RaisesList[i]); LinesList.Add(SelLine); end; end else begin for i := 0 to SelList.Count - 1 do begin SelLine := TOrthoLine(SelList[i]); LinesList.Add(SelLine); end; end; for i := 0 to LinesList.Count - 1 do begin ProcessMessagesEx; SelFigure := TFigure(LinesList[i]); ComponID := CopyComponentToSCSObject(SelFigure.ID, CableChannelID); // Tolik 15/03/2018 -- //AutoConnectOnAppendCable(GCadForm.FCADListID, SelFigure.ID); if aIsCable then AutoConnectOnAppendCable(GCadForm.FCADListID, SelFigure.ID, LinesList) else AutoConnectOnAppendCable(GCadForm.FCADListID, SelFigure.ID); // // если это м-э с-п, то найти трассу на другом листе if TOrthoLine(SelFigure).FIsRaiseUpDown then begin GetRaiseLine := GetBetweenFloorRaiseLine(TOrthoLine(SelFigure)); if GetRaiseLine <> nil then begin TraceIDs := TIntList.Create; TraceIDs.Add(TOrthoLine(SelFigure).ID); TraceIDs.Add(GetRaiseLine.ID); ConnectObjectsInPMByWay(TraceIDs, nil, nil, nil); FreeAndNil(TraceIDs); end; end; end; if RaisesList <> nil then FreeAndNil(RaisesList); if SelList <> nil then FreeAndNil(SelList); if LinesList <> nil then FreeAndNil(LinesList); end; GCadForm := SavedGcadForm; end; if ListOfLists <> nil then FreeAndNil(ListOfLists); except on E: Exception do addExceptionToLogEx('U_Common.TraceCableChannelBySelectedLines', E.Message); end; EndProgress; end; function IsSelectedLinesExist: Boolean; var i: integer; begin Result := False; try for i := 0 to GCadForm.PCad.SelectedCount - 1 do begin if CheckFigureByClassName(TFigure(GCadForm.PCad.Selection[i]), cTOrthoLine) then begin Result := True; break; // Tolik 22/11/2021 -- end; end; except on E: Exception do addExceptionToLogEx('U_Common.IsSelectedLinesExist', E.Message); end; end; function IsSelectedFigure(aListID, aFigureID: Integer): Boolean; var Fig: TFigure; begin Result := false; Fig := GetFigureObjectByID(aListID, aFigureID); if Fig <> nil then Result := Fig.Selected; end; function GetCoordXWithSnapToGrid(X: Double): Double; var BaseX: Double; GridStep: Double; begin Result := 0; try GridStep := GCadForm.PCad.GridStep; BaseX := Round(X / GridStep); Result := BaseX * GridStep; except on E: Exception do addExceptionToLogEx('U_Common.GetCoordXWithSnapToGrid', E.Message); end; end; function GetCoordYWithSnapToGrid(Y: Double): Double; var BaseY: Double; GridStep: Double; begin Result := 0; try GridStep := GCadForm.PCad.GridStep; BaseY := Round(Y / GridStep); Result := BaseY * GridStep; except on E: Exception do addExceptionToLogEx('U_Common.GetCoordYWithSnapToGrid', E.Message); end; end; function GetCoordsWithSnapToGrid(X, Y: Double): TDoublePoint; //var // BaseX, BaseY: Double; // GridStep: Double; begin try //01.10.2013 //Result := DoublePoint(0, 0); //GridStep := GCadForm.PCad.GridStep; //BaseX := Round(X / GridStep); //BaseY := Round(Y / GridStep); //Result.x := BaseX * GridStep; //Result.y := BaseY * GridStep; Result := DoublePoint(x, y); GCadForm.PCad.SnapToGrid(Result.x, Result.y); except on E: Exception do addExceptionToLogEx('U_Common.GetCoordsWithSnapToGrid', E.Message); end; end; function IsClickOnFigure: Boolean; var GridStep: Double; begin Result := False; try // нет привязки к сетке if not FSCS_Main.aSnaptoGrid.Checked then begin if (GMouseDownPos.x = GCurrMousePos.x) and (GMouseDownPos.y = GCurrMousePos.y) then Result := True; end else // есть приязка к сетке begin GridStep := GCadForm.PCad.GridStep; if (abs(GMouseDownPos.x - GCurrMousePos.x) < GridStep) and (abs(GMouseDownPos.y - GCurrMousePos.y) < GridStep) then Result := True; end; except on E: Exception do addExceptionToLogEx('U_Common.IsClickOnFigure', E.Message); end; end; procedure SetConnNameInCaptionOnCAD(AConnector: TConnectorObject); var i: integer; CaptionsLHandle: Integer; FullName: String; begin try FullName := AConnector.Name + IntToStr(AConnector.FIndex); if AConnector.OutTextCaptions.Count > 0 then AConnector.OutTextCaptions[0] := FullName else AConnector.OutTextCaptions.Add(FullName); AConnector.ReCreateCaptionsGroup(true, true); except on E: Exception do addExceptionToLogEx('U_Common.SetConnNameInCaptionOnCAD', E.Message); end; end; Procedure AutoTraceCableFromNB(AID_Cable: Integer; ACable: TSCSComponent; aFromDropConnObj: Boolean=false; aShowFirstMsg: Boolean=true; aSaveForUndo: Boolean=true; aNeedShowAutoTraceType: boolean = True; aFromDrop: boolean = False); var i, j, k: integer; ComponID: Integer; IsAnyRTSelected: Boolean; mess: String; aEndPointName: string; TracedList: TList; WasEndPoint: boolean; //02.07.2013 FiguresList: TList; //RackCount: Integer; //BoxCount: Integer; //WACount: Integer; //RackPortCount, BoxPortCount, WAPortCount: Integer; ptrTrFigInfo: PTracingFiguresInfo; ExistsBoxAndRack: Boolean; CurrentWA: TConnectorObject; WAList: TF_CAD; SCSList: TSCSList; SCSObj: TSCSCatalog; SCSCompon: TSCSComponent; //TempInterfaces: TSCSInterfaces; TmpPortCount: Integer; FigureID: integer; SCSComponTmp: TSCSComponent; SCSCatalog: TSCSCatalog; isEndObjectRack: boolean; BoxFigure: TFigure; isEndObjectBox: Boolean; isSnapObjectRack: boolean; isSnapObjectBox: Boolean; resM: integer; // Tolik FiguresListCreated: Boolean; // Tolik 17/05/2022 -- EndPointConnectedCatalog: TSCSCatalog; BeforeCableList, AfterCableList, NoConnectedCableList: TList; // Tolik 17/05/2022 -- PassedList: TList; JoinedLine: TOrthoLine; ListOfEndPoint: TSCSList; CadOfEndPoint: TF_Cad; AllPortCount, Panel48portCount, Panel24portCount, Compon_ID, Parent_ID: Integer; ParentCatalog: TSCSCatalog; ParentNode: TTreeNode; AddedCompon, RackCompon: TSCSComponent; p24List, p48List: TList; TempInterfaces1, TempInterfaces2: TSCSInterfaces; function CheckConnectedComponToEndObject(aCompon: TSCSComponent; aCatalog: TSCSCatalog): Boolean; var i: integer; begin Result := False; for i := 0 to aCompon.JoinedComponents.Count - 1 do begin if aCatalog.ComponentReferences.IndexOf(aCompon.JoinedComponents[i]) <> -1 then begin Result := True; break; end; end; end; // Function CheckAllFiguresConnectedToServer: Boolean; var i, j: integer; currConn: TConnectorObject; TraceList: TList; begin Result := True; if Assigned(TracedList) then begin for i := 0 to TracedList.Count - 1 do begin currConn := TConnectorObject(TracedList[i]); TraceList := GetAllTraceInCAD(currConn, GEndPoint); if TraceList = nil then begin Result := False; exit; end else FreeAndNil(TraceList); end; end; end; // function CheckSnapFigure: boolean; var i: integer; SCSCatalog: TSCSCatalog; SCSList: TSCSList; SCSCompon: TSCSComponent; begin Result := True; if GFigureSnap <> nil then begin if checkFigureByClassName(GFigureSnap, cTConnectorObject) then begin SCSList := F_ProjMan.GSCSBase.CurrProject.GetListByID(TF_CAD(GFigureSnap.Owner.Owner).FCADListID); if SCSList <> nil then begin SCSCatalog := SCSList.GetCatalogFromReferencesBySCSID(GFigureSnap.ID); if SCSCatalog <> nil then begin SCSCompon := SCSCatalog.GetFirstComponent; if SCSCompon <> nil then begin if (SCSCompon.ComponentType.SysName = ctsnCupBoard) then begin TConnectorObject(GFigureSnap).AsEndPoint := True; GFigureSnap.Select; if GCadForm.PCad.Selection.IndexOf(GFigureSnap) = -1 then GCadForm.PCad.Selection.Add(GFigureSnap); GEndPoint := GFigureSnap; Result := False; end; end; end; end; end; end; end; begin ptrTrFigInfo := nil; // Tolik TracedList := Nil; FiguresList := nil; FiguresListCreated := False; // //Tolik 17/05/2022 -- EndPointConnectedCatalog := nil; BeforeCableList := nil; AfterCableList := nil; NoConnectedCableList := nil; PassedList := nil; p24List := TList.Create; p48List := TList.Create; // try try WasEndPoint := True; if GEndPoint = nil then begin // КО ВЫБРАТЬ WasEndPoint := False; F_EndPoints.Execute; end; if GEndPoint <> nil then begin TracedList := TList.Create; // перегнать выделенные объекты в лист for i := 0 to GCadForm.PCad.SelectedCount - 1 do begin TracedList.Add(TFigure(GCadForm.PCad.Selection[i])); end; // проверить можно ли трассировать по выбранным или только во всем IsAnyRTSelected := False; for i := 0 to GCadForm.PCad.SelectedCount - 1 do begin If CheckFigureByClassName(TFigure(GCadForm.PCad.Selection[i]), cTConnectorObject) then If TConnectorObject(GCadForm.PCad.Selection[i]).ConnectorType <> ct_Clear then if TConnectorObject(GCadForm.PCad.Selection[i]) <> GEndPoint then begin IsAnyRTSelected := True; break; end; end; if IsAnyRTSelected or GAfterAutoCr then begin if (not GRackToRack) then //Tolik 17/08/2021 -- begin if (aNeedShowAutoTraceType) and not GAfterAutoCr then begin //Tolik 27/09/2021 - - //if GIsProgress then // PauseProgress(True); // if CheckAllFiguresConnectedToServer then //Tolik 15/09/2021 -- begin try resM := F_AutoTraceType.ShowModal; finally //if GIsProgress then // PauseProgress(False); end; if resM = mrOK then begin if F_AutoTraceType.rbTraceBySelected.Checked then GCadForm.FAutoTraceBySelected := True; if F_AutoTraceType.rbTraceByAll.Checked then GCadForm.FAutoTraceBySelected := False; end else // Tolik -- 09/02/2017 -- // Exit; begin if TracedList <> Nil then FreeAndNil(TracedList); Exit; end; // end //Tolik 15/09/2021 -- else begin GEndPointSelected := True; try if GEndPoint <> nil then begin GEndPoint.Select; if GCadForm.Pcad.Selection.IndexOf(GEndPoint) = -1 then GCadForm.Pcad.Selection.Add(GEndPoint); end; //Tolik 26/01/2022 //AutoCreateTracesMaster(GEndPoint); //29.06.2013 AutoCreateTraces; AutoCreateTracesMaster(GEndPoint, true, ACable.ComponentType.SysName = ctsnOFCable); // finally GEndPointSelected := False; end; if TracedList <> Nil then FreeAndNil(TracedList); exit; end; // end else GCadForm.FAutoTraceBySelected := True; end else GCadForm.FAutoTraceBySelected := True; end else begin if aShowFirstMsg then begin aEndPointName := GetFigureFirstComponentName(GEndPoint.ID); mess := cMain_Mes34 + aEndPointName + #13#10 + #13#10 + cMain_Mes35; //if MessageBoxA(FSCS_Main.Handle, PAnsiChar(mess), cMain_Mes36, MB_OK) = IDOk then if MessageBox(FSCS_Main.Handle, PChar(mess), PChar(cMain_Mes36), MB_OK) = IDOk then GCadForm.FAutoTraceBySelected := False else Exit; end else GCadForm.FAutoTraceBySelected := False end; //02.07.2013 - список с обїектами для трассировки FiguresList := nil; if not GCadForm.FAutoTraceBySelected then // Tolik 27/10/2016-- нех по всем фигурам лазить, если подложка с кучей объектов - будет сильно долго // берем только объекты СКС // FiguresList := GCadForm.PCad.Figures begin FiguresList := TList.Create; for i := 0 to GCadForm.FSCSFigures.Count - 1 do FiguresList.Add(TFigure(GCadForm.FSCSFigures[i])); FiguresListCreated := True; end // else // Tolik 09/02/2017 -- // FiguresList := TracedList; begin FiguresList := TList.Create; FiguresList.Assign(TracedList, laCopy); // FiguresListCreated := True; end; // Tolik 15/09/2021 -- for i := FiguresList.Count - 1 downto 0 do begin if not CheckFigureByClassName(TFigure(FiguresList[i]), cTConnectorObject) then FiguresList.delete(i) else begin if TConnectorObject(FiguresList[i]).ConnectorType = ct_Clear then FiguresList.Delete(i); end; end; // Tolik 12/07/2023 if (GisDrop and (GFigureSnap <> nil)) then begin for i := FiguresList.Count - 1 downto 0 do begin if TFigure(FiguresList[i]) is TConnectorObject then begin if TConnectorObject(FiguresList[i]).ConnectorType <> ct_Clear then begin if (TFigure(FiguresList[i]).ID <> GEndPoint.ID) and (TFigure(FiguresList[i]).ID <> GFigureSnap.ID) then FiguresList.Delete(i); end; end; end; end; // // //02.07.2013 - ОПРЕДЕЛЯЕМ НАЛИЧИЕ ШКАФА И БОКСА СРЕДИ ТРАССИРУЕМЫХ ОБЪЕКТОВ ExistsBoxAndRack := false; //RackCount := 0; //BoxCount := 0; //WACount := 0; //RackPortCount := 0; //BoxPortCount := 0; //WAPortCount := 0; BoxFigure := nil; if aFromDropConnObj then begin GetZeroMem(ptrTrFigInfo, SizeOf(TTracingFiguresInfo)); for i := 0 to FiguresList.Count - 1 do begin if CheckFigureByClassName(TFigure(FiguresList[i]), cTConnectorObject) then begin CurrentWA := TConnectorObject(FiguresList[i]); if CurrentWA <> nil then begin WAList := TF_CAD(TPowerCad(CurrentWA.Owner).Owner); SCSList := F_ProjMan.GSCSBase.CurrProject.GetListBySCSID(WAList.FCADListID); if SCSList <> nil then begin SCSObj := SCSList.GetCatalogFromReferencesBySCSID(CurrentWA.ID); if SCSObj <> nil then begin for j := 0 to SCSObj.SCSComponents.Count - 1 do begin SCSCompon := SCSObj.SCSComponents[j]; //TempInterfaces := SCSCompon.GetInterfacesByIsPort(biTrue, true, biFalse); TmpPortCount := GetPortsCountReadyToConnectByInterf(SCSCompon, 0, true); if SCSCompon.ComponentType.SysName = ctsnCupboard then begin Inc(ptrTrFigInfo^.RackCount); ptrTrFigInfo^.RackPortCount := ptrTrFigInfo^.RackPortCount + TmpPortCount; //TempInterfaces.Count; end else if SCSCompon.ComponentType.SysName = ctsnBox then begin BoxFigure := CurrentWA; Inc(ptrTrFigInfo^.BoxCount); ptrTrFigInfo^.BoxPortCount := ptrTrFigInfo^.BoxPortCount + TmpPortCount; //TempInterfaces.Count; end else if (SCSCompon.ComponentType.SysName = ctsnWorkPlace) or (SCSCompon.ComponentType.SysName = ctsnSocket) or (SCSCompon.ComponentType.SysName = ctsnModule) then begin Inc(ptrTrFigInfo^.WACount); ptrTrFigInfo^.WAPortCount := ptrTrFigInfo^.WAPortCount + TmpPortCount; //TempInterfaces.Count; end; //FreeAndNil(TempInterfaces); end; end; end; end; end; end; ExistsBoxAndRack := (ptrTrFigInfo^.RackCount > 0) and (ptrTrFigInfo^.BoxCount > 0); end; if aNeedShowAutoTraceType then // Tolik 17/11/2021 -- begin //*** Выбрать порядок подключения панелей с портами if Not ChoiceAutoTraceConnectOrder(nil, true, ACable, aFromDropConnObj, ptrTrFigInfo) then //07.02.2011 if Not ChoiceAutoTraceConnectOrder then // Tolik --27/10/2016-- begin {if FiguresListCreated then FreeAndNil(FiguresList);} if FiguresList <> nil then FreeAndNil(FiguresList); if TracedList <> nil then FreeAndNil(TracedList); // Exit; ///// EXIT ///// end; end; if ExistsBoxAndRack then begin if GEndPoint = GFigureSnap then // дропнули на КО и КО не бокс - переключить КО на бокс. begin isEndObjectBox := False; if GEndPoint <> nil then begin FigureID := TConnectorObject(GEndPoint).ID; SCSCatalog := F_ProjMan.GSCSBase.CurrProject.GetListBySCSID(TF_CAD(GEndPoint.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 = ctsnBox then begin isEndObjectBox := true; break; end end; end; end; if Not isEndObjectBox then begin //ExistsBoxAndRack := False; FSCS_Main.SetFigureAsEndObject(GCadForm, TConnectorObject(BoxFigure)); end; end else // дроп не на КО - проверим что КО и на что дропнули // если КО - шкаф и дроп на шкаф (соединяем два шкафа) - сделать ExistsBoxAndRack := False; // если КО - бокс, и дроп на шкаф - оставим пока как есть // если КО - шкаф и дроп не на бокс - сделать ExistsBoxAndRack := False; и очистить список добавить в него только снапобжект // если КО - шкаф и дроп на бокс - сделать бокс КО; // если КО не бокс и не шкаф - оставим пока как есть тоже begin isEndObjectRack := False; isEndObjectBox := False; isSnapObjectRack := False; isSnapObjectBox := False; if GEndPoint <> nil then begin FigureID := TConnectorObject(GEndPoint).ID; SCSCatalog := F_ProjMan.GSCSBase.CurrProject.GetListBySCSID(TF_CAD(GEndPoint.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 isEndObjectRack := true; break; end; if SCSCatalog.SCSComponents[k].ComponentType.SysName = ctsnBox then begin isEndObjectBox := true; break; end; end; end; end; if 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 isSnapObjectRack := true; break; end; if SCSCatalog.SCSComponents[k].ComponentType.SysName = ctsnBox then begin isSnapObjectBox := true; break; end; end; end; end; if isEndObjectRack and isSnapObjectRack then begin ExistsBoxAndRack := False; //FSCS_Main.SetFigureAsEndObject(GCadForm, TConnectorObject(BoxFigure)); end else if isEndObjectRack and Not isSnapObjectBox then begin // Tolik {if FiguresListCreated then begin FreeAndNil(FiguresList); FiguresListCreated := False; end;} // ExistsBoxAndRack := False; // // Tolik -- 09/02/2017 -- //FiguresList := TracedList; if FiguresList = nil then FiguresList := TList.Create; // FiguresList.Clear; FiguresList.Add(GFigureSnap); //FSCS_Main.SetFigureAsEndObject(GCadForm, TConnectorObject(BoxFigure)); end else if isEndObjectRack and isSnapObjectBox then begin //ExistsBoxAndRack := False; FSCS_Main.SetFigureAsEndObject(GCadForm, TConnectorObject(BoxFigure)); end else ExistsBoxAndRack := True; end; end; BeginProgress; try GAutoTraceCount := 0; //Tolik 17/05/2022 -- определить кабели на трассах к шкафу до выполнения очередной автотрассировки кабеля if GEndPoint <> nil then begin ListOfEndPoint := nil; if GEndPoint.Owner <> nil then if GEndPoint is TConnectorObject then if TConnectorObject(GEndPoint).ConnectorType <> ct_clear then if GEndPoint.Owner.Owner <> nil then ListOfEndPoint := F_ProjMan.GSCSBase.CurrProject.GetListBySCSID(TF_CAD(GEndPoint.Owner.Owner).FCADListID); if ListOfEndPoint <> nil then begin PassedList := TList.Create; BeforeCableList := TList.Create; EndPointConnectedCatalog := ListOfEndPoint.GetCatalogFromReferencesBySCSID(GEndPoint.ID); if EndPointConnectedCatalog <> nil then begin for I := 0 to TConnectorObject(GEndPoint).JoinedConnectorsList.Count - 1 do begin for j := 0 to TConnectorObject(TConnectorObject(GEndPoint).JoinedConnectorsList[i]).JoinedOrtholinesList.Count - 1 do begin JoinedLine := TOrthoLine(TConnectorObject(TConnectorObject(GEndPoint).JoinedConnectorsList[i]).JoinedOrtholinesList[j]); if not JoinedLine.deleted then begin if PassedList.IndexOf(JoinedLine) = -1 then begin PassedList.Add(JoinedLine); for k := 0 to EndPointConnectedCatalog.ComponentReferences.Count - 1 do begin if IsCableComponent(EndPointConnectedCatalog.ComponentReferences[k]) then BeforeCableList.Add(EndPointConnectedCatalog.ComponentReferences[k]); end; end; end; end; end; end; PassedList.Free; end; end; DoAutoTraceCycle(FiguresList, AID_Cable, ExistsBoxAndRack, aSaveForUndo); finally EndProgress; end; //Tolik 17/05/2022 -- определить неподключенные к шкафу кабели // отобрать новые (проложенные) кабели ... //Tolik 26/03/2024 -- //if aCable.IDNetType = 1 then // Tolik 10/07/2023 -- ограничить только для комп сетей if ((aCable.IDNetType = 1) and (GAutoAddNetworkEquipment = true)) then // Tolik 10/07/2023 -- ограничить только для комп сетей) then // Tolik 10/07/2023 -- ограничить только для комп сетей(но согласно опции в настройках) // begin if (GEndPoint is TConnectorObject) and (TConnectorObject(GEndPoint).ConnectorType <> ct_clear) then begin PassedList := TList.Create; AfterCableList := TList.Create; EndPointConnectedCatalog := ListOfEndPoint.GetCatalogFromReferencesBySCSID(JoinedLine.ID); if EndPointConnectedCatalog <> nil then begin for I := 0 to TConnectorObject(GEndPoint).JoinedConnectorsList.Count - 1 do begin for j := 0 to TConnectorObject(TConnectorObject(GEndPoint).JoinedConnectorsList[i]).JoinedOrtholinesList.Count - 1 do begin JoinedLine := TOrthoLine(TConnectorObject(TConnectorObject(GEndPoint).JoinedConnectorsList[i]).JoinedOrtholinesList[j]); if not JoinedLine.deleted then begin if PassedList.IndexOf(JoinedLine) = -1 then begin PassedList.Add(JoinedLine); for k := 0 to EndPointConnectedCatalog.ComponentReferences.Count - 1 do begin if IsCableComponent(EndPointConnectedCatalog.ComponentReferences[k]) then begin if BeforeCableList.IndexOf(EndPointConnectedCatalog.ComponentReferences[k]) = -1 then AfterCableList.Add(EndPointConnectedCatalog.ComponentReferences[k]); end; end; end; end; end; end; end; PassedList.Free; //проверка соединений кабелей к шкафу ... EndPointConnectedCatalog := ListOfEndPoint.GetCatalogFromReferencesBySCSID(GEndPoint.ID); if EndPointConnectedCatalog <> nil then begin if AfterCableList.Count > 0 then begin for I := AfterCableList.Count - 1 downto 0 do begin if CheckConnectedComponToEndObject(TSCSComponent(AfterCableList[i]), EndPointConnectedCatalog) then AfterCableList.Delete(i); end; end; //если есть неподключенные - попытаться установить патч-панели и подключить кабели к ним... if AfterCableList.Count > 0 then begin try GisAutoRotingCable := true; //расчет количества патч-панелей для доп установки в шкаф AllPortCount := AfterCableList.Count; Panel48portCount := 0; Panel24portCount := 0; if AllPortCount >= 48 then begin Panel48portCount := AllPortCount div 48; AllPortCount := AllPortCount mod 48; if AllPortCount > 24 then inc(Panel48portCount) else inc(Panel24portCount); end else begin if AllPortCount > 24 then inc(Panel48portCount) else inc(Panel24portCount); end; //установка EndPointConnectedCatalog := ListOfEndPoint.GetCatalogFromReferencesBySCSID(GEndPoint.ID); if EndPointConnectedCatalog <> nil then begin RackCompon := EndPointConnectedCatalog.GetFirstComponent; if Panel48portCount > 0 then begin {$IF DEFINED (SCS_PE)} //ENG Compon_ID := F_NormBase.DM.GetIntFromTable(tnComponent, fnID, fnGUID, '{BDCC25AF-8BC8-44A5-82B7-EFF7C0563D2C}', qmPhisical); {$ELSEIF DEFINED(SCS_UKR)} // UKR Compon_ID := F_NormBase.DM.GetIntFromTable(tnComponent, fnID, fnGUID, '{DD832593-E27F-4F8A-9786-D140249A6C38}', qmPhisical); {$ELSE} // UKR/RUS Compon_ID := F_NormBase.DM.GetIntFromTable(tnComponent, fnID, fnGUID, '{E764F7B3-A82A-47B6-9A9D-D3B9234B0125}', qmPhisical); {$IFEND} if Compon_ID <> -1 then begin Parent_ID := F_NormBase.DM.GetComponCatalogOwnerID(Compon_ID); if Parent_ID <> -1 then begin //SCSCompon := F_Normbase.GSCSBase.SCSComponent; SCSCompon := TSCSComponent.Create(F_NormBase); SCSCompon.ID := Compon_ID; SCSCompon.LoadComponentByFi([fiIsLine, fiIDProducer, fiIDNetType, fiIDNormBase, fiObjectID]); for i := 1 to Panel48portCount do begin {$IF DEFINED (SCS_PE)} //ENG Compon_ID := F_NormBase.DM.GetIntFromTable(tnComponent, fnID, fnGUID, '{A0D88BE1-5F2D-491E-B114-5DFAA0EACAE2}', qmPhisical); {$ELSEIF DEFINED(SCS_UKR)} // UKR Compon_ID := F_NormBase.DM.GetIntFromTable(tnComponent, fnID, fnGUID, '{92DF72C5-35F4-4E08-AA7A-2F5EE0D8D2B3}', qmPhisical); {$ELSE} // UKR/RUS Compon_ID := F_NormBase.DM.GetIntFromTable(tnComponent, fnID, fnGUID, '{E9B04BB4-96E6-404A-944C-5A99AEBE7F27}', qmPhisical); {$IFEND} if Compon_ID <> -1 then begin // Parent_ID := F_NormBase.DM.GetComponCatalogOwnerID(Compon_ID); // if Parent_ID <> -1 then //* begin //SCSCompon := F_Normbase.GSCSBase.SCSComponent; //SCSCompon := TSCSComponent.Create(F_NormBase); SCSCompon.ID := Compon_ID; SCSCompon.isLine := biFalse; SCSCompon.IDNetType := 1; //SCSCompon.LoadComponentByFi([fiIsLine, fiIDProducer, fiIDNetType, fiIDNormBase, fiObjectID]); //SCSCompon.LoadComponentByFi([fiID, fiIDNetType]); SCSCompon.LoadComponentByFi([fiAll]); Compon_ID := CopyComponentToSCSObject(GEndPoint.ID, Compon_ID, True); AddedCompon := EndPointConnectedCatalog.GetComponentFromReferences(Compon_Id); if RackCompon <> nil then begin if RackCompon.TreeViewNode <> nil then begin if AddedCompon <> nil then begin AddedCompon.DisJoinFromAll(false).Free; if AddedCompon.TreeViewNode <> nil then F_ProjMan.MoveDir(AddedCompon.TreeViewNode, RackCompon.TreeViewNode); end; end; end; //ComplectNBComponToProjObj(GEndPoint.ID, SCSCompon, True); { F_NormBase.CopyComponentFromNbToPm(F_NormBase, F_ProjMan, ParentNode, EndPointConnectedCatalog.TreeViewNode, Compon_ID, ckCompon, false); } end; {$IF DEFINED (SCS_PE)} //ENG Compon_ID := F_NormBase.DM.GetIntFromTable(tnComponent, fnID, fnGUID, '{6C8DCA87-B1D3-4843-A5C6-079C32EBA5B7}', qmPhisical); {$ELSEIF DEFINED(SCS_UKR)} // UKR Compon_ID := F_NormBase.DM.GetIntFromTable(tnComponent, fnID, fnGUID, '{24E60E82-C445-4D7B-AF30-1ABCC2BFF00C}', qmPhisical); {$ELSE} // UKR/RUS Compon_ID := F_NormBase.DM.GetIntFromTable(tnComponent, fnID, fnGUID, '{24E60E82-C445-4D7B-AF30-1ABCC2BFF00C}', qmPhisical); {$IFEND} if Compon_ID <> -1 then begin // Parent_ID := F_NormBase.DM.GetComponCatalogOwnerID(Compon_ID); // if Parent_ID <> -1 then //* begin //SCSCompon := F_Normbase.GSCSBase.SCSComponent; //SCSCompon := TSCSComponent.Create(F_NormBase); SCSCompon.ID := Compon_ID; SCSCompon.isLine := biFalse; SCSCompon.IDNetType := 1; //SCSCompon.LoadComponentByFi([fiIsLine, fiIDProducer, fiIDNetType, fiIDNormBase, fiObjectID]); //SCSCompon.LoadComponentByFi([fiID, fiIDNetType]); SCSCompon.LoadComponentByFi([fiAll]); //ComplectNBComponToProjObj(GEndPoint.ID, SCSCompon, True); Compon_ID := CopyComponentToSCSObject(GEndPoint.ID, Compon_ID, True); { F_NormBase.CopyComponentFromNbToPm(F_NormBase, F_ProjMan, ParentNode, EndPointConnectedCatalog.TreeViewNode, Compon_ID, ckCompon, false); } AddedCompon := EndPointConnectedCatalog.GetComponentFromReferences(Compon_Id); if RackCompon <> nil then begin if RackCompon.TreeViewNode <> nil then begin if AddedCompon <> nil then begin if AddedCompon.TreeViewNode <> nil then F_ProjMan.MoveDir(AddedCompon.TreeViewNode, RackCompon.TreeViewNode); end; end; end; end; {$IF DEFINED (SCS_PE)} //ENG Compon_ID := F_NormBase.DM.GetIntFromTable(tnComponent, fnID, fnGUID, '{BDCC25AF-8BC8-44A5-82B7-EFF7C0563D2C}', qmPhisical); {$ELSEIF DEFINED(SCS_UKR)} // UKR Compon_ID := F_NormBase.DM.GetIntFromTable(tnComponent, fnID, fnGUID, '{DD832593-E27F-4F8A-9786-D140249A6C38}', qmPhisical); {$ELSE} // UKR/RUS Compon_ID := F_NormBase.DM.GetIntFromTable(tnComponent, fnID, fnGUID, '{E764F7B3-A82A-47B6-9A9D-D3B9234B0125}', qmPhisical); {$IFEND} if Compon_ID <> -1 then begin // Parent_ID := F_NormBase.DM.GetComponCatalogOwnerID(Compon_ID); // if Parent_ID <> -1 then //* begin //SCSCompon := F_Normbase.GSCSBase.SCSComponent; //SCSCompon := TSCSComponent.Create(F_NormBase); SCSCompon.ID := Compon_ID; SCSCompon.isLine := biFalse; SCSCompon.IDNetType := 1; //SCSCompon.LoadComponentByFi([fiIsLine, fiIDProducer, fiIDNetType, fiIDNormBase, fiObjectID]); //SCSCompon.LoadComponentByFi([fiID, fiIDNetType]); SCSCompon.LoadComponentByFi([fiAll]); //ComplectNBComponToProjObj(GEndPoint.ID, SCSCompon, True); Compon_ID := CopyComponentToSCSObject(GEndPoint.ID, Compon_ID, True); { F_NormBase.CopyComponentFromNbToPm(F_NormBase, F_ProjMan, ParentNode, EndPointConnectedCatalog.TreeViewNode, Compon_ID, ckCompon, false); } AddedCompon := EndPointConnectedCatalog.GetComponentFromReferences(Compon_Id); if RackCompon <> nil then begin if RackCompon.TreeViewNode <> nil then begin if AddedCompon <> nil then begin p48List.Add(AddedCompon); AddedCompon.DisJoinFromAll(false); if AddedCompon.TreeViewNode <> nil then F_ProjMan.MoveDir(AddedCompon.TreeViewNode, RackCompon.TreeViewNode); end; end; end; end; end; end; end else begin Panel24portCount := (AfterCableList.Count div 24); AllPortCount := AllPortCount mod 24; if AllPortCount > 0 then inc(Panel24portCount); end; end; if Panel24portCount > 0 then begin SCSCompon := TSCSComponent.Create(F_NormBase); for i := 1 to Panel24portCount do begin {$IF DEFINED (SCS_PE)} //ENG Compon_ID := F_NormBase.DM.GetIntFromTable(tnComponent, fnID, fnGUID, '{F3484420-1EE2-4B0B-8866-20F7FA18E5B5}', qmPhisical); {$ELSEIF DEFINED(SCS_UKR)} // UKR Compon_ID := F_NormBase.DM.GetIntFromTable(tnComponent, fnID, fnGUID, '{F9C29F61-8A3C-469A-89F9-6562B1B63A1A}', qmPhisical); {$ELSE} // UKR/RUS Compon_ID := F_NormBase.DM.GetIntFromTable(tnComponent, fnID, fnGUID, '{A4DFD26B-B7BE-4030-B8C2-E3E4EA7B95F2}', qmPhisical); {$IFEND} if Compon_ID <> -1 then begin // Parent_ID := F_NormBase.DM.GetComponCatalogOwnerID(Compon_ID); // if Parent_ID <> -1 then //* begin //SCSCompon := F_Normbase.GSCSBase.SCSComponent; //SCSCompon := TSCSComponent.Create(F_NormBase); SCSCompon.ID := Compon_ID; SCSCompon.isLine := biFalse; SCSCompon.IDNetType := 1; //SCSCompon.LoadComponentByFi([fiIsLine, fiIDProducer, fiIDNetType, fiIDNormBase, fiObjectID]); //SCSCompon.LoadComponentByFi([fiID, fiIDNetType]); SCSCompon.LoadComponentByFi([fiAll]); Compon_ID := CopyComponentToSCSObject(GEndPoint.ID, Compon_ID, True); AddedCompon := EndPointConnectedCatalog.GetComponentFromReferences(Compon_Id); if RackCompon <> nil then begin if RackCompon.TreeViewNode <> nil then begin if AddedCompon <> nil then begin AddedCompon.DisJoinFromAll(false).Free; if AddedCompon.TreeViewNode <> nil then F_ProjMan.MoveDir(AddedCompon.TreeViewNode, RackCompon.TreeViewNode); end; end; end; //ComplectNBComponToProjObj(GEndPoint.ID, SCSCompon, True); { F_NormBase.CopyComponentFromNbToPm(F_NormBase, F_ProjMan, ParentNode, EndPointConnectedCatalog.TreeViewNode, Compon_ID, ckCompon, false); } end; {$IF DEFINED (SCS_PE)} //ENG Compon_ID := F_NormBase.DM.GetIntFromTable(tnComponent, fnID, fnGUID, '{6C8DCA87-B1D3-4843-A5C6-079C32EBA5B7}', qmPhisical); {$ELSEIF DEFINED(SCS_UKR)} // UKR Compon_ID := F_NormBase.DM.GetIntFromTable(tnComponent, fnID, fnGUID, '{24E60E82-C445-4D7B-AF30-1ABCC2BFF00C}', qmPhisical); {$ELSE} // UKR/RUS Compon_ID := F_NormBase.DM.GetIntFromTable(tnComponent, fnID, fnGUID, '{24E60E82-C445-4D7B-AF30-1ABCC2BFF00C}', qmPhisical); {$IFEND} if Compon_ID <> -1 then begin // Parent_ID := F_NormBase.DM.GetComponCatalogOwnerID(Compon_ID); // if Parent_ID <> -1 then //* begin //SCSCompon := F_Normbase.GSCSBase.SCSComponent; //SCSCompon := TSCSComponent.Create(F_NormBase); SCSCompon.ID := Compon_ID; SCSCompon.isLine := biFalse; SCSCompon.IDNetType := 1; //SCSCompon.LoadComponentByFi([fiIsLine, fiIDProducer, fiIDNetType, fiIDNormBase, fiObjectID]); //SCSCompon.LoadComponentByFi([fiID, fiIDNetType]); SCSCompon.LoadComponentByFi([fiAll]); //ComplectNBComponToProjObj(GEndPoint.ID, SCSCompon, True); Compon_ID := CopyComponentToSCSObject(GEndPoint.ID, Compon_ID, True); { F_NormBase.CopyComponentFromNbToPm(F_NormBase, F_ProjMan, ParentNode, EndPointConnectedCatalog.TreeViewNode, Compon_ID, ckCompon, false); } AddedCompon := EndPointConnectedCatalog.GetComponentFromReferences(Compon_Id); if RackCompon <> nil then begin if RackCompon.TreeViewNode <> nil then begin if AddedCompon <> nil then begin if AddedCompon.TreeViewNode <> nil then F_ProjMan.MoveDir(AddedCompon.TreeViewNode, RackCompon.TreeViewNode); end; end; end; end; {$IF DEFINED (SCS_PE)} //ENG Compon_ID := F_NormBase.DM.GetIntFromTable(tnComponent, fnID, fnGUID, '{BF1F478B-9010-46E2-AEF8-6A0C9313BFF4}', qmPhisical); {$ELSEIF DEFINED(SCS_UKR)} // UKR Compon_ID := F_NormBase.DM.GetIntFromTable(tnComponent, fnID, fnGUID, '{5B01FDFB-145A-4D5A-AC57-8AC215EA82E1}', qmPhisical); {$ELSE} // UKR/RUS Compon_ID := F_NormBase.DM.GetIntFromTable(tnComponent, fnID, fnGUID, '{3892348B-DBE1-40C8-81F0-2817AD2E9994}', qmPhisical); {$IFEND} if Compon_ID <> -1 then begin // Parent_ID := F_NormBase.DM.GetComponCatalogOwnerID(Compon_ID); // if Parent_ID <> -1 then //* begin //SCSCompon := F_Normbase.GSCSBase.SCSComponent; //SCSCompon := TSCSComponent.Create(F_NormBase); SCSCompon.ID := Compon_ID; SCSCompon.isLine := biFalse; SCSCompon.IDNetType := 1; //SCSCompon.LoadComponentByFi([fiIsLine, fiIDProducer, fiIDNetType, fiIDNormBase, fiObjectID]); //SCSCompon.LoadComponentByFi([fiID, fiIDNetType]); SCSCompon.LoadComponentByFi([fiAll]); //ComplectNBComponToProjObj(GEndPoint.ID, SCSCompon, True); Compon_ID := CopyComponentToSCSObject(GEndPoint.ID, Compon_ID, True); { F_NormBase.CopyComponentFromNbToPm(F_NormBase, F_ProjMan, ParentNode, EndPointConnectedCatalog.TreeViewNode, Compon_ID, ckCompon, false); } AddedCompon := EndPointConnectedCatalog.GetComponentFromReferences(Compon_Id); if RackCompon <> nil then begin if RackCompon.TreeViewNode <> nil then begin if AddedCompon <> nil then begin p24List.Add(AddedCompon); AddedCompon.DisJoinFromAll(false); if AddedCompon.TreeViewNode <> nil then F_ProjMan.MoveDir(AddedCompon.TreeViewNode, RackCompon.TreeViewNode); end; end; end; end; end; SCSCompon.free; end; end; finally GisAutoRotingCable := false; end; end; end; AllPortCount := 0; if p48List.Count > 0 then begin if p48List.Count > 0 then begin for i := 0 to p48List.Count - 1 do begin SCSCompon := TSCSComponent(p48List[i]); for j := 0 to 47 do begin if AllPortCount >= AfterCableList.Count then break; AddedCompon := AfterCableList[AllPortCount]; inc(AllPortCount); TempInterfaces1 := TSCSInterfaces.Create(false); TempInterfaces2 := TSCSInterfaces.Create(false); if TF_Main(F_ProjMan).F_ChoiceConnectSide.JoinWithDefineSides(AddedCompon, SCSCompon, false, TempInterfaces1, TempInterfaces2, true).CanConnect then; FreeAndNil(TempInterfaces1); FreeAndNil(TempInterfaces2); end; if AllPortCount >= AfterCableList.Count then break; end; end; end; if AllPortCount < AfterCableList.Count then begin if p24List.Count > 0 then begin for i := 0 to p24List.Count - 1 do begin SCSCompon := TSCSComponent(p24List[i]); for j := 0 to 23 do begin if AllPortCount >= AfterCableList.Count then break; AddedCompon := AfterCableList[AllPortCount]; inc(AllPortCount); TempInterfaces1 := TSCSInterfaces.Create(false); TempInterfaces2 := TSCSInterfaces.Create(false); if TF_Main(F_ProjMan).F_ChoiceConnectSide.JoinWithDefineSides(AddedCompon, SCSCompon, false, TempInterfaces1, TempInterfaces2, true).CanConnect then; FreeAndNil(TempInterfaces1); FreeAndNil(TempInterfaces2); end; if AllPortCount >= AfterCableList.Count then break; end; end; end; p48List.free; p24List.free; AfterCableList.free; end; end; // {IGOR} //D0000006298 if GAutoTraceCount = 0 then begin //if GIsProgress then // PauseProgress(true); // Tolik --10/05/2018 -- (* {$IF Defined(SCS_PE)} if MessageBox(FSCS_Main.Handle, 'Cables were not connected due to lack of free ports' + #13#10 + 'in Outlets or Boxes or Patch-panels in Telecom Cabinets' + #13#10 + 'Please add Outlets/Boxes/Patch-panels etc.' + #13#10 + #13#10 + 'Run cables anyway?', 'Warning', MB_YESNO) = IDYes then {$ELSE} if MessageBox(FSCS_Main.Handle, 'Кабель не был подключен, по причине отсутствия свободных портов ' + #13#10 + 'в розетках, боксах или патч-панелях в шкафах ' + #13#10 + 'Добавьте Розетки/Боксы/Патч-панели' + #13#10 + #13#10 + 'Автотрассировать снова?', 'Внимание', MB_YESNO) = IDYes then {$IFEND} *) if MessageBox(FSCS_Main.Handle, cCommon_Mes35, cWarningMess, MB_YESNO) = IDYes then // begin //if GIsProgress then // PauseProgress(false); F_AutoTraceConnectOrder.rbTraceManualCable.Checked := True; if ChoiceAutoTraceConnectOrder(nil, false, ACable, aFromDropConnObj, ptrTrFigInfo) then begin BeginProgress; try //Tolik 17/05/2022 -- определить кабели на трассах к шкафу до выполнения очередной автотрассировки кабеля if GEndPoint <> nil then begin if GEndPoint.Owner <> nil then if GEndPoint.Owner.Owner <> nil then ListOfEndPoint := F_ProjMan.GSCSBase.CurrProject.GetListBySCSID(TF_CAD(GEndPoint.Owner.Owner).FCADListID); if ListOfEndPoint <> nil then begin PassedList := TList.Create; BeforeCableList := TList.Create; EndPointConnectedCatalog := ListOfEndPoint.GetCatalogFromReferencesBySCSID(JoinedLine.ID); if EndPointConnectedCatalog <> nil then begin for I := 0 to TConnectorObject(GEndPoint).JoinedConnectorsList.Count - 1 do begin for j := 0 to TConnectorObject(TConnectorObject(GEndPoint).JoinedConnectorsList[i]).JoinedOrtholinesList.Count - 1 do begin JoinedLine := TOrthoLine(TConnectorObject(TConnectorObject(GEndPoint).JoinedConnectorsList[i]).JoinedOrtholinesList[j]); if not JoinedLine.deleted then begin if PassedList.IndexOf(JoinedLine) = -1 then begin PassedList.Add(JoinedLine); for k := 0 to EndPointConnectedCatalog.ComponentReferences.Count - 1 do begin if IsCableComponent(EndPointConnectedCatalog.ComponentReferences[k]) then BeforeCableList.Add(EndPointConnectedCatalog.ComponentReferences[k]); end; end; end; end; end; end; PassedList.Free; end; end; DoAutoTraceCycle(FiguresList, AID_Cable, ExistsBoxAndRack, aSaveForUndo); finally EndProgress; end; //Tolik 17/05/2022 -- определить неподключенные к шкафу кабели // отобрать новые (проложенные) кабели ... if (GEndPoint is TConnectorObject) and (TConnectorObject(GEndPoint).ConnectorType <> ct_clear) then begin PassedList := TList.Create; AfterCableList := TList.Create; EndPointConnectedCatalog := ListOfEndPoint.GetCatalogFromReferencesBySCSID(JoinedLine.ID); if EndPointConnectedCatalog <> nil then begin for I := 0 to TConnectorObject(GEndPoint).JoinedConnectorsList.Count - 1 do begin for j := 0 to TConnectorObject(TConnectorObject(GEndPoint).JoinedConnectorsList[i]).JoinedOrtholinesList.Count - 1 do begin JoinedLine := TOrthoLine(TConnectorObject(TConnectorObject(GEndPoint).JoinedConnectorsList[i]).JoinedOrtholinesList[j]); if not JoinedLine.deleted then begin if PassedList.IndexOf(JoinedLine) = -1 then begin PassedList.Add(JoinedLine); for k := 0 to EndPointConnectedCatalog.ComponentReferences.Count - 1 do begin if IsCableComponent(EndPointConnectedCatalog.ComponentReferences[k]) then begin if BeforeCableList.IndexOf(EndPointConnectedCatalog.ComponentReferences[k]) = -1 then AfterCableList.Add(EndPointConnectedCatalog.ComponentReferences[k]); end; end; end; end; end; end; end; PassedList.Free; //проверка соединений кабелей к шкафу ... EndPointConnectedCatalog := ListOfEndPoint.GetCatalogFromReferencesBySCSID(GEndPoint.ID); if EndPointConnectedCatalog <> nil then begin if AfterCableList.Count > 0 then begin for I := AfterCableList.Count - 1 downto 0 do begin if CheckConnectedComponToEndObject(TSCSComponent(AfterCableList[i]), EndPointConnectedCatalog) then AfterCableList.Delete(i); end; end; //если есть неподключенные - попытаться установить патч-панели и подключить кабели к ним... if AfterCableList.Count > 0 then begin end; end; // end; end; end //else // if GIsProgress then // PauseProgress(false); end; //02.07.2013 // // Трассировать по всем точкам // if not GCadForm.FAutoTraceBySelected then // begin // BeginProgress; // try // DoAutoTraceCycle(GCadForm.PCad.Figures, AID_Cable); // finally // EndProgress; // end; // end // else // // Трассировать по выбранным точкам // begin // BeginProgress; // try // DoAutoTraceCycle(TracedList, AID_Cable); // finally // EndProgress; // end; // end; if TracedList <> nil then FreeAndNil(TracedList); end; except on E: Exception do addExceptionToLogEx('U_Common.AutoTraceCableFromNB', E.Message); end; finally if (Not WasEndPoint) and (GEndPoint <> nil) then begin if GFigureSnap = GEndPoint then begin TConnectorObject(GEndPoint).AsEndPoint := False; GEndPoint := Nil; GListWithEndPoint := Nil; //RefreshCAD(GCadForm.PCad); end; end; // Tolik -- 27/10/2016 -- {if FiguresListCreated then FreeAndNil(FiguresList);} if FiguresList <> nil then FreeAndNil(FiguresList); // if ptrTrFigInfo <> nil then FreeMem(ptrTrFigInfo); end; end; procedure DoAutoTraceCycle(AFiguresList: TList; AID_Cable: Integer; aConsiderBoxAndRack: Boolean=false; aSaveForUndo: Boolean=true); var i, j: integer; CanTracingCount: Integer; CurrentWA: TConnectorObject; CurrentServer: TConnectorObject; IsTrace: Boolean; ObjectsList: TList; ListOfLists: TIntList; vLists: TList; vList: TF_CAD; // Tolik 28/08/2019 -- //TickPrev, TickCurr: Cardinal; TickPrev, TickCurr: DWord; // CableToTraceCount: integer; //Tolik function GetSortedListForAutoTraceByIndexes(aFigList: TList): TList; var i, j: Integer; ObjectList, CabinetList: TList; ObjectIDList: TIntList; CurrFigListIndex: Integer; currCabinet, childCatalog: TSCSCatalog; NotInListFigures: TList; CanSortList: Boolean; currFigure: TConnectorObject; BaseObject: TConnectorObject; BaseObjectFIndex: Integer; CurMinFindex: Integer; MinIndex: Integer; function GetCabinetList: TList; //получить отсортированный список кабинетов var i, j: Integer; AllCabList: TList; currCatalog: TSCSCatalog; currCabinet: TSCSCatalog; CanAddCabinet: Boolean; begin Result := TList.Create; // Список всех кабинетов AllCabList := TList.Create; for i := 0 to F_ProjMan.GSCSBase.CurrProject.ChildCatalogReferences.Count - 1 do begin currCatalog := TSCSCatalog(F_ProjMan.GSCSBase.CurrProject.ChildCatalogReferences[i]); if currCatalog.ItemType = itRoom then if AllCabList.IndexOf(currCatalog) = -1 then AllCabList.Add(currCatalog); end; // отобрать кабинеты, фигуры которых попадают в список автотрассировки if AllCabList.Count > 0 then begin for i := 0 to AllCabList.Count - 1 do begin currCatalog := TSCSCatalog(AllCabList[i]); CanAddCabinet := False; for j := 0 to currCatalog.ChildCatalogReferences.Count - 1 do begin if ObjectIDList.IndexOf(currCatalog.ChildCatalogReferences[j].SCSID) <> -1 then begin CanAddCabinet := True; Break; //// BREAK //// end; end; if (CanAddCabinet and (Result.IndexOf(currCatalog) = -1)) then Result.Add(currCatalog); end; if Result.Count > 1 then begin While CanSortList do begin CanSortList := False; for i := 0 to Result.Count - 2 do begin if (TSCSCatalog(Result[i]).SortID > TSCSCatalog(Result[i + 1]).SortID) then begin currCatalog := TSCSCatalog(Result[i]); Result[i] := Result[i + 1]; Result[i + 1] := currCatalog; CanSortList := True; end; end; end; end; end; AllCabList.Free; end; begin Result := TList.Create; NotInListFigures := Nil; try ObjectList := TList.Create; for i := 0 to aFigList.Count - 1 do if CheckFigureByClassName(TFigure(aFigList[i]), cTConnectorObject) then if TConnectorObject(aFigList[i]).ConnectorType <> ct_Clear then if not TConnectorObject(aFigList[i]).AsEndPoint then ObjectList.Add(TConnectorObject(aFigList[i])); //строим список ай-дишников фигур трассировки ObjectIDList := TIntList.Create; for i := 0 to ObjectList.Count - 1 do ObjectIDList.Add(TConnectorObject(ObjectList[i]).ID); CabinetList := GetCabinetList; // стандартно if (not F_AutoTraceConnectOrder.cbAutoTraceByIndexes.Checked) or (CabinetList.Count < 2) then begin Result := GetSortedListForAutoTrace(aFigList); end else // сортануть список фигур по кабинетам begin // добавить те, что в кабинетах, по порядку for i := 0 to CabinetList.Count - 1 do begin currCabinet := TSCSCatalog(CabinetList[i]); for j := 0 to currCabinet.ChildCatalogReferences.Count - 1 do begin childCatalog := TSCSCatalog(currCabinet.ChildCatalogReferences[j]); CurrFigListIndex := ObjectIDList.IndexOf(childCatalog.SCSID); if CurrFigListIndex <> -1 then Result.Add(TConnectorObject(ObjectList[CurrFigListIndex])); end; end; // те, что просто на листе, и не входят в кабинет if Result.Count < ObjectList.Count then begin NotInListFigures := TList.Create; for i := 0 to ObjectList.Count - 1 do begin if Result.IndexOf(TConnectorObject(ObjectList[i])) = -1 then NotInListFigures.Add(TConnectorObject(ObjectList[i])); end; if NotInListFigures.Count > 0 then begin CanSortList := True; while CanSortList do begin CanSortList := False; for i := 0 to NotInListFigures.Count - 2 do begin if TConnectorObject(NotInListFigures[i]).FIndex > TConnectorObject(NotInListFigures[i + 1]).FIndex then begin CurrFigure := TConnectorObject(NotInListFigures[i]); NotInListFigures[i] := NotInListFigures[i + 1]; NotInListFigures[i + 1] := currFigure; CanSortList := True; end; end; end; for i := 0 to NotInListFigures.Count - 1 do Result.Add(NotInListFigures[i]); end; end; end; FreeAndNil(ObjectList); if NotInListFigures <> nil then NotInListFigures.Free; ObjectIDList.Free; except on E: Exception do addExceptionToLogEx('U_Common.GetSortedListForAutoTrace', E.Message); end; end; // begin ListOfLists := nil; // Tolik 21/05/2018 -- try BeginAutoTrace; TickPrev := GetTickCount; CurrentServer := nil; //#From Oleg# //14.09.2010 CanTracingCount := 1; // Tolik -- 08/02/2017 -*- //ObjectsList := TList.Create; // if not F_AutoTraceConnectOrder.cbAutoTraceByIndexes.Checked then ObjectsList := GetSortedListForAutoTrace(aFiguresList) else ObjectsList := GetSortedListForAutoTraceByIndexes(aFiguresList); // //Tolik ListOfLists := nil; vLists := nil; // получить список листов через которые будет проведена автотрассировка ListOfLists := TIntList.create; if GListWithEndPoint <> nil then begin ListOfLists := GetSortedListIDsByBounds(GListWithEndPoint.FCADListID, GCadForm.FCADListID); end else ListOfLists.Add(GCadForm.FCADListID); if aSaveForUndo then begin vLists := TList.Create; for i := 0 to ListOfLists.Count - 1 do begin vList := GetListByID(ListOfLists[i]); if vList <> nil then vLists.Add(vList); end; SaveForProjectUndo(vLists, True, False); end; try CableToTraceCount := strtoint(F_AutoTraceConnectOrder.neCableTraceCount.Text); except CableToTraceCount := 0; end; // Tolik 28/10/2016-- BeginProgress(cProgress_Mes1, ObjectsList.Count, true); F_Progress.BringToFront; // while CanTracingCount > 0 do begin CanTracingCount := 0; //Tolik 24/11/2021 -- здесь, чтобы пауза прогресса не выполнялась каждый раз при TracingToEndPoint -- //сделать раз до цилка и выйти из паузы после него try PauseProgress(true); // Tolik 16/05/2022 -- вынесено из цикла! if CheckFigureByClassName(GEndPoint, cTConnectorObject) then CurrentServer := TConnectorObject(GEndPoint) else if CheckFigureByClassName(GEndPoint, cTHouse) then CurrentServer := GetEndPointByHouse(THouse(GEndPoint), CurrentWA); // *** if CurrentServer <> nil then begin GDropTracing := false; for i := 0 to ObjectsList.Count - 1 do begin CurrentWA := TConnectorObject(ObjectsList[i]); if CurrentWA <> nil then begin //Tolik 16/05/2022 -- Это нафиг из цикла - оченно ускорит процесс, если сделат 1(!) раз!!! // *** { if CheckFigureByClassName(GEndPoint, cTConnectorObject) then CurrentServer := TConnectorObject(GEndPoint) else if CheckFigureByClassName(GEndPoint, cTHouse) then CurrentServer := GetEndPointByHouse(THouse(GEndPoint), CurrentWA); // *** if CurrentServer <> nil then begin } {IGOR} //D0000006298 (* if F_AutoTraceConnectOrder.rbTraceManualCable.Checked then begin //Inc(CanTracingCount); ProcessMessagesEx; for j := 1 to CableToTraceCount do begin GCadForm.FTracingList := GetAllTraceInCAD(CurrentWA, CurrentServer); if Assigned(GCadForm.FTracingList) then FreeAndNil(GCadForm.FTracingList); IsTrace := TracingToEndPoint(CurrentWA, CurrentServer, AID_Cable, false {aConsiderBoxAndRack}); GAutoTraceCount := GAutoTraceCount + 1; if IsTrace then begin GCadForm.mProtocol.Lines.Add(cCommon_Mes2 + CurrentWA.Name + cCommon_Mes3 + CurrentServer.Name + '"'); end end; end else *) if F_AutoTraceConnectOrder.rbTraceManualCable.Checked or F_AutoTraceConnectOrder.StreakConnect.Checked then begin //Inc(CanTracingCount); ProcessMessagesEx; //Tolik if F_AutoTraceConnectOrder.StreakConnect.Checked and not F_AutoTraceConnectOrder.rbTraceManualCable.Checked then begin while CanConnectLineComponWithConObjects(AID_Cable, CurrentWA.ID, CurrentServer.ID, aConsiderBoxAndRack) do begin // Tolik -- 24/05/21017 -- Это нужно, чтобы не зациклилось, если конечным объектов выбран пустой коннектор, // подключенный к точечному объекту !!!!!!!!!!!!!!! if (CurrentWA.ClassName = 'TConnectorObject') and (CurrentServer.ClassName = 'TConnectorObject') and ((TConnectorObject(currentWA).JoinedConnectorsList.IndexOf(TConnectorObject(currentServer)) <> -1) or (TConnectorObject(currentServer).JoinedConnectorsList.IndexOf(TConnectorObject(currentWA)) <> -1)) then break; // //GCadForm.FTracingList := GetAllTraceInCAD(CurrentWA, CurrentServer); if Assigned(GCadForm.FTracingList) then FreeAndNil(GCadForm.FTracingList); IsTrace := TracingToEndPoint(CurrentWA, CurrentServer, AID_Cable, false {aConsiderBoxAndRack}); GAutoTraceCount := GAutoTraceCount + 1; if IsTrace then GCadForm.mProtocol.Lines.Add(cCommon_Mes2 + CurrentWA.Name + cCommon_Mes3 + CurrentServer.Name + '"') else break; end; end else begin for j := 1 to CableToTraceCount do begin //GCadForm.FTracingList := GetAllTraceInCAD(CurrentWA, CurrentServer); if Assigned(GCadForm.FTracingList) then FreeAndNil(GCadForm.FTracingList); IsTrace := TracingToEndPoint(CurrentWA, CurrentServer, AID_Cable, false {aConsiderBoxAndRack}); GAutoTraceCount := GAutoTraceCount + 1; if IsTrace then GCadForm.mProtocol.Lines.Add(cCommon_Mes2 + CurrentWA.Name + cCommon_Mes3 + CurrentServer.Name + '"'); end; end; end else begin if CanConnectLineComponWithConObjects(AID_Cable, CurrentWA.ID, CurrentServer.ID, aConsiderBoxAndRack) then begin Inc(CanTracingCount); ProcessMessagesEx; IsTrace := TracingToEndPoint(CurrentWA, CurrentServer, AID_Cable, aConsiderBoxAndRack); if IsTrace then begin GAutoTraceCount := GAutoTraceCount + 1; GCadForm.mProtocol.Lines.Add(cCommon_Mes2 + CurrentWA.Name + cCommon_Mes3 + CurrentServer.Name + '"'); end else // в протокол begin Dec(CanTracingCount); GCadForm.mProtocol.Lines.Add(cCommon_Mes4 + CurrentWA.Name + cCommon_Mes5 + #13#10 + cCommon_Mes6); end; end else GCadForm.mProtocol.Lines.Add(cCommon_Mes4 + CurrentWA.Name + cCommon_Mes5 + #13#10 + cCommon_Mes6); end; //end; end; // Tolik -- 28/10/2016 -- StepProgressRE; end; end; finally PauseProgress(false); end; end; EndProgress; FreeAndNil(ObjectsList); //Tolik if ListOfLists <> nil then FreeAndNil(ListOfLists); if vLists <> nil then FreeAndNil(vLists); // except on E: Exception do addExceptionToLogEx('U_Common.DoAutoTraceCycle', E.Message); end; TickCurr := GetTickCount - TickPrev; TickCurr := GetTickCount - TickPrev; EndAutoTrace; end; Procedure AutoConnectBetweenFloorPassage(ACable: TOrthoLine; ASide: Integer; ARaise: TConnectorObject); var i, j: integer; JoinedConn1, JoinedConn2: TConnectorObject; JoinedObject: TConnectorObject; JoinedLine: TOrthoLine; isConnected: Boolean; ptrInterfRecord1, ptrInterfRecord2: PConnectObjectParam; ParamsList1, ParamsList2: TList; ListOfPassage: TF_CAD; ConnOfPassage: TConnectorObject; begin try ParamsList1 := TList.Create; ParamsList2 := TList.Create; // интерфейсы кабеля New(ptrInterfRecord1); ptrInterfRecord1.IDObject := ACable.ID; if ASide = 1 then ptrInterfRecord1.Side := 1; if ASide = 2 then ptrInterfRecord1.Side := 2; ParamsList1.Add(ptrInterfRecord1); // получить объект и лист перехода ListOfPassage := GetListOfPassage(ARaise.FID_ListToPassage); if ListOfPassage <> nil then begin ConnOfPassage := TConnectorObject(GetFigureByID(ListOfPassage, ARaise.FID_ConnToPassage)); for j := 0 to ConnOfPassage.JoinedOrtholinesList.Count - 1 do begin JoinedLine := TOrthoLine(ConnOfPassage.JoinedOrtholinesList[j]); if JoinedLine.FIsRaiseUpDown then begin New(ptrInterfRecord2); ptrInterfRecord2.IDObject := JoinedLine.ID; if ConnOfPassage = JoinedLine.JoinConnector1 then ptrInterfRecord2.Side := 1; if ConnOfPassage = JoinedLine.JoinConnector2 then ptrInterfRecord2.Side := 2; ParamsList2.Add(ptrInterfRecord2); end; end; end; isConnected := ConnectObjectsInPM(ParamsList1, ParamsList2); // Tolik 09/02/2017 -- if ParamsList1 <> nil then begin for i := 0 to ParamsList1.Count - 1 do begin Dispose(PConnectObjectParam(ParamsList1[i])); end; FreeAndNil(ParamsList1); end; if ParamsList2 <> nil then begin for i := 0 to ParamsList2.Count - 1 do begin Dispose(PConnectObjectParam(ParamsList2[i])); end; FreeAndNil(ParamsList2); end; // // if ParamsList1 <> nil then // FreeAndNil(ParamsList1); // if ParamsList2 <> nil then // FreeAndNil(ParamsList2); except on E: Exception do addExceptionToLogEx('U_Common.AutoConnectBetweenFloorPassage', E.Message); end; end; Function GetBetweenFloorRaiseLine(ALine: TOrthoLine): TOrthoLine; var AConnRaiseType: TConnRaiseType; i: integer; RaiseConn: TConnectorObject; RaiseConnPassage: TConnectorObject; ListOfPassage: TF_CAD; ConnOfPassage: TConnectorObject; begin Result := nil; try AConnRaiseType := TConnectorObject(ALine.JoinConnector1).FConnRaiseType; if (AConnRaiseType = crt_BetweenFloorUp) or (AConnRaiseType = crt_BetweenFloorDown) then begin RaiseConn := TConnectorObject(ALine.JoinConnector1); ListOfPassage := GetListOfPassage(RaiseConn.FID_ListToPassage); if ListOfPassage <> nil then begin RaiseConnPassage := TConnectorObject(GetFigureByID(ListOfPassage, RaiseConn.FID_ConnToPassage)); for i := 0 to RaiseConnPassage.JoinedOrtholinesList.Count - 1 do if TOrthoLine(RaiseConnPassage.JoinedOrtholinesList[i]).FIsRaiseUpDown then Result := TOrthoLine(RaiseConnPassage.JoinedOrtholinesList[i]); end; end; AConnRaiseType := TConnectorObject(ALine.JoinConnector2).FConnRaiseType; if (AConnRaiseType = crt_BetweenFloorUp) or (AConnRaiseType = crt_BetweenFloorDown) then begin RaiseConn := TConnectorObject(ALine.JoinConnector2); ListOfPassage := GetListOfPassage(RaiseConn.FID_ListToPassage); if ListOfPassage <> nil then begin RaiseConnPassage := TConnectorObject(GetFigureByID(ListOfPassage, RaiseConn.FID_ConnToPassage)); for i := 0 to RaiseConnPassage.JoinedOrtholinesList.Count - 1 do if TOrthoLine(RaiseConnPassage.JoinedOrtholinesList[i]).FIsRaiseUpDown then Result := TOrthoLine(RaiseConnPassage.JoinedOrtholinesList[i]); end; end; except on E: Exception do addExceptionToLogEx('U_Common.GetBetweenFloorRaiseLine', E.Message); end; end; Function TracingToEndPoint(ACurrentWS, AEndPoint: TConnectorObject; AID_Cable: Integer; aConsiderBoxAndRack: Boolean=false): Boolean; var i, j: integer; RaiserThisList: TConnectorObject; RaiserOtherList: TConnectorObject; CurGCadForm: TF_CAD; ComponID: Integer; isConnected: Boolean; IDLine: Integer; IDPointer: ^Integer; AllTrace: TList; AllTraceItList: TList; AllTraceOtherList: TList; AllSCSObjs: TList; SetLinesList: TIntList; SCSObj: TSCSCatalog; ptrInterfRecord1, ptrInterfRecord2: PConnectObjectParam; ParamsList1, ParamsList2: TList; CurrLine: TOrthoLine; CurrConn: TConnectorObject; RaiseType: TConnRaiseType; ListOfLists: TIntList; ListOfRaises: TList; CurrentCAD: TF_CAD; ConnFrom: TConnectorObject; ConnTo: TConnectorObject; PrevConn: TConnectorObject; PrevCAD: TF_CAD; // Tolik FirstFigure: TFigure; LastFigure: TFigure; // ProgressPaused: Boolean; // Tolik 24/11/2021 - - begin Result := False; ProgressPaused := False; // Tolik 24/11/2021 -- if F_Progress.FPauseCount = 0 then // Tolik 24/11/2021 -- begin ProgressPaused := True; // Tolik 24/11/2021 -- PauseProgress(True); end; ListOfLists := Nil; // Tolik 21/05/2018 -- try if (ACurrentWS = nil) or (AEndPoint = nil) then begin if ProgressPaused then //Tolik 24/11/2021 -- PauseProgress(false); // Tolik 24/11/2021 -- exit; end; ProcessMessagesEx; if GListWithEndPoint = GCadForm then begin // если if not CheckTrunkObject(AEndPoint) or not CheckTrunkObject(AEndPoint) then begin // *** Получить текущий путь после выделения // *** его не будет если не было ручного выделения пути if GCadForm.FTracingList = nil then AllTrace := GetAllTraceInCAD(AEndPoint, ACurrentWS) else // Tolik -- 06/03/2017 -- begin //AllTrace := GCadForm.FTracingList; AllTrace := TList.Create; AllTrace.Assign(GCadForm.FTracingList, laCopy); end; // выделить трассу if AllTrace <> nil then begin AllSCSObjs := TList.Create; {for i := 0 to AllTrace.Count - 1 do TFigure(AllTrace[i]).Select;} DisableMarking; //15.01.2011 - Отключаем генерацию маркировки для кабеля try // скопировать кабель туда for i := 0 to AllTrace.Count - 1 do begin //08.11.2011 ComponID := CopyComponentToSCSObject(TFigure(AllTrace[i]).ID, AID_Cable); ComponID := CopyComponentToSCSObject(TFigure(AllTrace[i]).ID, AID_Cable, false, @SCSObj); AllSCSObjs.Add(SCSObj); end; finally EnableMarking; end; // убрать выделение трассы { for i := 0 to AllTrace.Count - 1 do TFigure(AllTrace[i]).DeSelect;} // SetLinesList := TIntList.Create; for i := 0 to AllTrace.Count - 1 do begin IDLine := TFigure(AllTrace[i]).ID; SetLinesList.Add(IDLine); end; isConnected := ConnectObjectsInPMByWay(SetLinesList, AllTrace, AllSCSObjs, nil, aConsiderBoxAndRack); //08.11.2011 isConnected := ConnectObjectsInPMByWay(SetLinesList, AllSCSObjs); if SetLinesList <> nil then FreeAndNil(SetLinesList); if AllTrace <> nil then FreeAndNil(AllTrace); if GCadForm.FTracingList <> nil then // Tolik 06/03/2017 -- // GCadForm.FTracingList := nil; FreeAndNil(GCadForm.FTracingList); // Result := True; //if aConsiderBoxAndRack then // if Not isConnected then // Result := false; AllSCSObjs.Free; end; GCadForm.FTracingListIndex := 0; end else begin TracingTrunkToEndPoint(ACurrentWS, AEndPoint, AID_Cable); end; end else if GListWithEndPoint <> nil then begin RaiseType := crt_BetweenFloorDown; //#From Oleg# //14.09.2010 // другой лист с КО if GetUpperList(GListWithEndPoint.FCADListID, GCadForm.FCADListID) = GListWithEndPoint.FCADListID then RaiseType := crt_BetweenFloorDown; if GetUpperList(GListWithEndPoint.FCADListID, GCadForm.FCADListID) = GCadForm.FCADListID then RaiseType := crt_BetweenFloorUp; ListOfLists := GetSortedListIDsByBounds(GListWithEndPoint.FCADListID, GCadForm.FCADListID); if ListOfLists.Count >= 2 then begin ListOfRaises := GetSortedListOfRaises(ListOfLists, RaiseType, AEndPoint, ACurrentWS); if ListOfLists.Count >= 2 then begin if CheckCanTracingBetweenFloor(ListOfLists, ListOfRaises) then begin PrevCAD := nil; PrevConn := nil; SetLinesList := TIntList.Create; DisableMarking; //15.01.2011 - Отключаем генерацию маркировки для кабеля try // CICLE for i := 0 to ListOfLists.Count - 1 do begin BeginProgress; CurrentCAD := GetListByID(ListOfLists[i]); if i < ListOfLists.Count - 1 then ConnTo := TConnectorObject(ListOfRaises[i]) else ConnTo := ACurrentWS; CurGCadForm := GCadForm; GCadForm := CurrentCAD; if i = 0 then begin ConnFrom := AEndPoint; end else begin ConnFrom := TConnectorObject(GetFigureByID(GCadForm, PrevConn.FID_ConnToPassage)); end; if GCadForm.FTracingList = nil then AllTrace := GetAllTraceInCAD(ConnFrom, ConnTo) else // Tolik -- 03/03/2017 -- // AllTrace := GCadForm.FTracingList; begin AllTrace := TList.Create; AllTrace.Assign(GCadForm.FTracingList, laOR); end; // if AllTrace <> nil then begin // Tolik 27/09/2016 -- { for j := 0 to AllTrace.Count - 1 do TFigure(AllTrace[j]).Select; for j := 0 to AllTrace.Count - 1 do ComponID := CopyComponentToSCSObject(TFigure(AllTrace[j]).ID, AID_Cable); for j := 0 to AllTrace.Count - 1 do TFigure(AllTrace[j]).DeSelect; RefreshCAD(GCadForm.PCad); for j := 0 to AllTrace.Count - 1 do begin IDLine := TOrthoLine(AllTrace[j]).ID; SetLinesList.Add(IDLine); end; } for j := 0 to AllTrace.Count - 1 do begin TFigure(AllTrace[j]).Select; ComponID := CopyComponentToSCSObject(TFigure(AllTrace[j]).ID, AID_Cable); TFigure(AllTrace[j]).DeSelect; IDLine := TOrthoLine(AllTrace[j]).ID; SetLinesList.Add(IDLine); end; RefreshCAD(GCadForm.PCad); { if i = 0 then begin for j := 0 to AllTrace.Count - 1 do begin TFigure(AllTrace[j]).Select; ComponID := CopyComponentToSCSObject(TFigure(AllTrace[j]).ID, AID_Cable); TFigure(AllTrace[j]).DeSelect; end; RefreshCAD(GCadForm.PCad); firstFigure := TFigure(AllTrace[0]); LastFigure := TFigure(AllTrace[AllTrace.Count - 1]); if checkFigurebyClassName(FirstFigure, cTConnectorObject) and checkFigurebyClassName(FirstFigure, cTOrthoLine) then begin for j := 0 to AllTrace.Count - 1 do begin IDLine := TOrthoLine(AllTrace[j]).ID; SetLinesList.Add(IDLine); end; end else begin for j := AllTrace.Count - 1 downto 0 do begin IDLine := TOrthoLine(AllTrace[j]).ID; SetLinesList.Add(IDLine); end; end; end else begin for j := 0 to AllTrace.Count - 1 do begin TFigure(AllTrace[j]).Select; ComponID := CopyComponentToSCSObject(TFigure(AllTrace[j]).ID, AID_Cable); TFigure(AllTrace[j]).DeSelect; end; RefreshCAD(GCadForm.PCad); firstFigure := TFigure(AllTrace[0]); LastFigure := TFigure(AllTrace[AllTrace.Count - 1]); if checkFigurebyClassName(FirstFigure, cTOrthoLine) and checkFigurebyClassName(FirstFigure, cTConnectorObject) then begin for j := 0 to AllTrace.Count - 1 do begin IDLine := TOrthoLine(AllTrace[j]).ID; SetLinesList.Add(IDLine); end; end else begin for j := AllTrace.Count - 1 downto 0 do begin IDLine := TOrthoLine(AllTrace[j]).ID; SetLinesList.Add(IDLine); end; end; end; } // end; if AllTrace <> nil then FreeAndNil(AllTrace); if GCadForm.FTracingList <> nil then // Tolik 08/02/2017 -- // GCadForm.FTracingList := nil; FreeAndNil(GCadForm.FTracingList); // Tolik 27/04/2017 -- EndProgress; // GCadForm.FTracingListIndex := 0; GCadForm := CurGCadForm; PrevCAD := CurrentCAD; PrevConn := ConnTo; end; finally EnableMarking; end; isConnected := ConnectObjectsInPMByWay(SetLinesList, nil, nil, nil); if SetLinesList <> nil then FreeAndNil(SetLinesList); Result := True; end; end; end; if ListOfLists <> nil then FreeAndNil(ListOfLists); if ListOfRaises <> nil then FreeAndNil(ListOfRaises); end; if ACurrentWS <> nil then if ACurrentWS.ConnectorType = ct_Clear then begin if ACurrentWS.JoinedOrtholinesList.Count > 1 then begin ParamsList1 := TList.Create; ParamsList2 := TList.Create; // интерфейсы кабеля CurrLine := TOrthoLine(ACurrentWS.JoinedOrtholinesList[0]); New(ptrInterfRecord1); ptrInterfRecord1.IDObject := CurrLine.ID; if CurrLine.JoinConnector1 = ACurrentWS then ptrInterfRecord1.Side := 1; if CurrLine.JoinConnector2 = ACurrentWS then ptrInterfRecord1.Side := 2; ParamsList1.Add(ptrInterfRecord1); for i := 1 to ACurrentWS.JoinedOrtholinesList.Count - 1 do begin CurrLine := TOrthoLine(ACurrentWS.JoinedOrtholinesList[i]); New(ptrInterfRecord2); ptrInterfRecord2.IDObject := CurrLine.ID; if CurrLine.JoinConnector1 = ACurrentWS then ptrInterfRecord2.Side := 1; if CurrLine.JoinConnector2 = ACurrentWS then ptrInterfRecord2.Side := 2; ParamsList2.Add(ptrInterfRecord2); end; isConnected := ConnectObjectsInPM(ParamsList1, ParamsList2); // Tolik 09/02/2017 -- //FreeAndNil(ParamsList1); //FreeAndNil(ParamsList2); if ParamsList1 <> nil then begin for i := 0 to ParamsList1.Count - 1 do begin Dispose(PConnectObjectParam(ParamsList1[i])); end; FreeAndNil(ParamsList1); end; if ParamsList2 <> nil then begin for i := 0 to ParamsList2.Count - 1 do begin Dispose(PConnectObjectParam(ParamsList2[i])); end; FreeAndNil(ParamsList2); end; // end; end; except on E: Exception do addExceptionToLogEx('U_Common.TracingToEndPoint', E.Message); end; if ProgressPaused then// Tolik 24/11/2021 -- PauseProgress(False); end; Procedure ApplyParamsForAllSCSObject(AConnHeight, ALineHeight: Double; AConnCaptionsShowType, AConnNotesShowType: TShowType; ALineCaptionsShowType, ALineNotesShowType: TShowKind; aCADParams: TCADParams); var i, j, k: integer; CurrObject: TConnectorObject; CurrTrace: TOrthoLine; ObjParams: TObjectParams; TracesList: TList; NotesList: TStringList; x1, y1, z1, x2, y2, z2: double; GetPointObject: TConnectorObject; LinesList: TList; ConnsList: TList; valBool: Boolean; valInteger: Integer; valDouble: Double; valString: string; valColor: TColor; Str: string; isApply: Boolean; PairCount: Integer; PairStr: string; NotesCaptions: TRichTextMod; Captions: TRichTextMod; CadCrossObject: TCadCrossObject; valPrintType: TPrintType; CurrRichText: TRichTextMod; // Tolik OldCaptH, OldCaptW: Double; FontStyles: TFontStyles; CableChannelElements: TList; ConnCatalog: TSCSCatalog; SCSComponent: TSCSComponent; // Tolik -- 21/12/2016 -- TraceList: TList; // Tolik -- 27/02/2017 -- RaiseList: TList; // список райзов CanChangeRaiseCaptions: Boolean; // подписи к райзам GCanRefreshFlag: Boolean; // function GetTraceList: TList; var i, j : Integer; begin Result := TList.Create; if CurrObject.ConnectorType = ct_NB then begin for i := 0 to CurrObject.JoinedConnectorsList.Count - 1 do begin for j := 0 to TConnectorObject(CurrObject.JoinedConnectorsList[i]).JoinedOrthoLinesList.Count - 1 do begin if Result.IndexOf(TOrthoLine(TConnectorObject(CurrObject.JoinedConnectorsList[i]).JoinedOrthoLinesList[j])) = -1 then Result.Add(TOrthoLine(TConnectorObject(CurrObject.JoinedConnectorsList[i]).JoinedOrthoLinesList[j])); end; end; end; if Result.Count = 0 then begin FreeAndNil(Result); Result := Nil; // на всякий end; end; // Украдено из модуля свойств СКС-Объекта procedure ChangeConnZ(aObject: TConnectorObject; aZ: Double); var i, j: integer; JoinedLine: TOrthoLine; JoinedConn: TConnectorObject; ObjFromRaise: TConnectorObject; ZCoord: Double; mess: string; RaiseConn: TConnectorObject; RaiseLine: TOrthoLine; PrevCount: integer; JConnList: TList; begin try JConnList := TList.Create; ZCoord := aZ; // Соединитель ----------------------------------------------------- if aObject.ConnectorType = ct_Clear then begin // Он не с-п и на нем нет с-п if (aObject.FConnRaiseType = crt_None) and (GetRaiseConn(aObject) = nil) then begin if not GCadForm.FListSettings.CADAutoPosTraceBetweenRM then CreateRaiseOnConnector(aObject, ZCoord) else begin for i := 0 to aObject.JoinedConnectorsList.Count - 1 do // отконнектить присоед. коннекторы begin if JConnList.IndexOf(aObject.JoinedConnectorsList[i]) = -1 then JConnList.Add(aObject.JoinedConnectorsList[i]); end; while aObject.JoinedConnectorsList.Count <> 0 do UnsnapConnectorFromPointObject(aObject.JoinedConnectorsList[0], aObject); end; end else // на нем есть с-п if GetRaiseConn(aObject) <> nil then begin ChangeRaiseOnConnector(aObject, ZCoord); // SP !!! // CheckDeleteAllRaises(GCadForm.PCad); end else // это с-п if (aObject.FConnRaiseType = crt_OnFloor) then begin ObjFromRaise := aObject.FObjectFromRaise; if ZCoord = ObjFromRaise.ActualZOrder[1] then begin mess := cSCSObjectProp_Mes1; //if MessageBoxA(FSCS_Main.Handle, PAnsiChar(mess), cSCSObjectProp_Mes2, MB_YESNO) = IDYes then if MessageBox(FSCS_Main.Handle, PChar(mess), PChar(cSCSObjectProp_Mes2), MB_YESNO) = IDYes then begin if ObjFromRaise.ConnectorType = ct_Clear then DestroyRaiseOnConnector(ObjFromRaise) else DestroyRaiseOnPointObject(ObjFromRaise); end else begin aObject.ActualZOrder[1] := ZCoord; SetConFigureCoordZInPM(aObject.ID, aObject.ActualZOrder[1]);//24.10.2012 end; end else begin aObject.ActualZOrder[1] := ZCoord; SetConFigureCoordZInPM(aObject.ID, aObject.ActualZOrder[1]);//24.10.2012 end; end; end else // Объект ---------------------------------------------------------- begin // Он не с-п и на нем нет с-п if (aObject.FConnRaiseType = crt_None) and (GetRaiseConn(aObject) = nil) then begin //Tolik // if aObject.JoinedConnectorsList.Count = 0 then if aObject.JoinedConnectorsList.Count = 0 then // begin aObject.ActualZOrder[1] := ZCoord; SetConFigureCoordZInPM(aObject.ID, ZCoord); end else begin if not GCadForm.FListSettings.CADAutoPosTraceBetweenRM then CreateRaiseOnPointObject(aObject, ZCoord) else begin for i := 0 to aObject.JoinedConnectorsList.Count - 1 do // отконнектить присоед. коннекторы begin if JConnList.IndexOf(aObject.JoinedConnectorsList[i]) = -1 then JConnList.Add(aObject.JoinedConnectorsList[i]); end; while aObject.JoinedConnectorsList.Count <> 0 do UnsnapConnectorFromPointObject(aObject.JoinedConnectorsList[0], aObject); end; aObject.ActualZOrder[1] := ZCoord; SetConFigureCoordZInPM(aObject.ID, ZCoord); end; end else // на нем есть с-п if GetRaiseConn(aObject) <> nil then begin // только подъем-спуск begin if aObject.JoinedConnectorsList.Count = 0 then begin aObject.ActualZOrder[1] := ZCoord; SetConFigureCoordZInPM(aObject.ID, ZCoord); end else begin ChangeRaiseOnPointObject(aObject, ZCoord); // SP !!! // CheckDeleteAllRaises(GCadForm.PCad); end; end; end else // это с-п if (aObject.FConnRaiseType = crt_OnFloor) then begin ObjFromRaise := aObject.FObjectFromRaise; if ZCoord = ObjFromRaise.ActualZOrder[1] then begin mess := cSCSObjectProp_Mes1; //if MessageBoxA(FSCS_Main.Handle, PAnsiChar(mess), cSCSObjectProp_Mes2, MB_YESNO) = IDYes then if MessageBox(FSCS_Main.Handle, PChar(mess), PChar(cSCSObjectProp_Mes2), MB_YESNO) = IDYes then begin if ObjFromRaise.ConnectorType = ct_Clear then DestroyRaiseOnConnector(ObjFromRaise) else DestroyRaiseOnPointObject(ObjFromRaise); end else begin aObject.ActualZOrder[1] := ZCoord; SetConFigureCoordZInPM(aObject.ID, aObject.ActualZOrder[1]);//24.10.2012 end; end else begin aObject.ActualZOrder[1] := ZCoord; SetConFigureCoordZInPM(aObject.ID, aObject.ActualZOrder[1]);//24.10.2012 end; end; end; aObject.MoveConnector(0, 0, false, false, false); // ДЛЯ ПЕРЕСЧЕТА ДЛИНЫ И ЗАПИСИ В РМ // Tolik --03/04/2018 -- чет тут хуйня написана кака-то совсем ... { if JConnList.Count > 0 then begin for i := 0 to JConnList.Count - 1 do begin SnapConnectorToPointObject(TConnectorObject(aObject), TConnectorObject(JConnList[i])); end; end; } for i := 0 to JConnList.Count - 1 do begin JoinedConn := TConnectorObject(TConnectorObject(JConnList[i])); if JoinedConn.ConnectorType = ct_Clear then begin if TConnectorObject(aObject).ConnectorType = ct_NB then CheckingSnapPointObjectToConnector(TConnectorObject(aObject), JoinedConn, False, True) else if TConnectorObject(aObject).ConnectorType = ct_clear then begin CheckingSnapConnectorToConnector(JoinedConn, TConnectorObject(aObject)); end; end else if JoinedConn.ConnectorType = ct_NB then begin if TConnectorObject(aObject).ConnectorType = ct_clear then CheckingSnapPointObjectToConnector(JoinedConn, TConnectorObject(aObject), False, False); end; end; // JConnList.Clear; // RaiseConn := nil; RaiseConn := GetRaiseConn(aObject); if RaiseConn <> nil then begin if Not RaiseConn.Deleted then begin i := 0; while i < RaiseConn.JoinedOrtholinesList.Count do begin prevcount := RaiseConn.JoinedOrtholinesList.Count; if Not TOrthoLine(RaiseConn.JoinedOrtholinesList[i]).Deleted then begin if TOrthoLine(RaiseConn.JoinedOrtholinesList[i]).FIsRaiseUpDown then begin RaiseLine := TOrthoLine(RaiseConn.JoinedOrtholinesList[i]); CheckDeleteRaise(RaiseLine); if Not assigned(RaiseConn) or RaiseConn.Deleted then break; end; end; if RaiseConn.JoinedOrtholinesList.Count = PrevCount then i := i + 1; if RaiseConn.JoinedOrtholinesList.Count < PrevCount then i := 0; end; end; end; // FreeAndNil(JConnList); except on E: Exception do AddExceptionToLogEx('U_Common.ChangeConnZ', E.Message); end; end; // begin //Tolik GCanRefreshFlag := GCanRefreshCad; GCanRefreshCad := False; // try BeginProgress; valPrintType := pt_Color; TracesList := TList.Create; LinesList := TList.Create; ConnsList := TList.Create; CableChannelElements := TList.Create; CanChangeRaiseCaptions := False; RaiseList := TList.Create; // занесение в листы // Tolik 24/01/2019 - - for i := 0 to GCadForm.FSCSFigures.Count - 1 do begin if not TFigure(GCadForm.FSCSFigures[i]).Deleted then begin if CheckFigureByClassName(TFigure(GCadForm.FSCSFigures[i]), cTOrthoLine) then begin CurrTrace := TOrthoLine(GCadForm.FSCSFigures[i]); // Tolik 11/05/2016 -- нужно учесть и вертикали тоже // if not CurrTrace.FIsRaiseUpDown then if ((not CurrTrace.FIsRaiseUpDown) and (not CurrTrace.FIsVertical)) then // begin if CurrTrace.ActualZOrder[1] = CurrTrace.ActualZOrder[2] then TracesList.Add(CurrTrace); end else if CurrTrace.FIsRaiseUpDown then RaiseList.Add(CurrTrace); LinesList.Add(CurrTrace); end else if CheckFigureByClassName(TFigure(GCadForm.FSCSFigures[i]), cTConnectorObject) then begin CurrObject := TConnectorObject(GCadForm.FSCSFigures[i]); ConnsList.Add(CurrObject); end; end; end; { for i := 0 to GCadForm.PCad.FigureCount - 1 do begin if not TFigure(GCadForm.PCad.Figures[i]).Deleted then begin if CheckFigureByClassName(TFigure(GCadForm.PCad.Figures[i]), cTOrthoLine) then begin CurrTrace := TOrthoLine(GCadForm.PCad.Figures[i]); // Tolik 11/05/2016 -- нужно учесть и вертикали тоже // if not CurrTrace.FIsRaiseUpDown then if ((not CurrTrace.FIsRaiseUpDown) and (not CurrTrace.FIsVertical)) then // begin if CurrTrace.ActualZOrder[1] = CurrTrace.ActualZOrder[2] then TracesList.Add(CurrTrace); end else if CurrTrace.FIsRaiseUpDown then RaiseList.Add(CurrTrace); LinesList.Add(CurrTrace); end else if CheckFigureByClassName(TFigure(GCadForm.PCad.Figures[i]), cTConnectorObject) then begin CurrObject := TConnectorObject(GCadForm.PCad.Figures[i]); ConnsList.Add(CurrObject); end; end; end; } // Tolik 27/02/2017 - -- райзы if (aCADParams.CADShowRaiseHeights <> F_MasterNewList.cbShowRaiseHeights.Checked) then // если показывать разницу высот райзов begin for i := 0 to RaiseList.Count - 1 do begin CurrTrace := TOrthoLine(RaiseList[i]); if CurrTrace.Visible and (not CurrTrace.Deleted) then CurrTrace.UpdateLengthTextBox(True, False); end; end; FreeAndNil(RaiseList); // // Tolik -- 11/05/2016 -- CurrTrace := NIL; // // ИЗМЕНЕНИЕ РАСПОЛОЖЕНИЯ ОБЪЕКТОВ // поиск всех объектов for i := 0 to ConnsList.Count - 1 do begin CurrObject := TConnectorObject(ConnsList[i]); if not CurrObject.Deleted then // Tolik 24/01/2019 -- на всякий begin // Selected if not F_MasterNewList.cbApplyForSelectedOnly.Checked then isApply := True else begin if CurrObject.Selected then isApply := True else isApply := False; end; // if isApply then begin if CurrObject.ConnectorType <> ct_Clear then begin if not HaveObjectCorkComponent(CurrObject.ID) then begin valDouble := UOMToMetre(StrToFloat_My(F_MasterNewList.edConnTotal.Text)); if aCADParams.CADHeightConns <> valDouble then begin if CurrObject.ActualZOrder[1] <> AConnHeight then // Tolik 21/12/2016 -- //ApplyParamsForObjects(CurrObject, AConnHeight); F_SCSObjectsProp.ChangeConnZ(CurrObject, AConnHeight); // TraceList := GetTraceList; // PutObjectOnHeight(CurrObject, AConnHeight, TraceList); // end; end; // Captions valBool := F_MasterNewList.cbShowConnectorsCaptions.Checked; if ((TCheckBoxState(F_MasterNewList.cbShowConnectorsCaptions.State) <> cbGrayed) and (aCADParams.CADShowConnObjectCaption <> valBool)) or (aCADParams.CADObjectCaptions <> AConnCaptionsShowType) then begin ObjParams := GetFigureParams(CurrObject.ID); CurrObject.Name := ObjParams.Name; CurrObject.FIndex := ObjParams.MarkID; SetConnNameInCaptionOnCAD(CurrObject); end; {====================================================================} // выноски valBool := F_MasterNewList.cbShowConnectorsNotes.Checked; if ((TCheckBoxState(F_MasterNewList.cbShowConnectorsNotes.State) <> cbGrayed) and (aCADParams.CADShowConnObjectNote <> valBool)) or ((aCADParams.CADObjectNotes <> AConnNotesShowType) or (aCADParams.CADLinesNotes <> ALineNotesShowType)) then begin NotesList := GetObjectNotesWithParams(CurrObject.ID); SetConnNotesInCAD(GCadForm.FCADListID, CurrObject.ID, NotesList); if NotesList <> nil then FreeAndNil(NotesList); end; {====================================================================} // цвет подписи к ТО valColor := F_MasterNewList.cbConnectorsCaptionsColor.ColorValue; if aCADParams.CADConnectorsCaptionsColor <> valColor then begin CurrObject.FCaptionsFontColor := valColor; CurrObject.ReCreateCaptionsGroup(True, True); end; // цвет выноски к ТО valColor := F_MasterNewList.cbConnectorsNotesColor.ColorValue; if aCADParams.CADConnectorsNotesColor <> valColor then begin CurrObject.FNotesFontColor := valColor; CurrObject.ReCreateNotesGroup(True); end; // размер шрифта подписи к ТО valInteger := StrToInt(F_MasterNewList.cbConnectorsCaptionsFontSize.Text); valString := F_MasterNewList.cbFontName.FontName; if (aCADParams.CADConnectorsCaptionsFontSize <> valInteger) then begin if CurrObject.FCaptionsFontSize <> valInteger then begin CurrObject.FCaptionsFontSize := valInteger; CurrObject.ReCreateCaptionsGroup(True, True); end; end else if (aCADParams.CADFontName <> valString) then begin if CurrObject.FCaptionsFontName <> valString then begin CurrObject.FCaptionsFontName := valString; CurrObject.ReCreateCaptionsGroup(True, True); end; end; // размер шрифта выноски к ТО valInteger := StrToInt(F_MasterNewList.cbConnectorsNotesFontSize.Text); valString := F_MasterNewList.cbFontName.FontName; if (aCADParams.CADConnectorsNotesFontSize <> valInteger) then begin if CurrObject.FNotesFontSize <> valInteger then begin CurrObject.FNotesFontSize := valInteger; CurrObject.ReCreateNotesGroup(True); end; end else if (aCADParams.CADFontName <> valString) then begin if CurrObject.FNotesFontName <> valString then begin CurrObject.FNotesFontName := valString; CurrObject.ReCreateNotesGroup(True); end; end; // отображение печати черно-белая/цветная if F_MasterNewList.cbBlackPrint.Checked then valPrintType := pt_Black; if F_MasterNewList.cbColorPrint.Checked then valPrintType := pt_Color; // размер и стиль шрифта для Кросс АТС if CurrObject.FTrunkName = ctsnCrossATS then begin valInteger := StrToInt(F_MasterNewList.cbCrossATSFontSize.Text); valBool := F_MasterNewList.cbCrossATSFontBold.Checked; if (aCADParams.CADCrossATSFontSize <> valInteger) or (aCADParams.CADCrossATSFontBold <> valBool) or (aCADParams.CADPrintType <> valPrintType) then begin CadCrossObject := GetPointObjectConnectedTrunk(GCadForm.FCADListID, CurrObject.ID); ChangeCrossATSInterf(GCadForm.FCADListID, CurrObject.ID, CadCrossObject); end; end; // размер шрифта для РШ if CurrObject.FTrunkName = ctsnDistributionCabinet then begin valInteger := StrToInt(F_MasterNewList.cbDistribCabFontSize.Text); valBool := F_MasterNewList.cbDistribCabFontBold.Checked; if (aCADParams.CADDistribCabFontSize <> valInteger) or (aCADParams.CADDistribCabFontBold <> valBool) or (aCADParams.CADPrintType <> valPrintType) then begin CadCrossObject := GetPointObjectConnectedTrunk(GCadForm.FCADListID, CurrObject.ID); ChangeDistribCabInterf(GCadForm.FCADListID, CurrObject.ID, CadCrossObject); end; end; end; end; end; end; for i := 0 to LinesList.Count - 1 do begin CurrTrace := TOrthoLine(LinesList[i]); if not CurrTrace.Deleted then // Tolik 24/01/2019 -- begin // Selected if not F_MasterNewList.cbApplyForSelectedOnly.Checked then isApply := True else begin if CurrTrace.Selected then isApply := True else isApply := False; end; // if isApply then begin valDouble := UOMToMetre(StrToFloat_My(F_MasterNewList.edLineTotal.Text)); if aCADParams.CADHeightLines <> valDouble then begin // Tolik 11/05/2016 -- УЧЕСТЬ ВЕРТИКАЛИ //if not CurrTrace.FIsRaiseUpDown then if ((not CurrTrace.FIsRaiseUpDown) and (not CurrTrace.FIsVertical)) then // begin if (CurrTrace.ActualZOrder[1] <> ALineHeight) or (CurrTrace.ActualZOrder[2] <> ALineHeight) then begin //Tolik -- 11/03/2016 -- // ищем элементы кабельного канала if CurrTrace.ActualZOrder[1] <> ALineHeight then begin if TConnectorObject(CurrTrace.JoinConnector1).ConnectorType = ct_NB then begin SCSComponent := F_ProjMan.GSCSBase.CurrProject.CurrList.GetComponentFromReferences(TConnectorObject(CurrTrace.JoinConnector1).ID); if SCSComponent <> nil then begin if SCSComponent.ComponentType.SysName = ctsnCableChannelElement then if CableChannelElements.IndexOf(TConnectorObject(CurrTrace.JoinConnector1)) = -1 then CableChannelElements.Add(TConnectorObject(CurrTrace.JoinConnector1)); end; end else if TConnectorObject(CurrTrace.JoinConnector1).ConnectorType = ct_Clear then begin for j := 0 to TConnectorObject(CurrTrace.JoinConnector1).JoinedConnectorsList.Count - 1 do begin if TConnectorObject(TConnectorObject(CurrTrace.JoinConnector1).JoinedConnectorsList[j]).ConnectorType = ct_NB then begin ConnCatalog := F_ProjMan.GSCSBase.CurrProject.CurrList.GetCatalogFromReferencesBySCSID(TConnectorObject(TConnectorObject(CurrTrace.JoinConnector1).JoinedConnectorsList[j]).ID); if ConnCatalog <> nil then begin for k := 0 to ConnCatalog.ComponentReferences.Count - 1 do begin SCSComponent := TSCSComponent(ConnCatalog.ComponentReferences[k]); if SCSComponent <> nil then begin if SCSComponent.ComponentType.SysName = ctsnCableChannelElement then if CableChannelElements.IndexOf(TConnectorObject(TConnectorObject(CurrTrace.JoinConnector1).JoinedConnectorsList[j])) = -1 then CableChannelElements.Add(TConnectorObject(TConnectorObject(CurrTrace.JoinConnector1).JoinedConnectorsList[j])); break; end; end; end; end; end; end; end; if CurrTrace.ActualZOrder[2] <> ALineHeight then begin if TConnectorObject(CurrTrace.JoinConnector2).ConnectorType = ct_NB then begin SCSComponent := F_ProjMan.GSCSBase.CurrProject.CurrList.GetComponentFromReferences(TConnectorObject(CurrTrace.JoinConnector2).ID); if SCSComponent <> nil then begin if SCSComponent.ComponentType.SysName = ctsnCableChannelElement then if CableChannelElements.IndexOf(TConnectorObject(CurrTrace.JoinConnector2)) = -1 then CableChannelElements.Add(TConnectorObject(CurrTrace.JoinConnector2)); end; end else if TConnectorObject(CurrTrace.JoinConnector2).ConnectorType = ct_Clear then begin for j := 0 to TConnectorObject(CurrTrace.JoinConnector2).JoinedConnectorsList.Count - 1 do begin if TConnectorObject(TConnectorObject(CurrTrace.JoinConnector2).JoinedConnectorsList[j]).ConnectorType = ct_NB then begin ConnCatalog := F_ProjMan.GSCSBase.CurrProject.CurrList.GetCatalogFromReferencesBySCSID(TConnectorObject(TConnectorObject(CurrTrace.JoinConnector2).JoinedConnectorsList[j]).ID); if ConnCatalog <> nil then begin for k := 0 to ConnCatalog.ComponentReferences.Count - 1 do begin SCSComponent := TSCSComponent(ConnCatalog.ComponentReferences[k]); if SCSComponent <> nil then begin if SCSComponent.ComponentType.SysName = ctsnCableChannelElement then if CableChannelElements.IndexOf(TConnectorObject(TConnectorObject(CurrTrace.JoinConnector2).JoinedConnectorsList[j])) = -1 then CableChannelElements.Add(TConnectorObject(TConnectorObject(CurrTrace.JoinConnector2).JoinedConnectorsList[j])); break; end; end; end; end; end; end; end; // Tolik //ApplyParamsForTraces(CurrTrace, ALineHeight, TracesList); CurrTrace.CalculLength := CurrTrace.LengthCalc; CurrTrace.LineLength := CurrTrace.CalculLength; CurrTrace.UpdateLengthTextBox(False, True); end; end; end; // так низзя - йобнется на определении райзов на коннекторах (потом, а вот какого х?...) //GCadForm.SelectTraces; {currTrace.Select; TFSCS_Main(F_ProjMan).RaiseSelectedLine(aLineHeight);} // подпись к трассе valBool := F_MasterNewList.cbShowLinesCaptions.Checked; if ((TCheckBoxState(F_MasterNewList.cbShowLinesCaptions.State) <> cbGrayed) and (aCADParams.CADShowLineObjectCaption <> valBool)) or (aCADParams.CADLinesCaptions <> ALineCaptionsShowType) then begin // вкинуть кол-во пар в OutTextCaptions[1] или убрать оттуда ReverseCaptionAfterTypeChange(CurrTrace, aCADParams.CADLinesCaptions, ALineCaptionsShowType); CurrTrace.UpdateLengthTextBox(True, True); end; {========================================================================} // выноска к трассе valBool := F_MasterNewList.cbShowLinesNotes.Checked; // WARNING !!! if ((TCheckBoxState(F_MasterNewList.cbShowLinesNotes.State) <> cbGrayed) and (aCADParams.CADShowLineObjectNote <> valBool)) or ((aCADParams.CADObjectNotes <> AConnNotesShowType) or (aCADParams.CADLinesNotes <> ALineNotesShowType)) then begin NotesList := GetObjectNotesWithParams(CurrTrace.ID); SetLineNotesInCAD(GCadForm.FCADListID, CurrTrace.ID, NotesList); if NotesList <> nil then FreeAndNil(NotesList); end; {========================================================================} if not CurrTrace.FIsRaiseUpDown then begin // цвет трассы valColor := F_MasterNewList.cbTraceColor.ColorValue; if aCADParams.CADTraceColor <> valColor then CurrTrace.FTraceColor := F_MasterNewList.cbTraceColor.ColorValue; // стиль трассы valInteger := F_MasterNewList.cbTraceStyle.ItemIndex; if ord(aCADParams.CADTraceStyle) <> valInteger then CurrTrace.FTraceStyle := TPenStyle(F_MasterNewList.cbTraceStyle.ItemIndex); // ширина трассы valInteger := StrToInt(F_MasterNewList.edTraceWidth.Text); if aCADParams.CADTraceWidth <> valInteger then CurrTrace.FTraceWidth := StrToInt(F_MasterNewList.edTraceWidth.Text); // шаг усл. обозначения valDouble := StrToFloat_My(F_MasterNewList.edBlockStep.Text); if aCADParams.CADBlockStep <> valDouble then begin if CurrTrace.BlockStep <> StrToFloat_My(F_MasterNewList.edBlockStep.Text) then begin CurrTrace.BlockStep := StrToFloat_My(F_MasterNewList.edBlockStep.Text); CurrTrace.ReCreateDrawFigureBlock; end; end; end; // Tolik -- 15/12/2015 -- добавлено все вкучу до к параметрам текста, чтобы два раза не пересоздавать CaptionsGroup // цвет подп/иси к трассе {valColor := F_MasterNewList.cbLinesCaptionsColor.ColorValue; if aCADParams.CADLinesCaptionsColor <> valColor then begin CurrTrace.FCaptionsFontColor := valColor; CurrTrace.ReCreateCaptionsGroup(True, True); end; // цвет выноски к трассе valColor := F_MasterNewList.cbLinesNotesColor.ColorValue; if aCADParams.CADLinesNotesColor <> valColor then begin CurrTrace.FNotesFontColor := valColor; CurrTrace.ReCreateNotesGroup(True); end; } // размер шрифта подписи к трассе valInteger := StrToInt(F_MasterNewList.cbLinesCaptionsFontSize.Text); valBool := F_MasterNewList.cbLinesCaptionsFontBold.Checked; valString := F_MasterNewList.cbFontName.FontName; // Tolik -- 15/12/2015 //!!! если поменять и наименование шрифта и размер или начертание, то не применится наименование шрифта // нужно поменять только то, что поменялось { if (aCADParams.CADLinesCaptionsFontSize <> valInteger) or (aCADParams.CADLinesCaptionsFontBold <> valBool) then begin if (CurrTrace.FCaptionsFontSize <> valInteger) or (CurrTrace.FCaptionsFontBold <> valBool) then begin CurrTrace.FCaptionsFontSize := valInteger; CurrTrace.FCaptionsFontBold := valBool; CurrTrace.ReCreateCaptionsGroup(True, True); end; end else if (aCADParams.CADFontName <> valString) then begin if CurrTrace.FCaptionsFontName <> valString then begin CurrTrace.FCaptionsFontName := valString; CurrTrace.ReCreateCaptionsGroup(True, True); end; end; } valColor := F_MasterNewList.cbLinesCaptionsColor.ColorValue; if (aCADParams.CADLinesCaptionsFontSize <> valInteger) or (aCADParams.CADLinesCaptionsFontBold <> valBool) or (aCADParams.CADFontName <> valString) or (aCADParams.CADLinesCaptionsColor <> valColor) then begin // получим размеры старого шрифта до изменения, чтобы потом, если выравнивание надписи - пользовательское, // можно было вернуть на адекватную позицию соответственно к величине изменения шрифта if CurrTrace.FCaptionsViewType <> cv_Center then // begin if ((CurrTrace.CaptionsGroup <> nil) and (CurrTrace.CaptionsGroup.InFigures.Count = 2)) then begin FontStyles := []; if CurrTrace.FCaptionsFontBold then FontStyles := [fsBold]; Captions := TRichTextMod(CurrTrace.CaptionsGroup.InFigures[1]); GetTextSizeCapt(CurrTrace.FCaptionsFontSize, FontStyles, CurrTrace.FCaptionsFontName, '', Captions.re.Lines, OldCaptH, OldCaptW); end; end; if aCADParams.CADLinesCaptionsFontSize <> valInteger then CurrTrace.FCaptionsFontSize := valInteger; if aCADParams.CADLinesCaptionsFontBold <> valBool then CurrTrace.FCaptionsFontBold := valBool; if aCADParams.CADFontName <> valString then CurrTrace.FCaptionsFontName := valString; if aCADParams.CADLinesCaptionsColor <> valColor then CurrTrace.FCaptionsFontColor := valColor; if CurrTrace.FCaptionsViewType <> cv_Center then CurrTrace.ReCreateCaptionsGroup(True, True, nil, OldCaptH, OldCaptW) else CurrTrace.ReCreateCaptionsGroup(True, True); end; // // размер шрифта выноски к трассе valInteger := StrToInt(F_MasterNewList.cbLinesNotesFontSize.Text); valString := F_MasterNewList.cbFontName.FontName; // Tolik 15/12/2015 -- та же херня, что и с подписью к линии {if (aCADParams.CADLinesNotesFontSize <> valInteger) then begin if CurrTrace.FNotesFontSize <> valInteger then begin CurrTrace.FNotesFontSize := valInteger; CurrTrace.ReCreateNotesGroup(True); end; end else if (aCADParams.CADFontName <> valString) then begin if CurrTrace.FNotesFontName <> valString then begin CurrTrace.FNotesFontName := valString; CurrTrace.ReCreateNotesGroup(True); end; end;} // цвет выноски к трассе valColor := F_MasterNewList.cbLinesNotesColor.ColorValue; if (aCADParams.CADLinesNotesFontSize <> valInteger) or (aCADParams.CADFontName <> valString) or (aCADParams.CADLinesNotesColor <> valColor) then begin if aCADParams.CADLinesNotesFontSize <> valInteger then CurrTrace.FNotesFontSize := valInteger; if aCADParams.CADFontName <> valString then CurrTrace.FNotesFontName := valString; if aCADParams.CADLinesNotesColor <> valColor then CurrTrace.FNotesFontColor := valColor; CurrTrace.ReCreateNotesGroup(True); end; // end; end; end; // Tolik 08/10/2016 -- if aCADParams.CADHeightLines <> aLineHeight then begin if ((LinesList.Count > 0) and isApply) then begin GCadForm.SelectTraces; TFSCS_Main(F_ProjMan).RaiseSelectedLine(aLineHeight); end; // Tolik -- 11/03/2016 -- // поднимаем элементы кабельного канала на высоту трасс for i := 0 to CableChannelElements.Count - 1 do begin //TConnectorObject(CableChannelElements[i]).ActualZOrder[1] := ALineHeight; if not TConnectorObject(CableChannelElements[i]).Deleted then // Tolik 24/01/2019 -- ChangeConnZ(TConnectorObject(CableChannelElements[i]), ALineHeight); end; FreeAndNil(CableChannelElements); end; // {**************************************************************************} if TracesList <> nil then FreeAndNil(TracesList); if LinesList <> nil then FreeAndNil(LinesList); if ConnsList <> nil then FreeAndNil(ConnsList); if CableChannelElements <> nil then // Tolik 14/05/2018 -- FreeAndNil(CableChannelElements); // создание листа if F_MasterNewList.Tag = 0 then SaveMaskTemplatesFromForm(F_MasterNewList.F_ComponTypesMarkMask, GCadForm.FCADListID, itList, True, True) // редактирование листа else SaveMaskTemplatesFromForm(F_MasterNewList.F_ComponTypesMarkMask, GCadForm.FCADListID, itList, True, False); // Tolik -- 11/11/2016 -- на всякмй GCadForm.PCad.DeselectAll(2); // GCanRefreshCad := GCanRefreshFlag; // Tolik 24/01/2019 -- RefreshCAD(GCadForm.PCad); // SP !!! CheckDeleteAllRaises(GCadForm.PCad); except on E: Exception do begin GCanRefreshCad := GCanRefreshFlag; addExceptionToLogEx('U_Common.ApplyParamsForAllSCSObject', E.Message); end; end; EndProgress; end; Procedure ApplyParamsForObjects(AObject: TConnectorObject; AHeight: Double); begin BaseBeginUpdate; try // нет с-п if GetRaiseConn(AObject) = nil then begin if AObject.JoinedConnectorsList.Count = 0 then begin AObject.ActualZOrder[1] := AHeight; SetConFigureCoordZInPM(AObject.ID, AHeight); end else CreateRaiseOnPointObject(AObject, AHeight); end // есть с-п else // сдвинуть на высоту begin // только подъем-спуск if AObject.JoinedConnectorsList.Count = 0 then begin AObject.ActualZOrder[1] := AHeight; SetConFigureCoordZInPM(AObject.ID, AHeight); end else ChangeRaiseOnPointObject(AObject, AHeight); end; except on E: Exception do addExceptionToLogEx('U_Common.ApplyParamsForObjects', E.Message); end; BaseEndUpdate; end; Procedure ApplyParamsForTraces(ATrace: TOrthoLine; AHeight: Double; ATracesList: TList); begin BaseBeginUpdate; try RaiseLineOnHeight(ATrace, AHeight, ATracesList); except on E: Exception do addExceptionToLogEx('U_Common.ApplyParamsForTraces', E.Message); end; BaseEndUpdate; end; Procedure ApplyCornerTypeForConnectors(aCornerType: TCornerType); var i: integer; FConnector: TConnectorObject; isApply: Boolean; begin try //Tolik -- 28/06/2016 -- //for i := 0 to GCadForm.PCad.FigureCount - 1 do for i := 0 to GCadForm.FSCSFigures.Count - 1 do begin // Tolik -- 28/06/2016 -- // if CheckFigureByClassName(TFigure(GCadForm.PCad.Figures[i]), cTConnectorObject) then if CheckFigureByClassName(TFigure(GCadForm.FSCSFigures[i]), cTConnectorObject) then begin // Tolik -- 28/6/2016 -- // FConnector := TConnectorObject(GCadForm.PCad.Figures[i]); FConnector := TConnectorObject(GCadForm.FSCSFigures[i]); // Selected if not F_MasterNewList.cbApplyForSelectedOnly.Checked then isApply := True else begin if FConnector.Selected then isApply := True else isApply := False; end; // if isApply then begin if CheckCornerTypeMaybeChanged(FConnector, aCornerType) then FConnector.FCornerType := aCornerType; end; end; end; except on E: Exception do addExceptionToLogEx('U_Common.ApplyCornerTypeForConnectors', E.Message); end; end; Function CheckCornertypeMaybeChanged(aConnector: TConnectorObject; aCornerType: TCornerType): Boolean; var i, j: Integer; JoinedConn1: TConnectorObject; JoinedConn2: TConnectorObject; JoinedLine1: TOrthoLine; JoinedLine2: TOrthoLine; Angle: Double; begin Result := False; try // НЕТ if aCornerType = crn_None then begin { if aConnector.ConnectorType = ct_Clear then begin if (aConnector.JoinedOrtholinesList.Count = 0) and (aConnector.JoinedOrtholinesList.Count = 1) or (aConnector.JoinedOrtholinesList.Count = 3) then Result := True; end else begin if (aConnector.JoinedConnectorsList.Count = 0) or (aConnector.JoinedConnectorsList.Count = 1) or (aConnector.JoinedConnectorsList.Count = 3) then Result := True; end; } Result := True; end; // ВНЕШНИЙ или ВНУТРЕННИЙ if (aCornerType = crn_Out) or (aCornerType = crn_In) then begin if (aConnector.FConnRaiseType = crt_None) and (GetRaiseConn(aConnector) = nil) then begin if aConnector.ConnectorType = ct_Clear then begin if aConnector.JoinedOrtholinesList.Count = 2 then begin JoinedLine1 := TOrthoLine(aConnector.JoinedOrtholinesList[0]); JoinedLine2 := TOrthoLine(aConnector.JoinedOrtholinesList[1]); if not JoinedLine1.FIsRaiseUpDown and not JoinedLine2.FIsRaiseUpDown then begin Angle := CalcAngleBetweenLines(JoinedLine1, JoinedLine2, aConnector); if (Angle <> 0) and (Angle <> 180) and (Angle <> 360) then Result := True; end; end; end else begin if aConnector.JoinedConnectorsList.Count = 2 then begin JoinedConn1 := TConnectorObject(aConnector.JoinedConnectorsList[0]); JoinedConn2 := TConnectorObject(aConnector.JoinedConnectorsList[1]); if (JoinedConn1.JoinedOrtholinesList.Count = 1) and (JoinedConn2.JoinedOrtholinesList.Count = 1) then begin JoinedLine1 := TOrthoLine(JoinedConn1.JoinedOrtholinesList[0]); JoinedLine2 := TOrthoLine(JoinedConn2.JoinedOrtholinesList[0]); if not JoinedLine1.FIsRaiseUpDown and not JoinedLine2.FIsRaiseUpDown then begin Angle := CalcAngleBetweenLines(JoinedLine1, JoinedLine2, aConnector); if (Angle <> 0) and (Angle <> 180) and (Angle <> 360) then Result := True; end; end; end; end; end; end; // ПЛОСКИЙ if aCornerType = crn_Vertical then begin if (aConnector.FConnRaiseType <> crt_None) or (GetRaiseConn(aConnector) <> nil) then begin if aConnector.ConnectorType = ct_Clear then begin if aConnector.JoinedOrtholinesList.Count = 2 then begin JoinedLine1 := TOrthoLine(aConnector.JoinedOrtholinesList[0]); JoinedLine2 := TOrthoLine(aConnector.JoinedOrtholinesList[1]); if JoinedLine1.FIsRaiseUpDown or JoinedLine2.FIsRaiseUpDown then begin Result := True; end; end; end else begin if aConnector.JoinedConnectorsList.Count = 2 then begin JoinedConn1 := TConnectorObject(aConnector.JoinedConnectorsList[0]); JoinedConn2 := TConnectorObject(aConnector.JoinedConnectorsList[1]); if (JoinedConn1.JoinedOrtholinesList.Count = 1) and (JoinedConn2.JoinedOrtholinesList.Count = 1) then begin JoinedLine1 := TOrthoLine(JoinedConn1.JoinedOrtholinesList[0]); JoinedLine2 := TOrthoLine(JoinedConn2.JoinedOrtholinesList[0]); if JoinedLine1.FIsRaiseUpDown or JoinedLine2.FIsRaiseUpDown then begin Result := True; end; end; end; end; end; end; // АДАПТЕР if aCornerType = crn_Adapter then begin if (aConnector.FConnRaiseType = crt_None) and (GetRaiseConn(aConnector) = nil) then begin if aConnector.ConnectorType = ct_Clear then begin if aConnector.JoinedOrtholinesList.Count = 2 then begin JoinedLine1 := TOrthoLine(aConnector.JoinedOrtholinesList[0]); JoinedLine2 := TOrthoLine(aConnector.JoinedOrtholinesList[1]); if not JoinedLine1.FIsRaiseUpDown and not JoinedLine2.FIsRaiseUpDown then begin Angle := CalcAngleBetweenLines(JoinedLine1, JoinedLine2, aConnector); if Angle = 180 then Result := True; end; end; end else begin if aConnector.JoinedConnectorsList.Count = 2 then begin JoinedConn1 := TConnectorObject(aConnector.JoinedConnectorsList[0]); JoinedConn2 := TConnectorObject(aConnector.JoinedConnectorsList[1]); if (JoinedConn1.JoinedOrtholinesList.Count = 1) and (JoinedConn2.JoinedOrtholinesList.Count = 1) then begin JoinedLine1 := TOrthoLine(JoinedConn1.JoinedOrtholinesList[0]); JoinedLine2 := TOrthoLine(JoinedConn2.JoinedOrtholinesList[0]); if not JoinedLine1.FIsRaiseUpDown and not JoinedLine2.FIsRaiseUpDown then begin Angle := CalcAngleBetweenLines(JoinedLine1, JoinedLine2, aConnector); if Angle = 180 then Result := True; end; end; end; end; end; end; except on E: Exception do addExceptionToLogEx('U_Common.CheckCornertypeMaybeChanged', E.Message); end; end; function GetAngleBetweenLines(AListID, AIDLine1, AIDLine2, AIDConnector: Integer; aAngleType: TAngleType): Double; var vList: TF_CAD; vLine1, vLine2: TOrthoLine; vConn: TConnectorObject; begin Result := 0; try vList := GetListByID(AListID); if vList <> nil then begin vLine1 := TOrthoLine(GetFigureByID(vList, AIDLine1)); vLine2 := TOrthoLine(GetFigureByID(vList, AIDLine2)); vConn := TConnectorObject(GetFigureByID(vList, AIDConnector)); if (vLine1 <> nil) and (vLine2 <> nil) and (vConn <> nil) then Result := CalcAngleBetweenLines(vLine1, vLine2, vConn); end; except on E: Exception do AddExceptionToLogEx('U_Common.GetAngleBetweenLines', E.Message); end; end; Function CalcAngleBetweenLines(aLine1, aLine2: TOrthoLine; aConnector: TConnectorObject): Double; var i, j: integer; JoinedConn: TConnectorObject; JoinedLine: TOrthoLine; Angle1, Angle2: Double; begin Result := 0; try Angle1 := 0; Angle2 := 0; if aConnector.ConnectorType = ct_Clear then begin if aLine1.JoinConnector1 = aConnector then Angle1 := GetLineAngle(aLine1.ActualPoints[1], aLine1.ActualPoints[2]); if aLine1.JoinConnector2 = aConnector then Angle1 := GetLineAngle(aLine1.ActualPoints[2], aLine1.ActualPoints[1]); if aLine2.JoinConnector1 = aConnector then Angle2 := GetLineAngle(aLine2.ActualPoints[1], aLine2.ActualPoints[2]); if aLine2.JoinConnector2 = aConnector then Angle2 := GetLineAngle(aLine2.ActualPoints[2], aLine2.ActualPoints[1]); end else begin for i := 0 to aConnector.JoinedConnectorsList.Count - 1 do begin JoinedConn := TConnectorObject(aConnector.JoinedConnectorsList[i]); for j := 0 to JoinedConn.JoinedOrtholinesList.Count - 1 do begin JoinedLine := TOrthoLine(JoinedConn.JoinedOrtholinesList[j]); if JoinedLine = aLine1 then begin if aLine1.JoinConnector1 = JoinedConn then Angle1 := GetLineAngle(aLine1.ActualPoints[1], aLine1.ActualPoints[2]); if aLine1.JoinConnector2 = JoinedConn then Angle1 := GetLineAngle(aLine1.ActualPoints[2], aLine1.ActualPoints[1]); end; if JoinedLine = aLine2 then begin if aLine2.JoinConnector1 = JoinedConn then Angle2 := GetLineAngle(aLine2.ActualPoints[1], aLine2.ActualPoints[2]); if aLine2.JoinConnector2 = JoinedConn then Angle2 := GetLineAngle(aLine2.ActualPoints[2], aLine2.ActualPoints[1]); end; end; end; end; Result := abs(Angle1 - Angle2); if Result > 180 then Result := 360 - Result; except on E: Exception do addExceptionToLogEx('U.Common.CalcAngleBetweenLines', E.Message); end; end; Function GetCheckedCornerType(aConnector: TConnectorObject): TCornerType; var i, j: integer; Angle: Double; CornerType: TCornerType; JoinedConn1: TConnectorObject; JoinedConn2: TConnectorObject; JoinedLine1: TOrthoLine; JoinedLine2: TOrthoLine; begin Result := crn_None; //#From Oleg# //14.09.2010 try CornerType := aConnector.FCornerType; Result := CornerType; // CLEAR if aConnector.ConnectorType = ct_Clear then begin // crn_None if (aConnector.JoinedOrtholinesList.Count = 0) or (aConnector.JoinedOrtholinesList.Count = 1) or (aConnector.JoinedOrtholinesList.Count = 3) then CornerType := crn_None; if aConnector.JoinedOrtholinesList.Count = 2 then begin JoinedLine1 := TOrthoLine(aConnector.JoinedOrtholinesList[0]); JoinedLine2 := TOrthoLine(aConnector.JoinedOrtholinesList[1]); // crn_Vertical if JoinedLine1.FIsRaiseUpDown or JoinedLine2.FIsRaiseUpDown then begin CornerType := crn_Vertical; end else begin Angle := CalcAngleBetweenLines(JoinedLine1, JoinedLine2, aConnector); // crn_Adapter if Angle = 180 then begin CornerType := crn_Adapter; end else // crn_Out, crn_In if (Angle <> 0) and (Angle <> 180) and (Angle <> 360) then begin if (CornerType <> crn_Out) and (CornerType <> crn_In) then begin // if GCadForm.FDefaultCornerType <> crn_None then // CornerType := crn_Out; end; end; end; end; end else // RT begin // crn_None if (aConnector.JoinedConnectorsList.Count = 0) or (aConnector.JoinedConnectorsList.Count = 1) or (aConnector.JoinedConnectorsList.Count = 3) then CornerType := crn_None; if aConnector.JoinedConnectorsList.Count = 2 then begin JoinedConn1 := TConnectorObject(aConnector.JoinedConnectorsList[0]); JoinedConn2 := TConnectorObject(aConnector.JoinedConnectorsList[1]); if (JoinedConn1.JoinedOrtholinesList.Count = 1) and (JoinedConn2.JoinedConnectorsList.Count = 1) then begin JoinedLine1 := TOrthoLine(JoinedConn1.JoinedOrtholinesList[0]); JoinedLine2 := TOrthoLine(JoinedConn2.JoinedOrtholinesList[0]); // crn_Vertical if JoinedLine1.FIsRaiseUpDown or JoinedLine2.FIsRaiseUpDown then begin CornerType := crn_Vertical; end else begin Angle := CalcAngleBetweenLines(JoinedLine1, JoinedLine2, aConnector); // crn_Adapter if Angle = 180 then begin CornerType := crn_Adapter; end else // crn_Out, crn_In if (Angle <> 0) and (Angle <> 180) and (Angle <> 360) then begin if (CornerType <> crn_Out) and (CornerType <> crn_In) then begin if GCadForm.FDefaultCornerType <> crn_None then CornerType := crn_Out; end; end; end; end; end; end; if aConnector.FCornerType <> CornerType then begin aConnector.FCornerType := CornerType; Result := CornerType; end; except on E: Exception do addExceptionToLogEx('U_Common.GetCheckedCornerType', E.Message); end; end; Function GetCornerTypeByConnectorID(AID_List, AID_Object: Integer): TCornerType; var FList: TF_CAD; FFigure: TFigure; begin Result := crn_None; //#From Oleg# //14.09.2010 try Result := GCadForm.FDefaultCornerType; FList := GetListByID(AID_List); if FList <> nil then begin FFigure := GetFigureByID(FList, AID_Object); if FFigure <> nil then if CheckFigureByClassName(FFigure, cTConnectorObject) then begin if TConnectorObject(FFigure).FCornerTypeChangedByUser then Result := TConnectorObject(FFigure).FCornerType else Result := GetCheckedCornerType(TConnectorObject(FFigure)); end; end; except on E: Exception do addExceptionToLogEx('U_Common.GetCornerTypeByConnectorID', E.Message); end; end; Procedure SetCornerTypeByConnectorID(AID_List, AID_Object: Integer; ACornerType: TCornerType); var FList: TF_CAD; FFigure: TFigure; begin try FList := GetListByID(AID_List); if FList <> nil then begin FFigure := GetFigureByID(FList, AID_Object); if FFigure <> nil then if CheckFigureByClassName(FFigure, cTConnectorObject) then TConnectorObject(FFigure).FCornerType := ACornerType; end; except on E: Exception do addExceptionToLogEx('U_Common.SetCornerTypeByConnectorID', E.Message); end; end; Procedure GetSidesByConnectedFigures(AID_List1, AID_List2, AID_Figure1, AID_Figure2: Integer; var Side1: Integer; var Side2: Integer); var PointObject: TConnectorObject; JoinedConn: TConnectorObject; JoinedLine: TOrthoLine; i, j, k: integer; CurrList: TF_CAD; Obj1, Obj2: TFigure; List1, List2: TF_CAD; Floor1Conn1, Floor1Conn2, Floor2Conn1, Floor2Conn2: TConnectorObject; House: THouse; Approach: TConnectorObject; begin try Side1 := -1; Side2 := -1; List1 := GetListByID(AID_List1); List2 := GetListByID(AID_List2); if (List1 = nil) or (List2 = nil) then Exit; Obj1 := GetFigureByID(List1, AID_Figure1); Obj2 := GetFigureByID(List2, AID_Figure2); // если не найдено, то может это дом if Obj1 = nil then Obj1 := GetHouseByID(List1, AID_Figure1); if Obj2 = nil then Obj2 := GetHouseByID(List2, AID_Figure2); if (Obj1 = nil) or (Obj2 = nil) then Exit; // оба коннекторы if CheckFigureByClassName(Obj1, cTConnectorObject) and CheckFigureByClassName(Obj2, cTConnectorObject) then begin Side1 := 0; Side2 := 0; end // 1-ортолиния, 2-коннектор else if CheckFigureByClassName(Obj1, cTOrthoLine) and CheckFigureByClassName(Obj2, cTConnectorObject) then begin Side2 := 0; // Side = 1 if TConnectorObject(TOrthoLine(Obj1).JoinConnector1) = Obj2 then Side1 := 1; if TConnectorObject(TOrthoLine(Obj1).JoinConnector2) = Obj2 then Side1 := 2; begin if TConnectorObject(TOrthoLine(Obj1).JoinConnector1).JoinedConnectorsList.Count > 0 then if TConnectorObject(TOrthoLine(Obj1).JoinConnector1).JoinedConnectorsList[0] = Obj2 then Side1 := 1; if TConnectorObject(TOrthoLine(Obj1).JoinConnector2).JoinedConnectorsList.Count > 0 then if TConnectorObject(TOrthoLine(Obj1).JoinConnector2).JoinedConnectorsList[0] = Obj2 then Side1 := 2; end; end // 1-коннектор, 2-ортолиния else if CheckFigureByClassName(Obj1, cTConnectorObject) and CheckFigureByClassName(Obj2, cTOrthoLine) then begin Side1 := 0; if TConnectorObject(TOrthoLine(Obj2).JoinConnector1) = Obj1 then Side2 := 1; if TConnectorObject(TOrthoLine(Obj2).JoinConnector2) = Obj1 then Side2 := 2; begin if TConnectorObject(TOrthoLine(Obj2).JoinConnector1).JoinedConnectorsList.Count > 0 then if TConnectorObject(TOrthoLine(Obj2).JoinConnector1).JoinedConnectorsList[0] = Obj1 then Side2 := 1; if TConnectorObject(TOrthoLine(Obj2).JoinConnector2).JoinedConnectorsList.Count > 0 then if TConnectorObject(TOrthoLine(Obj2).JoinConnector2).JoinedConnectorsList[0] = Obj1 then Side2 := 2; end; end // 1-ортолиния, 2-ортолиния else if CheckFigureByClassName(Obj1, cTOrthoLine) and CheckFigureByClassName(Obj2, cTOrthoLine) then begin // на одном КАДе if TOrthoLine(Obj1).JoinConnector1 = TOrthoLine(Obj2).JoinConnector1 then begin Side1 := 1; Side2 := 1; end; if TOrthoLine(Obj1).JoinConnector1 = TOrthoLine(Obj2).JoinConnector2 then begin Side1 := 1; Side2 := 2; end; if TOrthoLine(Obj1).JoinConnector2 = TOrthoLine(Obj2).JoinConnector1 then begin Side1 := 2; Side2 := 1; end; if TOrthoLine(Obj1).JoinConnector2 = TOrthoLine(Obj2).JoinConnector2 then begin Side1 := 2; Side2 := 2; end; if (Side1 = -1) or (Side2 = -1) then begin if TConnectorObject(TOrthoLine(Obj1).JoinConnector1).JoinedConnectorsList.count > 0 then begin PointObject := TConnectorObject(TConnectorObject(TOrthoLine(Obj1).JoinConnector1).JoinedConnectorsList[0]); for i := 0 to PointObject.JoinedConnectorsList.Count - 1 do begin JoinedConn := TConnectorObject(PointObject.JoinedConnectorsList[i]); for j := 0 to JoinedConn.JoinedOrtholinesList.Count - 1 do begin if TOrthoLine(JoinedConn.JoinedOrtholinesList[j]) = TOrthoLine(Obj2) then begin Side1 := 1; if TOrthoLine(Obj2).JoinConnector1 = JoinedConn then Side2 := 1; if TOrthoLine(Obj2).JoinConnector2 = JoinedConn then Side2 := 2; end; end; end; end; if TConnectorObject(TOrthoLine(Obj1).JoinConnector2).JoinedConnectorsList.count > 0 then begin PointObject := TConnectorObject(TConnectorObject(TOrthoLine(Obj1).JoinConnector2).JoinedConnectorsList[0]); for i := 0 to PointObject.JoinedConnectorsList.Count - 1 do begin JoinedConn := TConnectorObject(PointObject.JoinedConnectorsList[i]); for j := 0 to JoinedConn.JoinedOrtholinesList.Count - 1 do begin if TOrthoLine(JoinedConn.JoinedOrtholinesList[j]) = TOrthoLine(Obj2) then begin Side1 := 2; if TOrthoLine(Obj2).JoinConnector1 = JoinedConn then Side2 := 1; if TOrthoLine(Obj2).JoinConnector2 = JoinedConn then Side2 := 2; end; end; end; end; end; // с учетом межэтажных переходов Floor1Conn1 := TConnectorObject(TOrthoLine(Obj1).JoinConnector1); Floor1Conn2 := TConnectorObject(TOrthoLine(Obj1).JoinConnector2); Floor2Conn1 := TConnectorObject(TOrthoLine(Obj2).JoinConnector1); Floor2Conn2 := TConnectorObject(TOrthoLine(Obj2).JoinConnector2); if (Floor1Conn1.FID_ConnToPassage = Floor2Conn1.ID) and (Floor1Conn1.ID = Floor2Conn1.FID_ConnToPassage) then begin Side1 := 1; Side2 := 1; end; if (Floor1Conn1.FID_ConnToPassage = Floor2Conn2.ID) and (Floor1Conn1.ID = Floor2Conn2.FID_ConnToPassage) then begin Side1 := 1; Side2 := 2; end; if (Floor1Conn2.FID_ConnToPassage = Floor2Conn1.ID) and (Floor1Conn2.ID = Floor2Conn1.FID_ConnToPassage) then begin Side1 := 2; Side2 := 1; end; if (Floor1Conn2.FID_ConnToPassage = Floor2Conn2.ID) and (Floor1Conn2.ID = Floor2Conn2.FID_ConnToPassage) then begin Side1 := 2; Side2 := 2; end; end; // 1-ортолиния, 2-дом if CheckFigureByClassName(Obj1, cTOrthoLine) and CheckFigureByClassName(Obj2, cTHouse) then begin Side2 := 0; JoinedConn := TConnectorObject(TOrthoLine(Obj1).JoinConnector1); if JoinedConn.FIsHouseJoined then if JoinedConn.FHouse = Obj2 then Side1 := 1; JoinedConn := TConnectorObject(TOrthoLine(Obj1).JoinConnector2); if JoinedConn.FIsHouseJoined then if JoinedConn.FHouse = Obj2 then Side1 := 2; if Side1 = -1 then begin House := Thouse(Obj2); for i := 0 to House.fApproaches.Count - 1 do begin Approach := TConnectorObject(House.fApproaches[i]); if Approach.JoinedConnectorsList.Count > 0 then begin //if Approach.JoinedConnectorsList[0] = TOrthoLine(Obj1).JoinConnector1 then // Side1 := 1; //if Approach.JoinedConnectorsList[0] = TOrthoLine(Obj1).JoinConnector2 then // Side1 := 2; //03.12.2010 for j := 0 to Approach.JoinedConnectorsList.Count - 1 do begin if Approach.JoinedConnectorsList[j] = TOrthoLine(Obj1).JoinConnector1 then Side1 := 1; if Approach.JoinedConnectorsList[j] = TOrthoLine(Obj1).JoinConnector2 then Side1 := 2; end; end; end; end; end // 1-дом, 2-ортолиния else if CheckFigureByClassName(Obj1, cTHouse) and CheckFigureByClassName(Obj2, cTOrthoLine) then begin Side1 := 0; JoinedConn := TConnectorObject(TOrthoLine(Obj2).JoinConnector1); if JoinedConn.FIsHouseJoined then if JoinedConn.FHouse = Obj1 then Side2 := 1; JoinedConn := TConnectorObject(TOrthoLine(Obj2).JoinConnector2); if JoinedConn.FIsHouseJoined then if JoinedConn.FHouse = Obj1 then Side2 := 2; if Side2 = -1 then begin House := Thouse(Obj1); for i := 0 to House.fApproaches.Count - 1 do begin Approach := TConnectorObject(House.fApproaches[i]); if Approach.JoinedConnectorsList.Count > 0 then begin //if Approach.JoinedConnectorsList[0] = TOrthoLine(Obj2).JoinConnector1 then // Side2 := 1; //if Approach.JoinedConnectorsList[0] = TOrthoLine(Obj2).JoinConnector2 then // Side2 := 2; //03.12.2010 for j := 0 to Approach.JoinedConnectorsList.Count - 1 do begin if Approach.JoinedConnectorsList[j] = TOrthoLine(Obj2).JoinConnector1 then Side2 := 1; if Approach.JoinedConnectorsList[j] = TOrthoLine(Obj2).JoinConnector2 then Side2 := 2; end; end; end; end; end; except on E: Exception do addExceptionToLogEx('U_Common.GetSidesByConnectedFigures', E.Message); end; end; Procedure GetLineFigureHeghts(AID_List, AID_Line: Integer; var AHeight1: Double; var AHeight2: Double); var CurLine: TOrthoLine; vList: TF_CAD; begin try AHeight1 := -1; AHeight2 := -1; vList := GetListByID(AID_List); if vList <> nil then begin CurLine := TOrthoLine(GetFigureByID(vList, AID_Line)); if CurLine <> nil then begin AHeight1 := CurLine.ActualZOrder[1]; AHeight2 := CurLine.ActualZOrder[2]; end; end; except on E: Exception do addExceptionToLogEx('U_Common.GetLineFigureHeghts', E.Message); end; end; procedure UpdateForLayers; var i: integer; ShowLayer: TLayer; CurrentFigure: TFigure; begin try // отображение подписей к ортолиниям по умолчанию if GCadForm.FShowLinesCaptions = True then begin ShowLayer := GCadForm.Pcad.Layers.Items[3]; ShowLayer.visible := seen; end else begin ShowLayer := GCadForm.Pcad.Layers.Items[3]; ShowLayer.visible := lost; end; // отображение подписей к коннекторам по умолчанию if GCadForm.FShowConnectorsCaptions = True then begin ShowLayer := GCadForm.Pcad.Layers.Items[4]; ShowLayer.visible := seen; end else begin ShowLayer := GCadForm.Pcad.Layers.Items[4]; ShowLayer.visible := lost; end; // отображение выносок к ортолиниям по умолчанию if GCadForm.FShowLinesNotes = True then begin ShowLayer := GCadForm.Pcad.Layers.Items[5]; ShowLayer.visible := seen; end else begin ShowLayer := GCadForm.Pcad.Layers.Items[5]; ShowLayer.visible := lost; end; // отображение выносок к коннекторам по умолчанию if GCadForm.FShowConnectorsNotes = True then begin ShowLayer := GCadForm.Pcad.Layers.Items[6]; ShowLayer.visible := seen; end else begin ShowLayer := GCadForm.Pcad.Layers.Items[6]; ShowLayer.visible := lost; end; // Обновить !!! if F_LayersDialog.Showing then F_LayersDialog.UpdateLayersList; // отображать длины ортолиний по умолчанию if GCadForm.FShowLinesLength = True then begin for i := 0 to GCadForm.PCad.Figures.Count - 1 do begin CurrentFigure := TFigure(GCadForm.PCad.Figures[i]); end; end; if GCadForm.FShowLinesLength = False then begin for i := 0 to GCadForm.PCad.Figures.Count - 1 do begin CurrentFigure := TFigure(GCadForm.PCad.Figures[i]); end; end; if GCadForm.FAutoSelectTrace = True then FSCS_Main.aAutoSelectTrace.Checked := True; if GCadForm.FAutoSelectTrace = False then FSCS_Main.aAutoSelectTrace.Checked := False; RefreshCAD(GCadForm.PCad); except on E: Exception do addExceptionToLogEx('U_Common.UpdateForLayers', E.Message); end; end; Procedure RefreshAllLists; var i: integer; CurCAD: TF_CAD; begin try for i := 0 to FSCS_Main.MDIChildCount - 1 do begin CurCAD := TF_CAD(FSCS_Main.MDIChildren[i]); //Tolik 07/11/2015 // не дать обновиться Каду, на котором сейчас происходят какие-либо действия (удаление, дубли фигур и т.п.) if not CurCAD.inGuiEvent then RefreshCAD(CurCAD.PCad); end; except on E: Exception do addExceptionToLogEx('U_Common.RefreshAllLists', E.Message); end; end; Procedure SetNetworkTypesForObject(AID_List, AID_Object: Integer; ANetworkTypes: TObjectNetworkTypes); var CurObject: TFigure; vList: TF_CAD; begin try vList := GetListByID(AID_List); if vList <> nil then begin CurObject := GetFigureByID(vList, AID_Object); if CheckFigureByClassName(CurObject, cTConnectorObject) then begin TConnectorObject(CurObject).FNetworkTypes := ANetworkTypes; if Assigned(TConnectorObject(CurObject).DrawFigure) then TConnectorObject(CurObject).DrawFigure.FNetworkTypes := ANetworkTypes else addExceptionToLogEx('U_Common.SetNetworkTypesForObject', 'DrawFigure = nil'); end else if CheckFigureByClassName(CurObject, cTOrthoLine) then begin TOrthoLine(CurObject).FNetworkTypes := ANetworkTypes; end; end; except on E: Exception do addExceptionToLogEx('U_Common.SetNetworkTypesForObject', E.Message); end; end; Function IsViewObjectInCurrentNetwork(AObject: TFigure): Boolean; var i: integer; JoinedLine: TOrthoLine; NetTypes: TObjectNetworkTypes; begin Result := False; try if (nt_All in GCadForm.FShowNetworkTypes) then Result := True else begin NetTypes := []; if CheckFigureByClassName(AObject, cTConnectorObject) then NetTypes := TConnectorObject(AObject).FNetworkTypes else if CheckFigureByClassName(AObject, cTOrthoLine) then NetTypes := TOrthoLine(AObject).FNetworkTypes else if CheckFigureByClassName(AObject, cTFigureGrpMod) then NetTypes := TFigureGrpMod(AObject).FNetworkTypes; if (nt_Computer in GCadForm.FShowNetworkTypes) and (nt_Computer in NetTypes) then result := True; if (nt_Telephon in GCadForm.FShowNetworkTypes) and (nt_Telephon in NetTypes) then result := True; if (nt_Electric in GCadForm.FShowNetworkTypes) and (nt_Electric in NetTypes) then result := True; if (nt_Television in GCadForm.FShowNetworkTypes) and (nt_Television in NetTypes) then result := True; if (nt_Gas in GCadForm.FShowNetworkTypes) and (nt_Gas in NetTypes) then result := True; // Tolik 16/04/2020 -- чтобы правильно отрисовались райзы(символы с/п) по типам сетей if not Result then if CheckFigureByClassName(AObject, cTConnectorObject) then if TConnectorObject(aObject).ConnectorType <> ct_NB then if TConnectorObject(aObject).FConnRaiseType <> crt_None then //TConnectorObject(aObject).DrawRaise; Result := True; // end; {//01.11.2011 if CheckFigureByClassName(AObject, cTConnectorObject) then begin NetTypes := TConnectorObject(AObject).FNetworkTypes; end; if CheckFigureByClassName(AObject, cTOrthoLine) then NetTypes := TOrthoLine(AObject).FNetworkTypes; if CheckFigureByClassName(AObject, cTFigureGrpMod) then NetTypes := TFigureGrpMod(AObject).FNetworkTypes; if (nt_All in GCadForm.FShowNetworkTypes) then Result := True else begin if (nt_Computer in GCadForm.FShowNetworkTypes) and (nt_Computer in NetTypes) then result := True; if (nt_Telephon in GCadForm.FShowNetworkTypes) and (nt_Telephon in NetTypes) then result := True; if (nt_Electric in GCadForm.FShowNetworkTypes) and (nt_Electric in NetTypes) then result := True; if (nt_Television in GCadForm.FShowNetworkTypes) and (nt_Television in NetTypes) then result := True; if (nt_Gas in GCadForm.FShowNetworkTypes) and (nt_Gas in NetTypes) then result := True; end;} except on E: Exception do addExceptionToLogEx('U_Common.IsViewObjectInCurrentNetwork', E.Message); end; end; procedure SetBlockParamsForObject(AID_List, AID_Object: Integer; ABlockGUID: string; AObjectType: Integer; ABlockStreams, ABlockStreamsOtherType: TObjectList; aSysName: string = ''); var FFigure: TFigure; SavedCadForm: TF_CAD; vList: TF_CAD; begin try vList := GetListByID(AID_List); if vList <> nil then begin SavedCadForm := GCadForm; GCadForm := vList; FFigure := GetFigureByID(GCadForm, AID_Object); if FFigure = nil then FFigure := GetFigureByIDInSCSFigureGroups(GCadForm, AID_Object); if CheckNoFigureinList(FFigure, GCadForm.FRemFigures) then begin if FFigure <> nil then begin if CheckFigureByClassName(FFigure, cTConnectorObject) then begin if not TConnectorObject(FFigure).FIsBlockChanged then begin TConnectorObject(FFigure).FBlockGUID := ABlockGUID; TConnectorObject(FFigure).FObjectType := AObjectType; SetBlockForConnObject(TConnectorObject(FFigure), ABlockStreams, aSysName); end; end; if CheckFigureByClassName(FFigure, cTOrthoLine) then begin if not TOrthoLine(FFigure).FIsBlockChanged then begin TOrthoLine(FFigure).FBlockGUID := ABlockGUID; TOrthoLine(FFigure).FObjectType := AObjectType; SetBlockForLineObject(TOrthoLine(FFigure), ABlockStreams, ABlockStreamsOtherType); end; end; end; end; GCadForm := SavedCadForm; end; except on E: Exception do addExceptionToLogEx('U_Common.SetBlockParamsForObject', E.Message); end; end; procedure SetLayerHandleForFigureGrp(BlockFig: TFigureGrp; LayHandle: integer); var i: integer; begin for i := 0 to BlockFig.InFigures.Count - 1 do begin TFigure(BlockFig.InFigures[i]).LayerHandle := LayHandle; if (TFigure(BlockFig.InFigures[i]) is TBlock) or (TFigure(BlockFig.InFigures[i]) is TFigureGrp) or (TFigure(BlockFig.InFigures[i]) is TFigureGrpMod) or (TFigure(BlockFig.InFigures[i]) is TFigureGrpNotMod) then SetLayerHandleForFigureGrp(TFigureGrp(BlockFig.InFigures[i]), LayHandle); end; end; // установить новое усл.обозначение для коннектора Procedure SetBlockForConnObject(AConnector: TConnectorObject; ABlockStreams: TObjectList; aSysName: string = ''); var BlockFig: TBlock; FileName: string; i, j: integer; LayHandle: integer; deltax, deltay: Double; Bnd: TDoubleRect; FigGroup: TFigureGrpMod; AngleRad: Double; AngleDeg: Double; ABlockStream: TMemoryStream; alldelta: double; curdelta: double; CadCrossObject: TCadCrossObject; tmpAngle: Double; begin try if ABlockStreams <> nil then AConnector.FBlockCount := ABlockStreams.Count else AConnector.FBlockCount := 0; // если это кросс АТС или РШ то прорисовать его if aSysName = ctsnCrossATS then begin if (AConnector.FTrunkName <> ctsnCrossATS) then begin RemoveInFigureGrp(AConnector.DrawFigure); DeleteConnectingTraces(AConnector); AConnector.FTrunkName := ctsnCrossATS; CadCrossObject := GetPointObjectConnectedTrunk(GCadForm.FCADListID, AConnector.ID); CreateCadCrossATS(aConnector, CadCrossObject); // повернуть DrawFigure на нужный угол AngleRad := AConnector.FDrawFigureAngle; AngleDeg := AngleRad * 180 / pi; RotateTrunkObject(AConnector, AngleDeg); end; Exit; end else if aSysName = ctsnDistributionCabinet then begin if (AConnector.FTrunkName <> ctsnDistributionCabinet) then begin RemoveInFigureGrp(AConnector.DrawFigure); DeleteConnectingTraces(AConnector); AConnector.FTrunkName := ctsnDistributionCabinet; CadCrossObject := GetPointObjectConnectedTrunk(GCadForm.FCADListID, AConnector.ID); CreateCadDistribCab(aConnector, CadCrossObject); // повернуть DrawFigure на нужный угол AngleRad := AConnector.FDrawFigureAngle; AngleDeg := AngleRad * 180 / pi; RotateTrunkObject(AConnector, AngleDeg); end; Exit; end; //RefreshCAD(GCadForm.PCad); // преобразовать в Блок {$if Defined(ES_GRAPH_SC)} FileName := ExeDir + '\.blk\TempStream.blk'; {$else} FileName := ExtractFileDir(Application.ExeName) + '\.blk\TempStream.blk'; {$ifend} if (ABlockStreams <> nil) and (ABlockStreams.Count > 0) then begin LayHandle := GCadForm.PCad.GetLayerHandle(2); FigGroup := TFigureGrpMod.create(LayHandle, GCadForm.PCad); alldelta := 0; curdelta := 0; for i := 0 to ABlockStreams.Count - 1 do begin ABlockStream := TMemoryStream(ABlockStreams[i]); if ABlockStream <> nil then begin // ABlockStream.SaveToFile(FileName); // BlockFig := TBlock(GCadForm.PCad.InsertBlockwithFileName(2, FileName, -100, -100)); ABlockStream.Position := 0; BlockFig := TBlock(GCadForm.PCad.InsertBlockFromStream(2, ABlockStream, -100, -100)); if BlockFig <> nil then begin // Tolik 25/12/2019 -- после подъема со стрима блок будет выбран и запишет все модпоинты в кад, // так вот, нужно их сбросить, а то они будут накапливаться, что не есть хорошо if BlockFig.Selected then BlockFig.deselect; // try SetLayerHandleForFigureGrp(TFigureGrp(BlockFig), LayHandle); except end; if i > 0 then begin Bnd := BlockFig.GetBoundRect; curdelta := abs(Bnd.Top - Bnd.Bottom) / 2; end; // установить DrawFigure for j := 0 to BlockFig.InFigures.Count - 1 do begin FigGroup.AddFigure(TFigure(BlockFig.InFigures[j])); TFigure(BlockFig.InFigures[j]).Move(0, alldelta + curdelta); end; Bnd := FigGroup.GetBoundRect; alldelta := alldelta + abs(Bnd.Top - Bnd.Bottom) / 2; GCadForm.PCad.Figures.Remove(BlockFig); end; end; end; //RefreshCAD(GCadForm.PCad); tmpAngle := AConnector.FDrawFigureAngle; AConnector.FDrawFigureAngle := 0; AConnector.DrawFigure := FigGroup; AConnector.FDrawFigureAngle := tmpAngle; // преобразовать масштаб УГО AConnector.SetDrawFigurePercent(AConnector.FDrawFigurePercent); //RefreshCAD(GCadForm.PCad); // повернуть DrawFigure на нужный угол AngleRad := AConnector.FDrawFigureAngle; AngleDeg := AngleRad * 180 / pi; AConnector.DrawFigure.Rotate(AngleRad, AConnector.ActualPoints[1]); Bnd := AConnector.DrawFigure.GetBoundRect; //RefreshCAD(GCadForm.PCad); AConnector.GrpSizeX := Bnd.Right - Bnd.Left; AConnector.GrpSizeY := Bnd.Bottom - Bnd.Top; //RefreshCAD(GCadForm.PCad); AConnector.ReCreateCaptionsGroup(True, false); AConnector.ReCreateNotesGroup(True); AConnector.DefRaizeDrawFigurePos; //29.05.2013 end else begin LayHandle := GCadForm.PCad.GetLayerHandle(2); FigGroup := TFigureGrpMod.create(LayHandle, GCadForm.PCad); AConnector.DrawFigure := FigGroup; Bnd := AConnector.DrawFigure.GetBoundRect; AConnector.GrpSizeX := Bnd.Right - Bnd.Left; AConnector.GrpSizeY := Bnd.Bottom - Bnd.Top; AConnector.ReCreateCaptionsGroup(false, false); AConnector.DefRaizeDrawFigurePos; //29.05.2013 end; // RefreshCAD(GCadForm.PCad); except on E: Exception do addExceptionToLogEx('U_Common.SetBlockForConnObject', E.Message); end; end; // установить новое усл.обозначение для линии Procedure SetBlockForLineObject(ALine: TOrthoLine; ABlockStreams, ABlockStreamsOtherType: TObjectList); var BlockFig: TBlock; FileName: string; i, j, k: integer; LayHandle: integer; deltax, deltay: Double; Bnd: TDoubleRect; InFigGroup: TFigureGrpMod; FigGroup: TFigureGrpMod; ABlockStream: TMemoryStream; // delta, alldelta, curdelta: double; begin // Tolik 01/12/2016-- BlockFig := Nil; // try ALine.FSingleBlockDelta := 0; LayHandle := GCadForm.PCad.GetLayerHandle(2); //18.04.2013 if not ALine.FIsRaiseUpDown then begin FigGroup := TFigureGrpMod.create(LayHandle, GCadForm.PCad); // преобразовать в Блок {$if Defined(ES_GRAPH_SC)} FileName := ExeDir + '\.blk\TempStream.blk'; {$else} FileName := ExtractFileDir(Application.ExeName) + '\.blk\TempStream.blk'; {$ifend} if (ABlockStreams <> nil) and (ABlockStreams.Count > 0) then begin alldelta := 0; curdelta := 0; InFigGroup := TFigureGrpMod.create(LayHandle, GCadForm.PCad); for i := 0 to ABlockStreams.Count - 1 do begin ABlockStream := TMemoryStream(ABlockStreams[i]); if ABlockStream <> nil then begin ABlockStream.Position := 0; BlockFig := TBlock(GCadForm.PCad.InsertBlockFromStream(2, ABlockStream, -100, -100)); if BlockFig <> nil then begin try SetLayerHandleForFigureGrp(TFigureGrp(BlockFig), LayHandle); except end; if i > 0 then begin Bnd := BlockFig.GetBoundRect; end; // установить DrawFigure for j := 0 to BlockFig.InFigures.Count - 1 do begin InFigGroup.AddFigure(TFigure(BlockFig.InFigures[j])); end; Bnd := InFigGroup.GetBoundRect; GCadForm.PCad.Figures.Remove(BlockFig); end; end; end; FigGroup.AddFigure(InFigGroup); end else begin InFigGroup := TFigureGrpMod.create(LayHandle, GCadForm.PCad); FigGroup.AddFigure(InFigGroup); end; if (ABlockStreamsOtherType <> nil) and (ABlockStreamsOtherType.Count > 0) and (GCadForm.FShowLineCaptionsType = skExternalSCS) then begin alldelta := 0; curdelta := 0; Bnd := InFigGroup.GetBoundRect; delta := abs(Bnd.Bottom - Bnd.Top); delta := delta / 2; InFigGroup := TFigureGrpMod.create(LayHandle, GCadForm.PCad); for i := 0 to ABlockStreamsOtherType.Count - 1 do begin ABlockStream := TMemoryStream(ABlockStreamsOtherType[i]); if ABlockStream <> nil then begin ABlockStream.Position := 0; BlockFig := TBlock(GCadForm.PCad.InsertBlockFromStream(2, ABlockStream, -100, -100)); if BlockFig <> nil then begin try SetLayerHandleForFigureGrp(TFigureGrp(BlockFig), LayHandle); except end; if i > 0 then begin Bnd := BlockFig.GetBoundRect; end; // установить DrawFigure for j := 0 to BlockFig.InFigures.Count - 1 do begin InFigGroup.AddFigure(TFigure(BlockFig.InFigures[j])); TFigure(BlockFig.InFigures[j]).Move(0, delta); end; Bnd := InFigGroup.GetBoundRect; GCadForm.PCad.Figures.Remove(BlockFig); end; end; end; FigGroup.AddFigure(InFigGroup); end; ALine.DrawFigure := FigGroup; //if ALine.FIsRaiseUpDown then // ALine.FDrawFigurePercent := 50; if ALine.FDrawFigurePercent <> 100 then if Not ALine.FIsRaiseUpDown then //27.04.2013 ChangeDrawFigurePercentForLine(ALine, ALine.FDrawFigurePercent); // RefreshCAD(GCadForm.PCad); end; except on E: Exception do addExceptionToLogEx('U_Common.SetBlockForLineObject', E.Message); end; //Tolik 01/12/2016-- if BlockFig <> nil then begin BlockFig.InFigures.Clear; BlockFig.Free; end; // end; Function CheckCanConnectInCAD(AID_List1, AID_List2, AID_Object1, AID_Object2: Integer): Boolean; var i, j: integer; FList1, FList2: TF_CAD; FFigure1, FFigure2: TFigure; JoinedConn: TConnectorObject; JoinedFromList: TConnectorObject; Floor1Conn1, Floor1Conn2, Floor2Conn1, Floor2Conn2: TConnectorObject; PointObject: TConnectorObject; House: THouse; Approach: TConnectorObject; begin Result := False; try FList1 := GetListByID(AID_List1); FList2 := GetListByID(AID_List2); if (FList1 = nil) or (FList2 = nil) then Exit; FFigure1 := GetFigureByID(FList1, AID_Object1); FFigure2 := GetFigureByID(FList2, AID_Object2); // если не найдено, то может это дом if FFigure1 = nil then FFigure1 := GetHouseByID(FList1, AID_Object1); if FFigure2 = nil then FFigure2 := GetHouseByID(FList2, AID_Object2); if (FFigure1 = nil) or (FFigure2 = nil) then Exit; // 1 - ортолиния, 2 - ортолиния if CheckFigureByClassName(FFigure1, cTOrthoLine) and CheckFigureByClassName(FFigure2, cTOrthoLine) then begin // на одном КАДе if (TOrthoLine(FFigure1).JoinConnector1 = TOrthoLine(FFigure2).JoinConnector1) or (TOrthoLine(FFigure1).JoinConnector1 = TOrthoLine(FFigure2).JoinConnector2) or (TOrthoLine(FFigure1).JoinConnector2 = TOrthoLine(FFigure2).JoinConnector1) or (TOrthoLine(FFigure1).JoinConnector2 = TOrthoLine(FFigure2).JoinConnector2) then Result := True; if TConnectorObject(TOrthoLine(FFigure1).JoinConnector1).JoinedConnectorsList.count > 0 then begin PointObject := TConnectorObject(TConnectorObject(TOrthoLine(FFigure1).JoinConnector1).JoinedConnectorsList[0]); for i := 0 to PointObject.JoinedConnectorsList.Count - 1 do begin JoinedConn := TConnectorObject(PointObject.JoinedConnectorsList[i]); for j := 0 to JoinedConn.JoinedOrtholinesList.Count - 1 do if TOrthoLine(JoinedConn.JoinedOrtholinesList[j]) = TOrthoLine(FFigure2) then Result := True; end; end; if TConnectorObject(TOrthoLine(FFigure1).JoinConnector2).JoinedConnectorsList.count > 0 then begin PointObject := TConnectorObject(TConnectorObject(TOrthoLine(FFigure1).JoinConnector2).JoinedConnectorsList[0]); for i := 0 to PointObject.JoinedConnectorsList.Count - 1 do begin JoinedConn := TConnectorObject(PointObject.JoinedConnectorsList[i]); for j := 0 to JoinedConn.JoinedOrtholinesList.Count - 1 do if TOrthoLine(JoinedConn.JoinedOrtholinesList[j]) = TOrthoLine(FFigure2) then Result := True; end; end; // с учетом межэтажных переходов Floor1Conn1 := TConnectorObject(TOrthoLine(FFigure1).JoinConnector1); Floor1Conn2 := TConnectorObject(TOrthoLine(FFigure1).JoinConnector2); Floor2Conn1 := TConnectorObject(TOrthoLine(FFigure2).JoinConnector1); Floor2Conn2 := TConnectorObject(TOrthoLine(FFigure2).JoinConnector2); if (Floor1Conn1.FID_ConnToPassage = Floor2Conn1.ID) and (Floor1Conn1.ID = Floor2Conn1.FID_ConnToPassage) then Result := True; if (Floor1Conn1.FID_ConnToPassage = Floor2Conn2.ID) and (Floor1Conn1.ID = Floor2Conn2.FID_ConnToPassage) then Result := True; if (Floor1Conn2.FID_ConnToPassage = Floor2Conn1.ID) and (Floor1Conn2.ID = Floor2Conn1.FID_ConnToPassage) then Result := True; if (Floor1Conn2.FID_ConnToPassage = Floor2Conn2.ID) and (Floor1Conn2.ID = Floor2Conn2.FID_ConnToPassage) then Result := True; end; // 1 - ортолиния, 2 - коннектор if CheckFigureByClassName(FFigure1, cTOrthoLine) and CheckFigureByClassName(FFigure2, cTConnectorObject) then begin JoinedConn := TConnectorObject(TOrthoLine(FFigure1).JoinConnector1); for i := 0 to TConnectorObject(FFigure2).JoinedConnectorsList.Count - 1 do begin JoinedFromList := TConnectorObject(FFigure2).JoinedConnectorsList[i]; if JoinedConn = JoinedFromList then Result := True; end; JoinedConn := TConnectorObject(TOrthoLine(FFigure1).JoinConnector2); for i := 0 to TConnectorObject(FFigure2).JoinedConnectorsList.Count - 1 do begin JoinedFromList := TConnectorObject(FFigure2).JoinedConnectorsList[i]; if JoinedConn = JoinedFromList then Result := True; end; end; // 1 - коннектор, 2 - ортолиния if CheckFigureByClassName(FFigure1, cTConnectorObject) and CheckFigureByClassName(FFigure2, cTOrthoLine) then begin JoinedConn := TConnectorObject(TOrthoLine(FFigure2).JoinConnector1); for i := 0 to TConnectorObject(FFigure1).JoinedConnectorsList.Count - 1 do begin JoinedFromList := TConnectorObject(FFigure1).JoinedConnectorsList[i]; if JoinedConn = JoinedFromList then Result := True; end; JoinedConn := TConnectorObject(TOrthoLine(FFigure2).JoinConnector2); for i := 0 to TConnectorObject(FFigure1).JoinedConnectorsList.Count - 1 do begin JoinedFromList := TConnectorObject(FFigure1).JoinedConnectorsList[i]; if JoinedConn = JoinedFromList then Result := True; end; end; // 1 - Дом, 2 - ортолиния if CheckFigureByClassName(FFigure1, cTHouse) and CheckFigureByClassName(FFigure2, cTOrthoLine) then begin JoinedConn := TConnectorObject(TOrthoLine(FFigure2).JoinConnector1); if JoinedConn.FIsHouseJoined then if JoinedConn.FHouse = THouse(FFigure1) then Result := True; if JoinedConn.JoinedConnectorsList.Count > 0 then if TConnectorObject(JoinedConn.JoinedConnectorsList[0]).FIsApproach then if TConnectorObject(JoinedConn.JoinedConnectorsList[0]).FHouse = THouse(FFigure1) then Result := True; JoinedConn := TConnectorObject(TOrthoLine(FFigure2).JoinConnector2); if JoinedConn.FIsHouseJoined then if JoinedConn.FHouse = THouse(FFigure1) then Result := True; if JoinedConn.JoinedConnectorsList.Count > 0 then if TConnectorObject(JoinedConn.JoinedConnectorsList[0]).FIsApproach then if TConnectorObject(JoinedConn.JoinedConnectorsList[0]).FHouse = THouse(FFigure1) then Result := True; end; // 1 - ортолиния, 2 - дом if CheckFigureByClassName(FFigure1, cTOrthoLine) and CheckFigureByClassName(FFigure2, cTHouse) then begin JoinedConn := TConnectorObject(TOrthoLine(FFigure1).JoinConnector1); if JoinedConn.FIsHouseJoined then if JoinedConn.FHouse = THouse(FFigure2) then Result := True; if JoinedConn.JoinedConnectorsList.Count > 0 then if TConnectorObject(JoinedConn.JoinedConnectorsList[0]).FIsApproach then if TConnectorObject(JoinedConn.JoinedConnectorsList[0]).FHouse = THouse(FFigure2) then Result := True; JoinedConn := TConnectorObject(TOrthoLine(FFigure1).JoinConnector2); if JoinedConn.FIsHouseJoined then if JoinedConn.FHouse = THouse(FFigure2) then Result := True; if JoinedConn.JoinedConnectorsList.Count > 0 then if TConnectorObject(JoinedConn.JoinedConnectorsList[0]).FIsApproach then if TConnectorObject(JoinedConn.JoinedConnectorsList[0]).FHouse = THouse(FFigure2) then Result := True; end; except on E: Exception do addExceptionToLogEx('U_Common.CheckCanConnectInCAD', E.Message); end; end; Function BriefFormat(ADbl: Double): Double; var Str: string; begin Result := 0; try Str := FormatFloat('0.00', ADbl); Result := StrToFloat_My(Str); except on E: Exception do addExceptionToLogEx('U_Common.BriefFormat', E.Message); end; end; function CheckIsNameChanged(AID_List, AID_Figure: Integer): Boolean; var i: integer; FFigure: TFigure; vList: TF_CAD; begin Result := True; try vList := GetListByID(AID_List); if vList <> nil then begin FFigure := GetFigureByID(vList, AID_Figure); if FFigure <> nil then begin if CheckFigureByClassName(FFigure, cTConnectorObject) then Result := TConnectorObject(FFigure).FIsNameChanged; if CheckFigureByClassName(FFigure, cTOrthoLine) then Result := TOrthoLine(FFigure).FIsNameChanged; end; end; except on E: Exception do addExceptionToLogEx('U_Common.CheckIsNameChanged', E.Message); end; end; function CheckIsCaptionsChanged(AID_List, AID_Figure: Integer): Boolean; var i: integer; FFigure: TFigure; vList: TF_CAD; begin Result := True; try vList := GetListByID(AID_List); if vList <> nil then begin FFigure := GetFigureByID(vList, AID_Figure); if FFigure <> nil then begin if CheckFigureByClassName(FFigure, cTConnectorObject) then Result := TConnectorObject(FFigure).FIsCaptionsChanged; if CheckFigureByClassName(FFigure, cTOrthoLine) then Result := TOrthoLine(FFigure).FIsCaptionsChanged; end; end; except on E: Exception do addExceptionToLogEx('U_Common.CheckIsCaptionsChanged', E.Message); end; end; function CheckIsNotesChanged(AID_List, AID_Figure: Integer): Boolean; var i: integer; FFigure: TFigure; vList: TF_CAD; begin Result := True; try vList := GetListByID(AID_List); if vList <> nil then begin FFigure := GetFigureByID(vList, AID_Figure); if FFigure <> nil then begin if CheckFigureByClassName(FFigure, cTConnectorObject) then Result := TConnectorObject(FFigure).FIsNotesChanged; if CheckFigureByClassName(FFigure, cTOrthoLine) then Result := TOrthoLine(FFigure).FIsNotesChanged; end; end; except on E: Exception do addExceptionToLogEx('U_Common.CheckIsNotesChanged', E.Message); end; end; function CheckIsBlockChanged(AID_List, AID_Figure: Integer): Boolean; var i: integer; FFigure: TFigure; vList: TF_CAD; begin Result := True; try vList := GetListByID(AID_List); if vList <> nil then begin FFigure := GetFigureByID(vList, AID_Figure); if FFigure <> nil then begin if CheckFigureByClassName(FFigure, cTConnectorObject) then Result := TConnectorObject(FFigure).FIsBlockChanged; if CheckFigureByClassName(FFigure, cTOrthoLine) then Result := TOrthoLine(FFigure).FIsBlockChanged; end; end; except on E: Exception do addExceptionToLogEx('U_Common.CheckIsBlockChanged', E.Message); end; end; Function GetAllConnectedTracesID(AID_List, AID_Object: Integer): TIntList; var i, j: integer; CurrObject: TConnectorObject; JoinedConn: TConnectorObject; JoinedLine: TOrthoLine; vList: TF_CAD; begin Result := TIntList.Create; try vList := GetListByID(AID_List); if vList <> nil then begin CurrObject := TConnectorObject(GetFigureByID(vList, AID_Object)); if CurrObject <> nil then begin if CurrObject.ConnectorType = ct_Clear then begin for i := 0 to CurrObject.JoinedOrtholinesList.Count - 1 do begin JoinedLine := TOrthoLine(CurrObject.JoinedOrtholinesList[i]); Result.Add(JoinedLine.ID); end; end else begin for i := 0 to CurrObject.JoinedConnectorsList.Count - 1 do begin JoinedConn := TConnectorObject(CurrObject.JoinedConnectorsList[i]); for j := 0 to JoinedConn.JoinedOrtholinesList.Count - 1 do begin JoinedLine := TOrthoLine(JoinedConn.JoinedOrtholinesList[j]); Result.Add(JoinedLine.ID); end; end; end; end; end; except on E: Exception do addExceptionToLogEx('U_Common.GetAllConnectedTracesID', E.Message); end; end; Function GetAllConnectedTraces(AObject: TConnectorObject): TList; var i, j: integer; JoinedConn: TConnectorObject; JoinedLine: TOrthoLine; begin Result := TList.Create; try if AObject <> nil then begin if AObject.ConnectorType = ct_Clear then begin for i := 0 to AObject.JoinedOrtholinesList.Count - 1 do begin JoinedLine := TOrthoLine(AObject.JoinedOrtholinesList[i]); Result.Add(JoinedLine); end; end else begin for i := 0 to AObject.JoinedConnectorsList.Count - 1 do begin JoinedConn := TConnectorObject(AObject.JoinedConnectorsList[i]); for j := 0 to JoinedConn.JoinedOrtholinesList.Count - 1 do begin JoinedLine := TOrthoLine(JoinedConn.JoinedOrtholinesList[j]); Result.Add(JoinedLine); end; end; end; end; except on E: Exception do addExceptionToLogEx('U_Common.GetAllConnectedTraces', E.Message); end; end; procedure CheckBySCSObjectsNear(X, Y: Double; var ResFindedFigures: TList; TracedFigure: TFigure = nil); var i, j: integer; CurFigure: TFigure; FindedFigures: array[1..2{25}] of TList; LHSCSCommon: Integer; // Layer Handler Res: TFigure; XMod, YMod: Double; xadd, yadd: Double; adim1, adimstep05: Double; aZoomScaleCad: Double; begin Res := nil; try adim1 := 0.5; //1 adimstep05 := 0.25; //0.5 aZoomScaleCad := 0; if (GCadForm.PCad <> nil) then begin aZoomScaleCad := GCadForm.PCad.ZoomScale; if (GCadForm.PCad.ZoomScale >= 500) and (GCadForm.PCad.ZoomScale < 1000) then aZoomScaleCad := GCadForm.PCad.ZoomScale / 1.5 else if GCadForm.PCad.ZoomScale >= 1000 then aZoomScaleCad := GCadForm.PCad.ZoomScale / 2; end; if aZoomScaleCad > 0 then begin adim1 := adim1 / (aZoomScaleCad / 100); adimstep05 := adimstep05 / (aZoomScaleCad / 100); end; for j := 1 to 2 {25} do FindedFigures[j] := TList.Create; if TracedFigure <> nil then TracedFigure.Draw(GCadForm.PCad.DEngine, False); // поиск LHSCSCommon := GCadForm.PCad.GetLayerHandle(lnSCSCommon); //15.03.2012 if GCadForm.FNeedUpdateCheckedFigures then GCadForm.UpdateCheckedFigures; //for i := 0 to GCadForm.PCad.FigureCount - 1 do for i := 0 to GCadForm.FCheckedFigures.Count - 1 do begin //CurFigure := TFigure(GCadForm.PCad.Figures[i]); CurFigure := TFigure(GCadForm.FCheckedFigures[i]); if (CurFigure.LayerHandle = LHSCSCommon) then //15.03.2012 begin XMod := X; YMod := Y; if CheckFigureByClassName(CurFigure, cTConnectorObject) then begin xadd := -adim1; j := 1; //// ЦИКЛ ПОИСКА ОБЬЕКТОВ while xadd <= adim1 do begin yadd := -adim1; while yadd <= adim1 do begin if TConnectorObject(CurFigure).IsPointIn(XMod + xadd, YMod + yadd) then begin if FindedFigures[j].IndexOf(CurFigure) = -1 then FindedFigures[j].Add(CurFigure); end; yadd := yadd + adimstep05; end; xadd := xadd + adimstep05; end; end else if CheckFigureByClassName(CurFigure, cTOrthoLine) then begin xadd := -adim1; j := 1; //// ЦИКЛ ПОИСКА ОБЬЕКТОВ while xadd <= adim1 do begin yadd := -adim1; while yadd <= adim1 do begin if TOrthoLine(CurFigure).IsPointIn(X + xadd, Y + yadd) then begin if FindedFigures[j].IndexOf(CurFigure) = -1 then FindedFigures[j].Add(CurFigure); end; yadd := yadd + adimstep05; end; xadd := xadd + adimstep05; end; end else if CheckFigureByClassName(CurFigure, cTHouse) then begin xadd := -adim1; //// ЦИКЛ ПОИСКА ОБЬЕКТОВ while xadd <= adim1 do begin yadd := -adim1; j := 1; while yadd <= adim1 do begin if THouse(CurFigure).isPointInForSnap(X + xadd, Y + yadd) then begin if FindedFigures[j].IndexOf(CurFigure) = -1 then FindedFigures[j].Add(CurFigure); end; yadd := yadd + adimstep05; end; xadd := xadd + adimstep05; end; end; end; end; // выбор по критериям // сначала объект for j := 1 to 2 {25} do begin Res := Nil; for i := 0 to FindedFigures[j].Count - 1 do begin CurFigure := TFigure(FindedFigures[j][i]); if CheckFigureByClassName(CurFigure, cTConnectorObject) and (not TConnectorObject(CurFigure).FIsApproach) then if TConnectorObject(CurFigure).ConnectorType <> ct_Clear then Res := CurFigure; end; // потом пустой коннектор if Res = Nil then begin for i := 0 to FindedFigures[j].Count - 1 do begin CurFigure := TFigure(FindedFigures[j][i]); if CheckFigureByClassName(CurFigure, cTConnectorObject) then if TConnectorObject(CurFigure).ConnectorType = ct_Clear then Res := CurFigure; end; end; // ну тогда хотя бы ортолинию if Res = Nil then begin for i := 0 to FindedFigures[j].Count - 1 do begin CurFigure := TFigure(FindedFigures[j][i]); if CheckFigureByClassName(CurFigure, cTOrthoLine) then Res := CurFigure; end; end; // Подъезд if Res = Nil then begin for i := 0 to FindedFigures[j].Count - 1 do begin CurFigure := TFigure(FindedFigures[j][i]); if CheckFigureByClassName(CurFigure, cTConnectorObject) and (TConnectorObject(CurFigure).FIsApproach) then Res := CurFigure; end; end; // Дом if Res = Nil then begin for i := 0 to FindedFigures[j].Count - 1 do begin CurFigure := TFigure(FindedFigures[j][i]); if CheckFigureByClassName(CurFigure, cTHouse) then Res := CurFigure; end; end; if Res <> nil then begin if ResFindedFigures.IndexOf(Res) = -1 then ResFindedFigures.Add(Res); end; end; for j := 1 to 2 {25} do if FindedFigures[j] <> nil then FreeAndNil(FindedFigures[j]); if TracedFigure <> nil then TracedFigure.Draw(GCadForm.PCad.DEngine, False); except on E: Exception do addExceptionToLogEx('U_Common.CheckBySCSObjectsNear', E.Message); end; end; Function CheckBySCSObjects(X, Y: Double; TracedFigure: TFigure = nil): TFigure; var i: integer; CurFigure: TFigure; FindedFigures: TList; ProgramRegisterPro_2: boolean; addcod: integer; LHSCSCommon: Integer; // Layer Handler begin Result := nil; //Tolik -- 09/02/2017 -- FindedFigures := nil; // Tolik -- 01/03/2017 -- if GCadForm.PCad.Figures.Count < 3 then exit; // try {$IF Not Defined(ES_GRAPH_SC)} {$IF Not Defined(TRIAL_SCS)} {$I Inc\DelphiCrcBegin.inc} {$IFEND} {TODO} // пока закоментил временно - слишком часто вызывается //ProgramRegisterPro_2 := ProgProtection.IsVer2(PRO, addcod); ProgramRegisterPro_2 := True; addcod := 0; {$IF Not Defined(TRIAL_SCS)} {$I Inc\DelphiCrcEnd.inc} {$IFEND} {$IF Defined(TRIAL_SCS)} addcod := 0; {$IFEND} {$IF Not Defined(FINAL_SCS)} addcod := 0; {$IFEND} {$IF Defined(FINAL_SCS) and Not Defined(TRIAL_SCS)} {$IF Not Defined(TRIAL_SCS)} {$I Inc\DelphiCrcBegin.inc} {$IFEND} {TODO} // пока закоментил временно - слишком часто вызывается //if Not ProgramRegisterPro_2 then // exit; {$IF Not Defined(TRIAL_SCS)} {$I Inc\DelphiCrcEnd.inc} {$IFEND} {$IFEND} {$ELSE} addcod := 0; {$IFEND} FindedFigures := TList.Create; if TracedFigure <> nil then TracedFigure.Draw(GCadForm.PCad.DEngine, False); // поиск {$IF Not Defined(ES_GRAPH_SC)} {$IF Not Defined(TRIAL_SCS)} {$I Inc\DelphiCrcBegin.inc} {$IFEND} {$IFEND} LHSCSCommon := GCadForm.PCad.GetLayerHandle(lnSCSCommon); //15.03.2012 if GCadForm.FNeedUpdateCheckedFigures then GCadForm.UpdateCheckedFigures; //for i := 0 to GCadForm.PCad.FigureCount - 1 + addcod do // Tolik 21/11/2019 -- if Assigned(GCadForm) then if Assigned(GCadForm.FCheckedFigures) then begin // for i := 0 to GCadForm.FCheckedFigures.Count - 1 do begin //CurFigure := TFigure(GCadForm.PCad.Figures[i]); CurFigure := TFigure(GCadForm.FCheckedFigures[i]); if not CurFigure.Deleted then // Tolik 24/01/2019 -- begin if CurFigure.LayerHandle = LHSCSCommon then //15.03.2012 begin if CheckFigureByClassName(CurFigure, cTConnectorObject) then begin if TConnectorObject(CurFigure).IsPointIn(X, Y) then begin FindedFigures.Add(CurFigure); end; end else if CheckFigureByClassName(CurFigure, cTOrthoLine) then begin if TOrthoLine(CurFigure).IsPointIn(X + addcod, Y + addcod) then begin //Tolik 12/04/2018 -- все равно на 2-Д с вертикали только передвижение коннектора можно поиметь, так что пусть коннектор двигают, потому что только тогда // от коннектора правильно нарисуются шадоу присоединенных трасс //FindedFigures.Add(CurFigure); If not TOrthoLine(CurFigure).FisVertical then FindedFigures.Add(CurFigure); // end; end else if CheckFigureByClassName(CurFigure, cTHouse) then begin if THouse(CurFigure).isPointInForSnap(X, Y) then begin FindedFigures.Add(CurFigure); end; end; end; end; end; end; // выбор по критериям {$IF Not Defined(ES_GRAPH_SC)} {TODO} // пока закоментил временно - слишком часто вызывается //ProgramRegisterPro_2 := ProgProtection.IsVer2(PRO, addcod); addcod := 0; ProgramRegisterPro_2 := True; {$IFEND} {$IF Not Defined(ES_GRAPH_SC)} {$IF Not Defined(TRIAL_SCS)} {$I Inc\DelphiCrcEnd.inc} {$IFEND} {$IF Defined(TRIAL_SCS)} addcod := 0; {$IFEND} {$IF Not Defined(FINAL_SCS)} addcod := 0; {$IFEND} {$IF Not Defined(TRIAL_SCS)} {$I Inc\DelphiCrcBegin.inc} {$IFEND} {$ELSE} addcod := 0; {$IFEND} // сначала объект for i := addcod to FindedFigures.Count - 1 do begin CurFigure := TFigure(FindedFigures[i]); if CheckFigureByClassName(CurFigure, cTConnectorObject) and (not TConnectorObject(CurFigure).FIsApproach) then if TConnectorObject(CurFigure).ConnectorType <> ct_Clear then Result := CurFigure; end; {$IF Not Defined(ES_GRAPH_SC)} {$IF Not Defined(TRIAL_SCS)} {$I Inc\DelphiCrcEnd.inc} {$IFEND} {$IFEND} // потом пустой коннектор if Result = Nil then begin for i := 0 to FindedFigures.Count - 1 do begin CurFigure := TFigure(FindedFigures[i]); if CheckFigureByClassName(CurFigure, cTConnectorObject) then if TConnectorObject(CurFigure).ConnectorType = ct_Clear then Result := CurFigure; end; end; // ну тогда хотя бы ортолинию if Result = Nil then begin for i := 0 to FindedFigures.Count - 1 do begin CurFigure := TFigure(FindedFigures[i]); if CheckFigureByClassName(CurFigure, cTOrthoLine) then Result := CurFigure; end; end; // Подъезд if Result = Nil then begin for i := 0 to FindedFigures.Count - 1 do begin CurFigure := TFigure(FindedFigures[i]); if CheckFigureByClassName(CurFigure, cTConnectorObject) and (TConnectorObject(CurFigure).FIsApproach) then Result := CurFigure; end; end; // Дом if Result = Nil then begin for i := 0 to FindedFigures.Count - 1 do begin CurFigure := TFigure(FindedFigures[i]); if CheckFigureByClassName(CurFigure, cTHouse) then Result := CurFigure; end; end; if FindedFigures <> nil then FreeAndNil(FindedFigures); if TracedFigure <> nil then TracedFigure.Draw(GCadForm.PCad.DEngine, False); except on E: Exception do addExceptionToLogEx('U_Common.CheckBySCSObjects', E.Message); end; end; Function CheckBySCSObjectsList(X, Y: Double): TList; var i: integer; CurFigure: TFigure; begin Result := TList.Create; try // поиск for i := 0 to GCadForm.PCad.FigureCount - 1 do begin CurFigure := TFigure(GCadForm.PCad.Figures[i]); if CheckFigureByClassName(CurFigure, cTConnectorObject) then begin if TConnectorObject(CurFigure).IsPointIn(X, Y) then Result.Add(CurFigure); end; if CheckFigureByClassName(CurFigure, cTOrthoLine) then begin if TOrthoLine(CurFigure).IsPointIn(X, Y) then Result.Add(CurFigure); end; end; except on E: Exception do addExceptionToLogEx('U_Common.CheckBySCSObjectsList', E.Message); end; end; Procedure AutoShiftobject(AObject: TConnectorObject); var i, UCount: integer; CanMove: Boolean; AddDelta: Double; Bnd: TDoubleRect; ComponWidth, SlotsWidth, koefX: Double; ComponsList: TObjectList; Obj: TWMFObject; begin try if not HaveObjectSocketComponent(AObject.ID) then Exit; AddDelta := 0; if BriefFormat(AObject.DrawFigure.CenterPoint.x) > BriefFormat(AObject.ActualPoints[1].x) then CanMove := False else begin if AObject.DrawFigure.InFigures.Count > 0 then begin CanMove := True; if (AObject.DrawFigure.InFigures.Count = 1) and CheckFigureByClassName(TFigure(AObject.DrawFigure.InFigures[0]), 'TWMFObject') then begin ComponWidth := AObject.DrawFigure.GetBoundRect.Right - AObject.DrawFigure.GetBoundRect.Left; AddDelta := 0.04 * ComponWidth; end else AddDelta := 0; end else CanMove := False; end; if CanMove then begin AObject.DrawFigure.Rotate(- AObject.FDrawFigureAngle, AObject.ActualPoints[1]); Bnd := AObject.DrawFigure.GetBoundRect; AObject.GrpSizeX := abs(Bnd.Right - Bnd.Left); AObject.GrpSizeY := abs(Bnd.Bottom - Bnd.Top); AObject.DrawFigure.move(AObject.GrpSizeX / 2 - AddDelta, 0); AObject.DrawFigure.Rotate(AObject.FDrawFigureAngle, AObject.ActualPoints[1]); Bnd := AObject.DrawFigure.GetBoundRect; AObject.GrpSizeX := abs(Bnd.Right - Bnd.Left); AObject.GrpSizeY := abs(Bnd.Bottom - Bnd.Top); if AObject.CaptionsGroup <> nil then AObject.CaptionsGroup.Move(AObject.GrpSizeX / 2 - AddDelta, 0); end; except on E: Exception do addExceptionToLogEx('U_Common.AutoShiftobject', E.Message); end; end; Function GetObjectsListForCork(AListID, AID_LineFigure, ALineSide: Integer; var AID_Connector: Integer): TIntList; var i, j: integer; ASelfLine: TOrthoLine; AConnector: TConnectorObject; GetPointObject: TConnectorObject; JoinedLine: TOrthoLine; JoinedConn: TConnectorObject; ID: Integer; IDLine: ^Integer; vList: TF_CAD; begin Result := TIntList.Create; try AConnector := nil; //#From Oleg# //14.09.2010 AID_Connector := -1; vList := GetListByID(AListID); if vList <> nil then begin ASelfLine := TOrthoLine(GetFigureByID(vList, AID_LineFigure)); if ASelfLine <> nil then begin if ALineSide = 1 then AConnector := TConnectorObject(ASelfLine.JoinConnector1); if ALineSide = 2 then AConnector := TConnectorObject(ASelfLine.JoinConnector2); // лист из присоединенных трасс // напрямую if AConnector.JoinedConnectorsList.Count = 0 then begin if (AConnector.FConnRaiseType <> crt_BetweenFloorUp) and (AConnector.FConnRaiseType <> crt_BetweenFloorDown) then begin // Вернуть ИД коннектора AID_Connector := AConnector.ID; for i := 0 to AConnector.JoinedOrtholinesList.Count - 1 do begin JoinedLine := TOrthoLine(AConnector.JoinedOrtholinesList[i]); //New(IDLine); //ID := JoinedLine.ID; //IDLine^ := ID; //Result.Add(IDLine); Result.Add(JoinedLine.ID); end; end; end else // через точ.объект begin GetPointObject := TConnectorObject(AConnector.JoinedConnectorsList[0]); if (GetPointObject.FConnRaiseType <> crt_BetweenFloorUp) and (GetPointObject.FConnRaiseType <> crt_BetweenFloorDown) then begin AID_Connector := GetPointObject.ID; for i := 0 to GetPointObject.JoinedConnectorsList.Count - 1 do begin JoinedConn := TConnectorObject(GetPointObject.JoinedConnectorsList[i]); for j := 0 to JoinedConn.JoinedOrtholinesList.Count - 1 do begin JoinedLine := TOrthoLine(JoinedConn.JoinedOrtholinesList[j]); //New(IDLine); //ID := JoinedLine.ID; //IDLine^ := ID; //Result.Add(IDLine); Result.Add(JoinedLine.ID); end; end; end; end; end; end; except on E: Exception do addExceptionToLogEx('U_Common.GetObjectsListForCork', E.Message); end; end; Procedure BeginProgress(ACaption: String = ''; AMaxPos: Integer = -1; MustShowProgress: Boolean=False); begin // Tolik -- 21/04/2017 -- if GisGroupUpdate then exit; // if GIsProgressHandling then Exit; try if GIsProgressCount = 0 then begin GIsProgress := True; GIsProgressHandling := true; try if not F_Progress.Visible then if (F_Splash = nil) or Not F_Splash.Visible then begin try F_Progress.StartProgress(ACaption, AMaxPos, MustShowProgress); except end; end; if assigned(F_Progress) then begin if F_Progress.FPauseCount = 0 then // Tolik 24/03/2021 -- //FSCS_Main.FCADsInProgress.Clear; ClearCADsInProgress(FSCS_Main.FCADsInProgress); // FSCS_Main.FCADsInProgress.Clear; end else // Tolik 24/03/2021 -- //FSCS_Main.FCADsInProgress.Clear; ClearCADsInProgress(FSCS_Main.FCADsInProgress); //FSCS_Main.FCADsInProgress.Clear; SetCADsProgressMode(true); BaseBeginUpdate; except end; GIsProgressHandling := false; end else begin if ((AMaxPos > 0) and MustShowProgress) then F_Progress.REShowProgress(ACaption, AMaxPos, MustShowProgress); end; Inc(GIsProgressCount); except on E: Exception do addExceptionToLogEx('U_Common.BeginProgress', E.Message); end; end; { Procedure BeginProgress(ACaption: String = ''; AMaxPos: Integer = -1); begin if GIsProgressHandling then Exit; try if GIsProgressCount = 0 then begin GIsProgress := True; GIsProgressHandling := true; try if not F_Progress.Visible then if (F_Splash = nil) or Not F_Splash.Visible then begin try F_Progress.StartProgress(ACaption, AMaxPos); except end; end; if assigned(F_Progress) then begin if F_Progress.FPauseCount = 0 then FSCS_Main.FCADsInProgress.Clear; end else FSCS_Main.FCADsInProgress.Clear; SetCADsProgressMode(true); BaseBeginUpdate; except end; GIsProgressHandling := false; end; Inc(GIsProgressCount); except on E: Exception do addExceptionToLogEx('U_Common.BeginProgress', E.Message); end; end; } Procedure EndProgress; var i: Integer; refreshFlag: Boolean; begin // Tolik -- 21/04/2017 -- if GisGroupUpdate then exit; // if GIsProgressHandling then Exit; // Toik 16/12/2019 -- refreshFlag := GCanRefreshCad; GCanRefreshCad := False; // try if GIsProgressCount > 0 then begin Dec(GIsProgressCount); if GIsProgressCount = 0 then begin GIsProgressHandling := true; try SetCADsProgressMode(false); BaseEndUpdate; if F_Progress.Visible then begin F_Progress.StopProgress; end; except end; GIsProgress := False; GIsProgressHandling := false; // Tolik -- 28/11/2016-- короче, сюда НИ В КОЕМ СЛУЧАЕ ни х подобного не лепить!!! // будет подвешивать приложение (хз, почему) // Tolik -- 04/11/2016-- НЕ ТРОГАТЬ!!! { Application.Restore; // !!! чтобы показало СКС (если был АЛЬТ-ТАБ) Application.MainForm.RePaint; Application.MainForm.Refresh;} // Tolik -- 25//11//2016 -- чтобы отрисовалось дерево нормативной базы после переключения // с другого прложения по альт-таб (если прошел длительный процесс типа прокладки трасс или кабелей) { if Assigned(F_NormBase) then begin F_NormBase.Width := F_NormBase.Width + 1; F_NormBase.Width := F_NormBase.Width - 1; end; } // Tolik 28/11/2016 -- // F_NormBase.Tree_Catalog.Width := F_NormBase.Tree_Catalog.Width +1; // F_NormBase.Tree_Catalog.Width := F_NormBase.Tree_Catalog.Width -1; // end; end; except on E: Exception do addExceptionToLogEx('U_Common.EndProgress', E.Message); end; GCanRefreshCad := refreshFlag; //Tolik 16/12/2019 -- end; { Procedure EndProgress; var i: Integer; begin if GIsProgressHandling then Exit; try if GIsProgressCount > 0 then begin Dec(GIsProgressCount); if GIsProgressCount = 0 then begin GIsProgressHandling := true; try SetCADsProgressMode(false); BaseEndUpdate; if F_Progress.Visible then begin F_Progress.StopProgress; end; // Tolik -- 04/11/2016-- НЕ ТРОГАТЬ!!! Application.Restore; // !!! чтобы показало СКС (если был АЛЬТ-ТАБ) Application.MainForm.RePaint; Application.MainForm.Refresh; if Assigned(F_NormBase) then begin F_NormBase.RePaint; F_NormBase.Refresh; end; if GCadForm <> nil then // не потерять Кад (события ) TF_CAD(GCADForm).SetFocus else Application.MainForm.SetFocus; // except end; GIsProgress := False; GIsProgressHandling := false; end; end; except on E: Exception do addExceptionToLogEx('U_Common.EndProgress', E.Message); end; end;} procedure SetCADsProgressMode(AIsProgress: Boolean); var i: Integer; CAD: TF_CAD; begin // Очистка на BeginProgress // Очистка FSCS_Main.FCADsInProgress на BeginProgress - делается собственно в BeginProgress //if AIsProgress then // FSCS_Main.FCADsInProgress.Clear; for i := 0 to FSCS_Main.MDIChildCount - 1 do begin CAD := TF_CAD(FSCS_Main.MDIChildren[i]); if AIsProgress then begin //CAD.mProtocol.Properties.BeginUpdate; //CAD.mProtocol.Lines.BeginUpdate; //CAD.PCad.DisableAlign; CADBeginUpdate(CAD); if FSCS_Main.FCADsInProgress.IndexOf(CAD) = -1 then FSCS_Main.FCADsInProgress.Add(CAD); end else begin if FSCS_Main.FCADsInProgress.IndexOf(CAD) <> -1 then begin //CAD.mProtocol.Properties.EndUpdate; //CAD.mProtocol.Lines.EndUpdate; //CAD.PCad.EnableAlign; CADEndUpdate(CAD); //04.04.2013 - НУЖНО ЧТОБЫ НЕБЫЛО МЕРЦАНИЙ НА PauseProgress //if CAD = FSCS_Main.ActiveMDIChild then // RefreshCAD(CAD.PCad); end; end; end; // Очистка на EndProgress if Not AIsProgress then if assigned(F_Progress) then begin if F_Progress.FPauseCount = 0 then // Tolik 24/03/2021-- // FSCS_Main.FCADsInProgress.Clear; // Tolik 24/03/2021 -- //FSCS_Main.FCADsInProgress.Clear; ClearCADsInProgress(FSCS_Main.FCADsInProgress); end else // Tolik 24/03/2021 -- //FSCS_Main.FCADsInProgress.Clear; ClearCADsInProgress(FSCS_Main.FCADsInProgress); end; procedure CADBeginUpdate(aCAD: TObject); //07.11.2011 begin TF_CAD(aCAD).mProtocol.Properties.BeginUpdate; TF_CAD(aCAD).mProtocol.Lines.BeginUpdate; TF_CAD(aCAD).PCad.DisableAlign; TF_CAD(aCAD).PCad.BeginUpdate; //23.08.2012 end; procedure CADEndUpdate(aCAD: TObject); //07.11.2011 begin TF_CAD(aCAD).mProtocol.Properties.EndUpdate; TF_CAD(aCAD).mProtocol.Lines.EndUpdate; TF_CAD(aCAD).PCad.EnableAlign; TF_CAD(aCAD).PCad.EndUpdate; //23.08.2012 end; procedure StepProgress; begin try if (GIsProgressCount = 1) and F_Progress.Showing then begin F_Progress.StepProgress; ProcessMessagesEx; end; except on E: Exception do addExceptionToLogEx('StepProgress: ', E.Message); end; end; procedure StepProgressRE; begin try // if (GIsProgressCount = 1) and F_Progress.Showing then begin F_Progress.StepProgress; ProcessMessagesEx; end; except on E: Exception do addExceptionToLogEx('StepProgressRE: ', E.Message); end; end; procedure StartUpProgress; begin F_Splash.ProgressBar.StepIt; Application.ProcessMessages; end; Procedure SetListsNamesInProject(AProjectName: string); var i: integer; LayerName: string; CurCadForm: TF_CAD; begin try for i := 0 to FSCS_Main.MDIChildCount - 1 do begin CurCadForm := TF_CAD(FSCS_Main.MDIChildren[i]); CurCadForm.FCADProjectName := AProjectName; LayerName := CurCadForm.PCad.GetLayerName(CurCadForm.PCad.ActiveLayer); CurCadForm.Caption := CurCadForm.FCADProjectName + ' - ' + CurCadForm.FCADListName + cCommon_Mes7 + LayerName; end; except on E: Exception do addExceptionToLogEx('U_Common.SetListsNamesInProject', E.Message); end; end; // Tolik 18/12/2019 -- procedure CreateShadowObject; var i: integer; x, y: integer; LayHandle: integer; //Obj: TFigureGrpNotMod; Line: TLine; Rect: TRectangle; VisibleRect: TDoubleRect; deltax, deltay: double; isExistShadow: boolean; Figure: TFigure; a: integer; begin try if (GCadForm <> nil) and (GCadForm.PCad <> nil) then begin if Assigned(GShadowObject) then begin GCadForm.PCad.Figures.Remove(GShadowObject); FreeAndNil(GShadowObject); end; VisibleRect := GCadForm.PCad.GetVisibleRect; deltax := VisibleRect.Left + 10; deltay := VisibleRect.Top + 10; LayHandle := GCadForm.PCad.GetLayerHandle(2); GShadowObject := TFigureGrpNotMod.Create(LayHandle, GCadForm.PCad); Line := TLine.create(0, 0, 0, 0, 1, ord(psClear), clBlack, 0, LayHandle, mydsNormal, GCadForm.PCad); GShadowObject.AddFigure(Line); GCadForm.PCad.AddCustomFigure (GLN(LayHandle), GShadowObject, False); //Tolik 11/01/2022 //GShadowObject.Move(deltax, deltay); GShadowObject.Move(GCadForm.dragx, GCadForm.dragy); //GShadowObject.Move(GCurrMousePos.x, GCurrMousePos.y); // GShadowObject.LockModify := True; GShadowObject.LockMove := True; end; except on E: Exception do addExceptionToLogEx('U_Common.CreateShadowObject', E.Message); end; end; (* procedure CreateShadowObject; var i: integer; x, y: integer; LayHandle: integer; //Obj: TFigureGrpNotMod; Line: TLine; Rect: TRectangle; VisibleRect: TDoubleRect; deltax, deltay: double; isExistShadow: boolean; Figure: TFigure; a: integer; begin try if (GCadForm <> nil) and (GCadForm.PCad <> nil) then begin isExistShadow := True; while isExistShadow do begin isExistShadow := False; For a := 0 to GCadForm.PCad.Figures.Count - 1 do begin if TFigure(GCadForm.PCad.Figures[a]) is TFigureGrpNotMod then if TFigureGrpNotMod(GCadForm.PCad.Figures[a]).InFigures.Count = 1 then begin Figure := TFigureGrpNotMod(GCadForm.PCad.Figures[a]).InFigures[0]; if Figure.ClassName = 'TLine' then begin isExistShadow := True; GIsDrawShadow := False; RemoveInFigureGrp(TFigureGrpNotMod(GCadForm.PCad.Figures[a])); GCadForm.PCad.Figures.Remove(GCadForm.PCad.Figures[a]); break; end; end; end; end; VisibleRect := GCadForm.PCad.GetVisibleRect; deltax := VisibleRect.Left + 10; deltay := VisibleRect.Top + 10; LayHandle := GCadForm.PCad.GetLayerHandle(2); Obj := TFigureGrpNotMod.Create(LayHandle, GCadForm.PCad); Line := TLine.create(0, 0, 0, 0, 1, ord(psClear), clBlack, 0, LayHandle, mydsNormal, GCadForm.PCad); if Assigned(GShadowObject) then GShadowObject := nil; // Tolik 18/12/2019 -- //GShadowObject := TFigureGrpNotMod(GCadForm.PCad.AddCustomFigure (GLN(LayHandle), Obj, False)); GCadForm.PCad.AddCustomFigure (GLN(LayHandle), Obj, False); GShadowObject := Obj; // GShadowObject.AddFigure(Line); GShadowObject.Move(deltax, deltay); GShadowObject.LockModify := True; GShadowObject.LockMove := True; {GShadowObject.DrawStyle := dsTrace; for i := 0 to GShadowObject.inFigures.Count - 1 do TFigure(GShadowObject.inFigures[i]).DrawStyle := dsTrace;} {Rect := TRectangle.create(0, 0, 4, 4, 2, ord(psSolid), clGray, ord(psSolid), 0, LayHandle, mydsNormal, GCadForm.PCad); GShadowObject := TFigureGrpNotMod(GCadForm.PCad.AddCustomFigure (GLN(LayHandle), Obj, False)); GShadowObject.AddFigure(Rect); GShadowObject.Move(deltax, deltay); GShadowObject.LockModify := True; GShadowObject.LockMove := True; GShadowObject.ShadowCP.x := deltax + 4; GShadowObject.ShadowCP.y := deltay + 4; Rect.DrawStyle := dsTrace; GShadowObject.DrawStyle := dsTrace; GCadForm.PCad.TraceFigure := GShadowObject;} end; except on E: Exception do addExceptionToLogEx('U_Common.CreateShadowObject', E.Message); end; end; *) // Tolik 18/12/2019 -- procedure DestroyShadowObject; var i: integer; begin try if (GCadForm <> nil) and (GCadForm.PCad <> nil) then begin //GCadForm.PCad.TraceFigure := nil; //16.03.2012 GIsDrawShadow := False; if GShadowObject <> nil then begin GCadForm.PCad.Figures.Remove(GShadowObject); freeAndNil(GShadowObject); end; end; except on E: Exception do addExceptionToLogEx('U_Common.DestroyShadowObject', E.Message); end; //Tolik 13/08/2019 -- а тут же ж как же ж? if GCadForm <> nil then // if (GCadForm.FCreateObjectOnClick){and(not Assigned(GShadowObject))} then CreateShadowObject; // На CAD end; // (* procedure DestroyShadowObject; var i: integer; begin try if (GCadForm <> nil) and (GCadForm.PCad <> nil) then begin //GCadForm.PCad.TraceFigure := nil; //16.03.2012 GIsDrawShadow := False; if GShadowObject <> nil then begin RemoveInFigureGrp(GShadowObject); GCadForm.PCad.Figures.Remove(GShadowObject); end; end; except on E: Exception do addExceptionToLogEx('U_Common.DestroyShadowObject', E.Message); end; //Tolik 13/08/2019 -- а тут же ж как же ж? if GCadForm <> nil then // if (GCadForm.FCreateObjectOnClick){and(not Assigned(GShadowObject))} then CreateShadowObject; // На CAD end; *) Procedure AutoConnectOverRaiseInCAD(AObjFromRaise, ARaiseObj: TConnectorObject); var i, j: integer; ObjFromRaise: TConnectorObject; RaiseObj: TConnectorObject; RaiseLine: TOrthoLine; JoinedLine: TOrthoLine; JoinedConn: TConnectorObject; ptrConnectObjParam: PConnectObjectParam; ConnectedLines: TList; ConnectedBeforeRaise: TList; ConnectedAfterRaise: TList; procedure DefineConnectedObjectParams(ATargetConnectedObjectParams: TList; AConnectorObject: TConnectorObject); var i, j: Integer; JoinedLine: TOrthoLine; JoinedConn: TConnectorObject; ptrConnectObjParam: PConnectObjectParam; begin if AConnectorObject.ConnectorType = ct_Clear then for i := 0 to AConnectorObject.JoinedOrtholinesList.Count - 1 do begin JoinedLine := TOrthoLine(AConnectorObject.JoinedOrtholinesList[i]); if JoinedLine <> RaiseLine then begin New(ptrConnectObjParam); ptrConnectObjParam.IDObject := JoinedLine.ID; if JoinedLine.JoinConnector1 = AConnectorObject then ptrConnectObjParam.Side := 1; if JoinedLine.JoinConnector2 = AConnectorObject then ptrConnectObjParam.Side := 2; ATargetConnectedObjectParams.Add(ptrConnectObjParam); end; end else begin for i := 0 to AConnectorObject.JoinedConnectorsList.Count - 1 do begin JoinedConn := TConnectorObject(AConnectorObject.JoinedConnectorsList[i]); for j := 0 to JoinedConn.JoinedOrtholinesList.Count - 1 do begin JoinedLine := TOrthoLine(JoinedConn.JoinedOrtholinesList[j]); if JoinedLine <> RaiseLine then begin New(ptrConnectObjParam); ptrConnectObjParam.IDObject := JoinedLine.ID; if JoinedLine.JoinConnector1 = JoinedConn then ptrConnectObjParam.Side := 1; if JoinedLine.JoinConnector2 = JoinedConn then ptrConnectObjParam.Side := 2; ATargetConnectedObjectParams.Add(ptrConnectObjParam); end; end; end; end; end; begin try ObjFromRaise := AObjFromRaise; RaiseObj := ARaiseObj; if (ARaiseObj.FConnRaiseType = crt_None) and (AObjFromRaise.FConnRaiseType <> crt_None) then begin ObjFromRaise := ARaiseObj; RaiseObj := AObjFromRaise; end; RaiseLine := GetRaiseLine(RaiseObj); ConnectedBeforeRaise := TList.Create; ConnectedAfterRaise := TList.Create; DefineConnectedObjectParams(ConnectedBeforeRaise, ObjFromRaise); DefineConnectedObjectParams(ConnectedAfterRaise, RaiseObj); AutoConnectOverRaiseLine(ObjFromRaise.ID, RaiseLine.ID, ConnectedBeforeRaise, ConnectedAfterRaise, ltUpDown); // Tolik 21/12/2019 -- {if ConnectedBeforeRaise <> nil then FreeList(ConnectedBeforeRaise); if ConnectedAfterRaise <> nil then FreeList(ConnectedAfterRaise);} // так будет правильнее ... FreeAndDisposeList(ConnectedBeforeRaise); FreeAndDisposeList(ConnectedAfterRaise); // except on E: Exception do addExceptionToLogEx('U_Common.AutoConnectOverRaiseInCAD', E.Message); end; end; function GetCADStreamByIDList(AID_List: Integer; aFileName: string = ''): TMemoryStream; var i: integer; CurCADForm: TF_CAD; begin Result := nil; //09.09.2011 TMemoryStream.Create; try for i := 0 to FSCS_Main.MDIChildCount - 1 do begin if TF_CAD(FSCS_Main.MDIChildren[i]).FCADListID = AID_List then Break; end; if i = FSCS_Main.MDIChildCount then Exit; CurCADForm := TF_CAD(FSCS_Main.MDIChildren[i]); GCadForm := CurCADForm; if GCadForm <> nil then begin GCadForm.PCad.SaveWithPreview := False; if aFileName = '' then begin Result := TMemoryStream.Create; GCadForm.PCad.SaveToStream(Result) end else begin ForceDirectories(ExtractFileDir(aFileName)); GCadForm.PCad.SaveToFile(0, aFileName); end; GCadForm.PCad.SaveWithPreview := True; end; except on E: Exception do addExceptionToLogEx('GetCADStreamByIDList', E.Message); end; end; function IfDrawFigureMoveCan(AObject: TConnectorObject; ADeltaX, ADeltaY: Double): Boolean; var BegPoints: TDoublePoint; EndPoints: TDoublePoint; ToPoints: TDoublePoint; begin Result := False; try BegPoints.x := AObject.ActualPoints[1].x - AObject.GrpSizeX / 2; BegPoints.y := AObject.ActualPoints[1].y - AObject.GrpSizeY / 2; EndPoints.x := AObject.ActualPoints[1].x + AObject.GrpSizeX / 2; EndPoints.y := AObject.ActualPoints[1].y + AObject.GrpSizeY / 2; ToPoints.x := AObject.DrawFigure.CenterPoint.x + ADeltaX; ToPoints.y := AObject.DrawFigure.CenterPoint.y + ADeltaY; if ((ToPoints.x >= BegPoints.x) and (ToPoints.x <= EndPoints.x)) and ((ToPoints.y >= BegPoints.y) and (ToPoints.y <= EndPoints.y)) then Result := True; except on E: Exception do addExceptionToLogEx('U_Common.IfDrawFigureMoveCan', E.Message); end; end; procedure ReAssignNavigatorParams; var i: integer; ListValue: Double; BaseValue: Double; KoefValue: Double; begin try if F_Navigator <> nil then begin if F_Navigator.PCadNavigator.SelectedCount > 0 then F_Navigator.PCadNavigator.DeselectAll(0); if (F_Navigator.PCadNavigator.PageOrient <> GCadForm.PCad.PageOrient) or (F_Navigator.PCadNavigator.PageLayout <> GCadForm.PCad.PageLayout) or // Tolik 24/03/2017 -- (F_Navigator.PCadNavigator.WorkWidth <> GCadForm.PCad.WorkWidth) or (F_Navigator.PCadNavigator.WorkHeight <> GCadForm.PCad.WorkHeight) then begin F_Navigator.PCadNavigator.PageOrient := GCadForm.PCad.PageOrient; F_Navigator.PCadNavigator.PageLayout := GCadForm.PCad.PageLayout; F_Navigator.PCadNavigator.WorkWidth := GCadForm.PCad.WorkWidth; F_Navigator.PCadNavigator.WorkHeight := GCadForm.PCad.WorkHeight; // A0 - 1189*841 - 3% ZoomScale // A1 - 841*594 // A2 - 594*421 // A3 - 421*297 // A4 - 297*210 // A5 - 210*148 // A6 - 105*74 BaseValue := 1189; ListValue := Max(GCadForm.PCad.WorkHeight, GCadForm.PCad.WorkWidth); KoefValue := BaseValue / ListValue; F_Navigator.PCadNavigator.ZoomScale := Round(3 * KoefValue); end; RefreshCAD(F_Navigator.PCadNavigator); end; except on E: Exception do addExceptionToLogEx('U_Common.ReAssignNavigatorParams', E.Message); end; end; Procedure LoadSettingsForList(AListID: Integer; aApplyListFormat: Boolean); var ListSettings: TListSettingRecord; ListParams: TListParams; begin try SetDefaultPageParams; // подгрузить параметры листа ListParams := GetListParams(AListID); LoadSettingsForListByParams(ListParams, aApplyListFormat); except on E: Exception do addExceptionToLogEx('U_Common.LoadSettingsForList', E.Message); end; end; function MakeEditList(AMakeEdit: TMakeEdit; var AListParams: TListParams; AShowForm: Boolean; ASpravochnikKind: TViewKind = vkNone; AGUIDToLocate: String = ''): Boolean; var NewTab: TTabSheet; MenuItem: TMenuItem; i, j: integer; GetIDList: Integer; OldPrjCaption, PrjCaption: string; OldListCaption, ListCaption: String; Box: TConnectorObject; BoxList: TF_CAD; WasOpenedProject: Boolean; CADParams: TCADParams; Cabinet: TCabinet; x1, x2, y1, y2: double; LHandle: integer; OldListParams: TListParams; OldListW, OldListH: double; isChangeListParams: Boolean; PCadRecordUndoFlag: Boolean; // Tolik 16/10/2020 -- begin Result := false; try if not CanAddListToPM(WasOpenedProject) then begin ShowMessage(cCommon_Mes8); Exit; end; OldListW := 0; //#From Oleg# //14.09.2010 OldListH := 0; //#From Oleg# //14.09.2010 //*** На случай, если Лист создается на закрытом проекте, и параметры до тек. момента // небыли определены if WasOpenedProject then ///if AListParams.MarkID = 0 then AListParams := GetListParamsForNewList; OldListParams := AListParams; CADParams := SetCADParamsStruct(AListParams); // &&& if (GIfMasterUsed) or (GLiteVersion and (AMakeEdit = meMake)) and (not GReadOnlyMode) then isChangeListParams := F_MasterNewListLite.ChangeListParams(AMakeEdit, AListParams, AShowForm{, CADParams}, ASpravochnikKind, AGUIDToLocate) else isChangeListParams := F_MasterNewList.ChangeListParams(AMakeEdit, AListParams, AShowForm{, CADParams}, ASpravochnikKind, AGUIDToLocate); if isChangeListParams then begin // Tolik -- 15/04/2016 -- if AMakeEdit = meEdit then begin if GCadForm.PCad.ActiveLayer = 1 then begin if MessageBox(Application.Handle, cCommon_Mes30, cCommon_Mes29, MB_YESNO) = IDNO then exit; end; end; // Result := true; BeginProgress; try // MAKE if AMakeEdit = meMake then begin // создать лист в проекте TF_CAD.Create(FSCS_Main); // создать виртуальный кабинет CreateVirtualCabinetInCAD(GCadForm); if GCurrentCADListID = 0 then begin GetIDList := GenNewListID; GCadForm.FCADListID := GetIDList; AListParams.ID := GCadForm.FCADListID; end else GCadForm.FCADListID := GCurrentCADListID; GCadForm.FCADListName := AListParams.Name; GCadForm.FCADListIndex := AListParams.MarkID; SetDefaultPageParams; // Добавить переключатель в панель листов проекта NewTab := TTabSheet.Create(nil); NewTab.PageControl := FSCS_Main.pageCADList; NewTab.Tag := GCadForm.Handle; FSCS_Main.pageCADList.ActivePage := NewTab; // Добавить Листы в главное меню for i := 0 to FSCS_Main.mainWindow.Count - 1 do if FSCS_Main.mainWindow.Items[i].Caption = '-' then break; j := 0; inc(i); while FSCS_Main.mainWindow.Count > i do begin MenuItem := FSCS_Main.mainWindow.Items[FSCS_Main.mainWindow.Count - 1]; FSCS_Main.mainWindow.Delete(FSCS_Main.mainWindow.Count - 1); MenuItem.Free; end; for j := 0 to FSCS_Main.pageCADList.PageCount - 1 do begin MenuItem := TMenuItem.Create(nil); MenuItem.Caption := FSCS_Main.pageCADList.Pages[j].Caption; MenuItem.Tag := FSCS_Main.pageCADList.Pages[j].Tag; MenuItem.AutoCheck := True; MenuItem.RadioItem := True; MenuItem.Checked := FSCS_Main.pageCADList.Pages[j] = FSCS_Main.pageCADList.ActivePage; MenuItem.OnClick := FSCS_Main.SwitchWindow; FSCS_Main.mainWindow.Add(MenuItem); end; // Создать лист в МП if (F_NormBase <> nil) and (F_ProjMan <> nil) then if GCurrentCADListID = 0 then AddListInPM(GCadForm.FCADListID, AListParams); GCadForm.WindowState := wsMaximized; GCadForm.FCADProjectName := GetCurrProjectName; PrjCaption := GetCurrProjectParams.Caption; ListCaption := AListParams.Caption; GCadForm.Caption := PrjCaption + ' - ' + ListCaption; {$IF Defined(ES_GRAPH_SC)} GCadForm.CurrentLayer := 8; {$else} GCadForm.CurrentLayer := 2; {$ifend} end; // *** // установить параметры табов и вкладок PrjCaption := GetCurrProjectParams.Caption; ListCaption := AListParams.Caption; FSCS_Main.pageCADList.ActivePage.Caption := ListCaption; for i := 0 to FSCS_Main.mainWindow.Count - 1 do begin if FSCS_Main.mainWindow.Items[i].Checked then break; end; FSCS_Main.mainWindow.Items[i].Caption := ListCaption; // *UNDO* if AMakeEdit = meEdit then begin if GCadForm <> nil then begin PCADRecordUndoFlag := GCadForm.PCAD.RecordUndo; // Tolik 16/10/2020 -- GCadForm.PCAD.RecordUndo := False; if GCadForm.FCanSaveForUndo then begin GCadForm.SaveForUndo(uat_None, True, False); GCadForm.FCanSaveForUndo := False; end; end; end; if AMakeEdit = meEdit then if GCadForm <> nil then begin OldListW := GCadForm.PCad.WorkWidth; OldListH := GCadForm.PCad.WorkHeight; end; // установить параметры листа от мастера создания листа LoadSettingsForListByParams(AListParams, True); SaveListParams(GCadForm.FCADListID, AListParams, F_MasterNewList.cbApplyForAllSCSObjects.Checked, F_MasterNewList.cbApplyForSelectedOnly.Checked); if (GIfMasterUsed) or (GLiteVersion and (AMakeEdit = meMake)) and (not GReadOnlyMode) then SetNewListParamsForMaster(CADParams) else //SetNewListParams(CADParams); SetNewListParams(CADParams, aMakeEdit); if AMakeEdit = meMake then if GCadForm <> nil then begin if GCadForm.FListType = lt_Normal then {$IF Defined(ES_GRAPH_SC)} GCadForm.CurrentLayer := 8 {$else} GCadForm.CurrentLayer := 2 {$ifend} else GCadForm.CurrentLayer := 1; end; // *** EDIT *** if AMakeEdit = meEdit then begin if GCadForm.FListType = lt_DesignBox then begin // Обновить дизайн-лист // Tolik 23/06/2021 -- тут зададим пользователю вопрос, обновлять ли схему шкафа, т.к. не всем это может быть нужно, а то // получится так, что пользователь схему поредактировал схему как ему нужно, сменил формат листа и все пропало!!!, потому что она // видите ли, обновилась! if MessageBox(FSCS_Main.Handle, PChar(cRenewRackDesign), PChar(cBaseCommon45), MB_YESNO) = IDYes then begin // BoxList := GetListByID(GCadForm.FJoinedListIDForDesignList); if BoxList <> nil then begin Box := TConnectorObject(GetFigureByID(BoxList, GCadForm.FJoinedBoxIDForDesignList)); if Box <> nil then UpdateDesignList(GCadForm, Box); end; end; end; // if (GCadForm <> nil) and (GCadForm.PCad <> nil) then begin try if (OldListParams.MarkID <> AListParams.MarkID) or (OldListParams.Name <> AListParams.Name) then // 2011-05-10 RenameListInCAD(GCadForm.FCADListID, '', AListParams.Caption, @AListParams, false); except end; end; // обновить имя листа на рамке if (GCadForm <> nil) and (GCadForm.PCad <> nil) then begin try //13.09.2010 if (GCadForm.FFrameListName = nil) or (TRichText(GCadForm.FFrameListName).re.Text = '') then //13.09.2010 RenameListOnFrame(GCadForm, GetCurrProjectParams(false), OldListParams); RenameListOnFrame(GCadForm, GetCurrProjectParams(false), OldListParams); except end; end; // автоподгонка изображения if AMakeEdit = meEdit then if F_MasterNewList.cbRescaleDrawing.Enabled and F_MasterNewList.cbRescaleDrawing.Checked then if GCadForm <> nil then ReScaleDrawingToListFormat(OldListW, OldListH); // *UNDO* if GCadForm <> nil then GCadForm.FCanSaveForUndo := True; end; finally EndProgress; GIfMasterUsed := False; // Tolik 16/10/2020 -- if GCadForm <> nil then begin if GCadForm.PCad.ActiveLayer = 1 then begin //GCadForm.PCad.DeselectAll(1); //GCadForm.PCad.ActiveLayer := 2; if GCadForm.FListType = lt_Normal then // Tolik 01/06/2021 -- для схем не нужно! GCadForm.CurrentLayer := 2 else GCadForm.CurrentLayer := 1; end; GCadForm.PCAD.RecordUndo := PCADRecordUndoFlag; // Tolik 04/06/2021 -- { if AMakeEdit = meEdit then GCadForm.PCAD.RecordUndo := PCadRecordUndoFlag; // Tolik 16/10/2020 --} end; end; end; except on E: Exception do addExceptionToLogEx('U_Common.MakeEditList', E.Message); end; // Tolik 17/05/2021 -- if GCadForm <> nil then begin BeginProgress; EndProgress; GCadForm.PCad.Refresh; end; // end; procedure LoadSettingsForListByParams(AListParams: TListParams; aApplyListFormat: Boolean); var ListSettings: TListSettingRecord; ListFormat: TListFormatType; IsChanged: Boolean; begin try ListSettings := AListParams.Settings; //06.08.2012 GCadForm.PCad.FGrayedColor := AListParams.Settings.CADGrayedColor; GCadForm.FCADListIndex := AListParams.MarkID; GCadForm.FCADListIndex := AListParams.MarkID; GCadForm.FRoomHeight := ListSettings.HeightRoom; GCadForm.FFalseFloorHeight := ListSettings.HeightCeiling; GCadForm.FConnHeight := ListSettings.HeightSocket; GCadForm.FLineHeight := ListSettings.HeightCorob; GCadForm.FLengthKoef := ListSettings.LengthKoef; GCadForm.FPortReserv := ListSettings.PortReserv; GCadForm.FMultiportReserv := ListSettings.MultiportReserv; GCadForm.FCableChannelFullnessKoef := ListSettings.CableCanalFullnessKoef; GCadForm.FTwistedPairMaxLength := ListSettings.TwistedPairMaxLength; // GCadForm.FShowObjectCaptionsType := ListSettings.ShowObjectTypeCAD; GCadForm.FShowObjectNotesType := ListSettings.CADShowObjectNotesType; // Tolik 05/02/2020 -- чтобы и для внутренныих и для внешних сетей оботражение длины линии было одинаковым ... //GCadForm.FShowLineCaptionsType := ListSettings.CADCaptionsKind; //GCadForm.FShowLineNotesType := ListSettings.CADNotesKind; if ListSettings.CADCaptionsKind = skExternalSCS then GCadForm.FShowLineCaptionsType := skSimple else GCadForm.FShowLineCaptionsType := ListSettings.CADCaptionsKind; if ListSettings.CADNotesKind = skExternalSCS then GCadForm.FShowLineNotesType := skSimple else GCadForm.FShowLineNotesType := ListSettings.CADNotesKind; // GCadForm.FGroupListObjectsByType := ListSettings.GroupListObjectsByType; GCadForm.FPutCableOnTrace := ListSettings.PutCableInTrace; GCadForm.FShowLinesLength := ListSettings.ShowLineObjectLength; GCadForm.FShowLinesCaptions := ListSettings.ShowLineObjectCaption; GCadForm.FShowConnectorsCaptions := ListSettings.ShowConnObjectCaption; GCadForm.FShowLinesNotes := ListSettings.ShowLineObjectNote; GCadForm.FShowConnectorsNotes := ListSettings.ShowConnObjectNote; GCadForm.FDefaultTraceColor := ListSettings.CADTraceColor; GCadForm.FDefaultBlockStep := ListSettings.CADBlockStep; GCadForm.FDefaultTraceStyle := ListSettings.CADTraceStyle; GCadForm.FDefaultTraceWidth := ListSettings.CADTraceWidth; GCadForm.FClickType := ListSettings.CADClickObjectType; GCadForm.FShowRaise := ListSettings.CADShowRaise; //GCadForm.FShowRaiseDrawFigure := ListSettings.CADShowRaiseDrawFigure; GCadForm.FNotePrefix := ListSettings.NoteCountPrefix; GCadForm.PCad.GridStep := ListSettings.CADGridStep; // Шрифт КАДа GCadForm.FFontName := ListSettings.CADFontName; GCadForm.PCad.Font.Name := GCadForm.FFontName; // Тип уголка по дефолту GCadForm.FDefaultCornerType := ListSettings.CornerType; GCadForm.FKeepLineTypesRules := ListSettings.KeepLineTypesRules; // Обновить все тексты на листе UpdateForTexts(GCadForm.FFontName); GCadForm.FListType := ListSettings.ListType; if GCadForm.FListType = lt_Normal then EnableOptionsForNormalList else if GCadForm.FListType = lt_DesignBox then DisableOptionsForDesignList else if GCadForm.FListType = lt_ProjectPlan then DisableOptionsForProjectPlan // Tolik 10/02/2021 -- else if GCadForm.FListType = lt_ElScheme then DisableOptionsForEl_Scheme else if GCadForm.FListType = lt_AScheme then DisableOptionsForEl_Scheme; // Для дизайнерского листа GCadForm.FJoinedBoxIDForDesignList := ListSettings.IDFigureForDesignList; GCadForm.FJoinedListIDForDesignList := ListSettings.IDListForDesignList; GCadForm.FDesignListShowName := ListSettings.ShowNameInDesignList; GCadForm.FDesignListShowSign := ListSettings.ShowNameShortInDesignList; GCadForm.FDesignListShowMark := ListSettings.ShowNameMarkInDesignList; // ПАРАМЕТРЫ СТРАНИЦЫ // заполнить структуру формата листа ListFormat.ListCountX := ListSettings.CADListCountX; ListFormat.ListCountY := ListSettings.CADListCountY; ListFormat.PageWidth := ListSettings.CADWidth * ListSettings.CADListCountX; ListFormat.PageHeight := ListSettings.CADHeight * ListSettings.CADListCountY; ListFormat.ShowMainStamp := ListSettings.CADShowMainStamp; ListFormat.ShowUpperStamp := ListSettings.CADShowUpperStamp; ListFormat.ShowSideStamp := ListSettings.CADShowSideStamp; ListFormat.StampLang := ListSettings.CADStampLang; ListFormat.StampType := ListSettings.CADStampType; ListFormat.StampFields.Margins := ListSettings.CADStampMargins; ListFormat.StampFields.Developer := ListSettings.CADStampDeveloper; //15.11.2011 - разработал ListFormat.StampFields.Checker := ListSettings.CADStampChecker; //15.11.2011 - проверил ListFormat.StampFields.ListSign := ListSettings.CADStampListSign; ListFormat.StampFields.MainEngineer := ListSettings.CADStampMainEngineer; //02.10.2012 - Главный инженер проекта ListFormat.StampFields.Approved := ListSettings.CADStampApproved; //02.10.2012 - Утвердил ListFormat.StampFields.DesignStage := ListSettings.CADStampDesignStage; //02.10.2012 - Стадия проектир. if ListSettings.CADPageSizeIndex = 0 then ListFormat.PageLayout := plA0; if ListSettings.CADPageSizeIndex = 1 then ListFormat.PageLayout := plA1; if ListSettings.CADPageSizeIndex = 2 then ListFormat.PageLayout := plA2; if ListSettings.CADPageSizeIndex = 3 then ListFormat.PageLayout := plA3; if ListSettings.CADPageSizeIndex = 4 then ListFormat.PageLayout := plA4; if ListSettings.CADPageSizeIndex = 5 then ListFormat.PageLayout := plA5; if ListSettings.CADPageSizeIndex = 6 then ListFormat.PageLayout := plA6; if ListSettings.CADPageSizeIndex = 7 then ListFormat.PageLayout := plB4; if ListSettings.CADPageSizeIndex = 8 then ListFormat.PageLayout := plB5; if ListSettings.CADPageSizeIndex = 9 then ListFormat.PageLayout := plLetter; if ListSettings.CADPageSizeIndex = 10 then ListFormat.PageLayout := plTabloid; if ListSettings.CADPageSizeIndex = 11 then ListFormat.PageLayout := plCustom; if ListSettings.CADPageOrient = PCTypesUtils.poPortrait then ListFormat.PageOrient := PCTypesUtils.poPortrait else if ListSettings.CADPageOrient = PCTypesUtils.poLandscape then ListFormat.PageOrient := PCTypesUtils.poLandscape; // проверить были ли изменения IsChanged := CheckListFormatChanged(GCadForm, ListFormat); GCadForm.FCadStampType := ListSettings.CADStampType; GCadForm.FCadStampLang := ListSettings.CADStampLang; //GCadForm.FCadStampMargins := ListSettings.CADStampMargins; //GCadForm.FCADStampDeveloper := ListSettings.CADStampDeveloper; //GCadForm.FCADStampChecker := ListSettings.CADStampChecker; GCadForm.FStampFields := ListFormat.StampFields; GCadForm.FListCountX := ListSettings.CADListCountX; GCadForm.FListCountY := ListSettings.CADListCountY; GCadForm.FShowMainStamp := ListSettings.CADShowMainStamp; GCadForm.FShowUpperStamp := ListSettings.CADShowUpperStamp; GCadForm.FShowSideStamp := ListSettings.CADShowSideStamp; //GCadForm.FShowPathLengthType := TShowPathLengthType(ListSettings.CADShowPathLengthType); GCadForm.SetShowPathLengthType(TShowPathLengthType(ListSettings.CADShowPathLengthType)); //GCadForm.FShowPathTraceLengthType := TShowPathLengthType(ListSettings.CADShowPathTraceLengthType); GCadForm.SetShowPathTraceLengthType(TShowPathLengthType(ListSettings.CADShowPathTraceLengthType)); if aApplyListFormat and IsChanged then SetCadListFormat(ListFormat); // настройки КАДа // показывать линейки GCadForm.PCad.RulerVisible := ListSettings.CADShowRuler; FSCS_Main.aShowRuler.Checked := GCadForm.PCad.RulerVisible; GCadForm.tbShowRuler.Down := GCadForm.PCad.RulerVisible; // показывать сетку GCadForm.PCad.Grids := ListSettings.CADShowGrid; FSCS_Main.aShowGrid.Checked := GCadForm.PCad.Grids; GCadForm.tbShowGrid.Down := GCadForm.PCad.Grids; // показывать центр. направляющие // FSCS_Main.aShowCenterGuides.Checked := GCadForm.PCad.CenterGuide; // показывать направляющие GCadForm.PCad.GuidesVisible := ListSettings.CADShowGuides; FSCS_Main.aShowGuideLines.Checked := GCadForm.PCad.GuidesVisible; GCadForm.tbShowGuides.Down := GCadForm.PCad.GuidesVisible; // привязка к сетке GCadForm.PCad.SnapToGrids := ListSettings.CADSnapGrid; FSCS_Main.aSnaptoGrid.Checked := GCadForm.PCad.SnapToGrids; GCadForm.tbSnapGrid.Down := GCadForm.PCad.SnapToGrids; GCadForm.LastSnapGridStatus := GCadForm.PCad.SnapToGrids; // привязка к направляющим GCadForm.PCad.SnapToGuides := ListSettings.CADSnapGuides; FSCS_Main.aSnaptoGuides.Checked := GCadForm.PCad.SnapToGuides; GCadForm.tbSnapGuides.Down := GCadForm.PCad.SnapToGuides; // привязка к ближ. объекту GCadForm.PCad.SnapToNearPoint := ListSettings.CADSnapNearObject; FSCS_Main.aSnaptoNearObject.Checked := GCadForm.PCad.SnapToNearPoint; GCadForm.tbSnapNearObject.Down := GCadForm.PCad.SnapToNearPoint; // стиль отображения измерительных линий GCadForm.FDimLinesType := ListSettings.CADDimLinesType; // обновить слои UpdateForLayers; // отображение номеров кабинетов GCadForm.FShowCabinetsNumbers := ListSettings.CADShowCabinetsNumbers; GCadForm.FShowCabinetsBounds := ListSettings.CADShowCabinetsBounds; // цвета подписей и выносок GCadForm.FLinesCaptionsColor := ListSettings.CADLinesCaptionsColor; GCadForm.FConnectorsCaptionsColor := ListSettings.CADConnectorsCaptionsColor; GCadForm.FLinesNotesColor := ListSettings.CADLinesNotesColor; GCadForm.FConnectorsNotesColor := ListSettings.CADConnectorsNotesColor; // размеры шрифтов подписей и выносок GCadForm.FLinesCaptionsFontSize := ListSettings.CADLinesCaptionsFontSize; GCadForm.FConnectorsCaptionsFontSize := ListSettings.CADConnectorsCaptionsFontSize; GCadForm.FLinesNotesFontSize := ListSettings.CADLinesNotesFontSize; GCadForm.FConnectorsNotesFontSize := ListSettings.CADConnectorsNotesFontSize; GCadForm.FCrossATSFontSize := ListSettings.CADCrossATSFontSize; GCadForm.FCrossATSFontBold := ListSettings.CADCrossATSFontBold; GCadForm.FDistribCabFontSize := ListSettings.CADDistribCabFontSize; GCadForm.FDistribCabFontBold := ListSettings.CADDistribCabFontBold; GCadForm.FPrintType := ListSettings.CADPrintType; GCadForm.FSCSType := ListSettings.SCSType; GCadForm.FDefaultTraceStepRotate := ListSettings.CADTraceStepRotate; GCadForm.FAutoCadMouse := ListSettings.AutoCadMouse; GCadForm.FScaleByCursor := ListSettings.ScaleByCursor; GCadForm.FAutoPosTraceBetweenRM := ListSettings.CADAutoPosTraceBetweenRM; GCadForm.FSaveUndoCount := ListSettings.CADSaveUndoCount; GCadForm.FActiveActions := 0; GCadForm.FAllowSuppliesKind := ListSettings.CADAllowSuppliesKind; //Tolik 05/02/2021 -- //GCadForm.FNewTraceLengthType := TTraceLengthType(ListSettings.CADNewTraceLengthType); GCadForm.FNewTraceLengthType := tltAuto; // GCadForm.FListSettings := ListSettings; GCadForm.FListSettings.ShowTracesCrossPoints := ListSettings.ShowTracesCrossPoints; // Tolik 13/09/2017 -- GCadForm.tbShowTransparency.down := GCadForm.FListSettings.AllowTransparency; except on E: Exception do addExceptionToLogEx('U_Common.LoadSettingsForListByParams', E.Message); end; end; procedure SetCADFrameParams(ACadForm: TF_CAD); var //ListParams: TListParams; //ProjectParams: TProjectParams; CadForm: TF_CAD; begin try // подгрузить параметры листа //ListParams := GetListParams(AListID); //ProjectParams := GetCurrProjectParams(false); CadForm := ACadForm; //GetListByID(AListID); if CadForm <> nil then begin LoadCaptionsOnFrame(CadForm, CadForm.FCadStampType, false); // номер листа //if GCadForm.FFrameListName <> nil then //begin // GCadForm.PCad.Figures.Remove(GCadForm.FFrameListName); // RefreshCad(GCadForm.PCad); // GCadForm.FFrameListName := CreateStampCaptionToField(aBnd, aListName); // GCadForm.FFrameListName.DataID := 200; // GCadForm.PCad.AddCustomFigure (GLN(LHandle), GCadForm.FFrameListName, False); //end; end; except on E: Exception do AddExceptionToLogEx('SetCADFrameParams', E.Message); end; end; // ОТКРЫТЬ ЛИСТЫ В ПРОЕКТЕ procedure OpenListsInProject(AListID: Integer; AListName: string); var NewTab: TTabSheet; MenuItem: TMenuItem; i, j: integer; //08.09.2011 Buffer: array[0..1023] of Char; TempPath: string; ListSettings: TListSettingRecord; PrjCaption: string; ListCaption: String; Addlayer: TLayer; ListStream: TMemoryStream; fFileName: string; VirtualCabinetExist: Boolean; // Tolik 28/08/2019 -- //OldTick, CurrTick: Cardinal; OldTick, CurrTick: DWord; // ObjIdx: Integer; Figure: TFigure; NeedCheck: Boolean; isDuplicate: Boolean; SCSCatalog: TSCSCatalog; SCSCompon: TSCSComponent; a: integer; ListOfUse: TList; //Tolik FFigure: Tfigure; CadFigList: TList; // слепок фигур Када (Список) currLine: TOrthoLine; oldQuotaMessageCount: Integer; UserQuotaReached_Message: string; f: TextFile; RefreshFlag: boolean; createID: integer; TrackPos: integer; // // Tolik -- 10/11/2016 -- корректно удалить и с Када и ПМ (хотя бы постараться) Procedure DeleteFigureFromCadAndPM(aFigure: TFigure); var i, j, FRemIndex: Integer; Joined1, Joined2: TConnectorObject; RemJoinedFigure: TFigure; begin try // удалить связи конекторов с удаленными ортолиниями if CheckFigureByClassName(aFigure, cTOrthoLine) then begin // Tolik // нахер это здесь не нужно, т.к. выполнится на удалении ортолинии Joined1 := TConnectorObject(TOrthoLine(aFigure).JoinConnector1); Joined2 := TConnectorObject(TOrthoLine(aFigure).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(aFigure, cTOrthoLine) or (CheckFigureByClassName(aFigure, cTConnectorObject) and (not TConnectorObject(aFigure).fisApproach)) then DeleteObjectFromPM(aFigure.ID, TFigure(aFigure).Name, true) // Cabinet else if CheckFigureByClassName(aFigure, cTCabinet) then DeleteRoomFromCADToPM(TCabinet(aFigure).FSCSID) // CabinetExt else if CheckFigureByClassName(aFigure, cTCabinetExt) then DeleteRoomFromCADToPM(TCabinetExt(aFigure).FSCSID) // House else if CheckFigureByClassName(aFigure, cTHouse) then DeleteObjectFromPM(THouse(aFigure).ID, THouse(aFigure).Name, true) // Approach else if CheckFigureByClassName(aFigure, cTConnectorObject) and (TConnectorObject(aFigure).fisApproach) then DeleteComponInPM(GCadForm.FCADListID, TConnectorObject(aFigure).FComponID); end; try if CheckFigureByClassName(aFigure, cTFigureGrpMod) or CheckFigureByClassName(aFigure, cTFigureGrpNotMod) then RemoveInFigureGrp(TFigureGrp(aFigure)) // запомнить присоединенные коннекторы чтобы удалить (с-п) // (они не выделяются потому и не удаляются вместе с группой) else if CheckFigureByClassName(aFigure, cTOrthoLine) then begin Joined1 := TConnectorObject(TOrthoLine(aFigure).JoinConnector1); Joined2 := TConnectorObject(TOrthoLine(aFigure).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; GCadForm.FRemFigures.Remove(aFigure); GCadForm.PCad.Figures.Remove(aFigure); aFigure.Destroy; except end; except on E: Exception do addExceptionToLogEx('TF_CAD.PCadGUIEvent', E.Message); end; end; // Procedure CheckRestoreConnections; var i, j: Integer; currConn, JoinedConn: TConnectorObject; currLine: TOrthoLine; begin for i := 0 to CadFigList.Count - 1 do begin if CheckFigureByClassName(TFigure(CadFigList[i]), cTConnectorObject) then begin currConn := TConnectorObject(CadFigList[i]); for j := 0 to currConn.JoinedConnectorsList.Count - 1 do begin JoinedConn := TConnectorObject(currConn.JoinedConnectorsList[j]); if JoinedConn.JoinedConnectorsList.IndexOf(currConn) = -1 then begin JoinedConn.JoinedConnectorsList.Add(currConn); addExceptionToLogEx('OpenListsInProject: ', currConn.Name + InttoStr(currConn.FIndex) + ' added to ' + JoinedConn.Name + ' ' + InttoStr(JoinedConn.FIndex) + ' Joined Connectors List on ' + GCadForm.FCadListName); end; end; end else if CheckFigureByClassName(TFigure(CadFigList[i]), cTOrthoLine) then begin currLine := TOrthoLine(CadFigList[i]); if currLine.JoinConnector1 <> nil then begin currConn := TConnectorObject(currLine.JoinConnector1); if CurrConn.JoinedOrtholinesList.IndexOf(currLine) = -1 then begin currConn.JoinedOrtholinesList.Add(currLine); addExceptionToLogEx('OpenListsInProject: ', currLine.Name + InttoStr(currLine.FIndex) + ' added to ' + currConn.Name + ' ' + InttoStr(currConn.FIndex) + ' Joined OrthoLines List on ' + GCadForm.FCadListName); end; end; if currLine.JoinConnector2 <> nil then begin currConn := TConnectorObject(currLine.JoinConnector2); if currConn.JoinedOrtholinesList.IndexOf(currLine) = -1 then begin currConn.JoinedOrtholinesList.Add(currLine); addExceptionToLogEx('OpenListsInProject: ', currLine.Name + InttoStr(currLine.FIndex) + ' added to ' + currConn.Name + ' ' + InttoStr(currConn.FIndex) + ' Joined OrthoLines List on ' + GCadForm.FCadListName); end; end; end; end; end; begin F_ProjMan.GSCSBase.CurrProject.Setting.FirstTraceCreated := True; RefreshFlag := GCanRefreshCad; try // Tolik -- 01/03/2017 -- если уже было превышение квоты - выход нах { if GUserOBjectsQuotaLimit_Message_Counter <> 0 then exit;} oldQuotaMessageCount := GUserOBjectsQuotaLimit_Message_Counter; // создать лист в проекте TF_CAD.Create(FSCS_Main); GCadForm.FCADListID := AListID; GCadForm.FCADListName := AListName; GCadForm.FCADProjectName := GetCurrProjectName; GCadForm.PCad.DisableAlign; //27.12.2011 GCadForm.PCad.BeginUpdate; ListOfUse := TList.Create; try LoadSettingsForList(AListID, False); PrjCaption := GetCurrProjectParams.Caption; ListCaption := GetListParams(GCadForm.FCADListID).Caption; GCadForm.Caption := PrjCaption + ' - ' + ListCaption; try // поднять Stream с листа ListStream := OpenListInPM(GCadForm.FCADListID, GCadForm.FCADListName, fFileName); if (ListStream <> nil) or (fFileName <> '') then begin //27.12.2010 - Перед поднятием объектов LoadFromFile очистит все, поэтому нужно FActiveNet сбросить if ActiveNet = GCadForm.FActiveNet then ActiveNet := nil; GCadForm.FActiveNet := nil; if ListStream <> nil then begin TempPath := GetAnsiTempPath; //08.09.2011 SetString(TempPath, Buffer, GetTempPath(Sizeof(Buffer) - 1, Buffer)); ListStream.SaveToFile(TempPath + 'tempCAD.pwd'); // подгрузить из файла GCadForm.PCad.OnObjectInserted := nil; GCadForm.PCad.LoadFromFile(TempPath + 'tempCAD.pwd'); GCadForm.PCad.OnObjectInserted := GCadForm.PCadObjectInserted; end else if fFileName <> '' then begin // подгрузить из файла GCadForm.PCad.OnObjectInserted := nil; //GProcCnt := 0; OldTick := GetTickCount; GCadForm.PCad.LoadFromFile(fFileName); CurrTick := GetTickCount - OldTick; GCadForm.PCad.OnObjectInserted := GCadForm.PCadObjectInserted; end; // Tolik -- 01/03/2017 -- если загрузка фигур из стрима была прервана по причине превышения квоты, // выдать сообщение и вывалиться нафиг if oldQuotaMessageCount <> GUserOBjectsQuotaLimit_Message_Counter then begin Dec(GUserOBjectsQuotaLimit_Message_Counter); UserQuotaReached_Message := GetQuotaMessage(CheckUserObjQuotaReached(1), cMess_Quota_OpenProj); if UserQuotaReached_Message <> '' then begin if GUserOBjectsQuotaLimit_Message_Counter < 2 then begin PauseProgress(True); Showmessage(UserQuotaReached_Message); PauseProgress(False); end; GCadForm.PCad.Figures.Clear; GCadForm.FSCSFigures.Clear; // GCadForm.Close; //Exit; end; end; // end; if (ListStream <> nil) or (fFileName <> '') then begin // для старых проектов - пересоздать слои if GCadForm.PCad.LayerCount = 7 then begin AddLayer := TLayer.Create(cCad_Mes7); GCadForm.PCad.Layers.Add(Addlayer); end; if GCadForm.PCad.LayerCount = 8 then begin AddLayer := TLayer.create(cCad_Mes8); GCadForm.PCad.Layers.Add(AddLayer); GCadForm.FActiveNet := nil; end; RaiseActiveNet(GCadForm); if GCadForm.PCad.LayerCount = 9 then begin AddLayer := TLayer.create(cCad_Mes29); GCadForm.PCad.Layers.Add(AddLayer); end; {//17.11.2011 GCadForm.FFrameProjectName := nil; GCadForm.FFrameListName := nil; GCadForm.FFrameCodeName := nil; GCadForm.FFrameIndexName := nil;} GCadForm.ClearFrameFigures; GNeedReRaiseProperties := False; VirtualCabinetExist := False; // 31.07.2015 // Tolik // копия блока см. ниже // для того, чтобы не "плыл" список фигур Када, который будем перебирать и обрабатывать, // здесь создадим слепок фигур Када и будем лазить по нему, а с Кадом сделаем, что захотим // и ничего нам не помешает, и сделаем все в один проход (а не в два) // БУДЕТ АКТУАЛЬНО, СКОРЕЕ ВСЕГО, ДЛЯ БИТЫХ ПРОЕКТОВ !!! CadFigList := TList.Create; // создаем пустой список if (GCadForm.PCad.NotExistInCatalog > 0) then begin // попытаемся создать if (GCadForm.PCad.NotExistInCatalog = 1) then begin PauseProgress(True); ShowMessageByType(0, smtDisplay, cCommon_Mes31, '', MB_ICONINFORMATION or MB_OK); PauseProgress(False); GCadForm.PCad.resAutoCreate := true; end else begin end; end; for i := 0 to GCadForm.PCad.FigureCount - 1 do // тулим в него все фигуры Када как есть begin CadFigList.Add(TFigure(GCadForm.PCad.Figures.Items[i])); end; for i := 0 to CadFigList.Count - 1 do begin Figure := TFigure(CadFigList[i]); NeedCheck := False; if CheckFigureByClassName(Figure, cTConnectorObject) then begin TConnectorObject(Figure).RaiseProperties(CadFigList); if TConnectorObject(Figure).FHouse = nil then begin //NeedCheck := True; end else begin { for j := 0 to Length(TConnectorObject(Figure).FHouse.FApproachesIndexes) - 1 do begin if TConnectorObject(GCadForm.PCad.Figures.Items[TConnectorObject(Figure).FHouse.FApproachesIndexes[j]]).ID = Figure.ID then begin //NeedCheck := True; break; end; end; } if TConnectorObject(Figure).FIsApproach then begin if F_ProjMan.GSCSBase.CurrProject.GetComponentFromReferencesList(GCadForm.FCADListID, TConnectorObject(Figure).FComponID) = nil then begin SCSCatalog := nil; if TConnectorObject(Figure).FHouse <> nil then SCSCatalog := F_ProjMan.GSCSBase.CurrProject.CheckCatalogFromReferencesBySCSID(TConnectorObject(Figure).FHouse.ID, GCadForm.FCADListID, isDuplicate); SCSCompon := nil; if SCSCatalog <> nil then SCSCompon := SCSCatalog.GetFirstComponent; if SCSCompon <> nil then begin // вернулся дом. теперь по индексу или маркировке попробуем найти нужный чилд for j := 0 to SCSCompon.ChildReferences.Count - 1 do begin if ListOfUse.Indexof(TSCSComponent(SCSCompon.ChildReferences[j])) = -1 then begin TConnectorObject(Figure).FComponID := TSCSComponent(SCSCompon.ChildReferences[j]).ID; ListOfUse.Add(TSCSComponent(SCSCompon.ChildReferences[j])); break; end; end; end else begin {TODO} // удалить из всех мест этот подьезд // выставить Deleted подъезду // НЕ ПРОВТЫКАТЬ ЧТО ИМЕННО В ТОМ МЕСТЕ НЕЛЬЗЯ удалять и что-то чистить - так как пока не прошли все фигуры через RaiseProperties - ничего удалять нельзя с КАДа end; end; end; end; if not TConnectorObject(Figure).deleted then begin if (GCadForm.PCad.NotExistInCatalog = 1) then begin if TConnectorObject(Figure).ConnectorType = ct_Clear then begin // если это коннектор прицепленный к ТО - то такого коннектора и не должно быть в ПМке if length(TConnectorObject(Figure).FJoinedConnectorsIndexes) = 0 then begin SCSCatalog := nil; SCSCatalog := F_ProjMan.GSCSBase.CurrProject.GetCatalogFromReferencesBySCSID(Figure.ID); if SCSCatalog = nil then begin createID := GCadForm.CreateConnectorInPM(Figure); //TF_Cad(self.Owner).CreateConnectorInPM(Figure); if createID < 0 then GCadForm.PCad.resAutoCreate := false; //beep; end; end; end; end; end; end else if CheckFigureByClassName(Figure, cTOrthoLine) then begin TOrthoLine(Figure).RaiseProperties(CadFigList); try begin currLine := TOrthoLine(Figure); if (currLine.JoinConnector1 <> nil) and (currLine.JoinConnector2 <> nil) then if (not currLine.JoinConnector1.Deleted) and (not currLine.JoinConnector2.Deleted) then if (TConnectorObject(currLine.JoinConnector1).JoinedConnectorsList <> nil) and (TConnectorObject(currLine.JoinConnector2).JoinedConnectorsList <> nil) then if (TConnectorObject(currLine.JoinConnector1).JoinedConnectorsList.Count > 0) and (TConnectorObject(currLine.JoinConnector2).JoinedConnectorsList.Count > 0) then if TConnectorObject(TConnectorObject(currLine.JoinConnector1).JoinedConnectorsList[0]).ID = TConnectorObject(TConnectorObject(currLine.JoinConnector2).JoinedConnectorsList[0]).ID then AddExceptionToLog('The OrthoLine '+ inttostr(currLine.FIndex) + ' has the same object on both Connectors !!!'); end; except // on e: Exception do showmessage('Tolik Error'); on e: Exception do addExceptionToLogEx('Tolik Error', E.Message); end; //NeedCheck := True; end else if CheckFigureByClassName(Figure, cTFrame) then begin TFrame(Figure).RaiseProperties; end else if CheckFigureByClassName(Figure, cTPlanTrace) then begin TPlanTrace(Figure).RaiseProperties(CadFigList); end else if CheckFigureByClassName(Figure, cTPlanObject) then begin TPlanObject(Figure).RaiseProperties(CadFigList); end else if CheckFigureByClassName(Figure, cTPlanConnector) then begin TPlanConnector(Figure).RaiseProperties(CadFigList); end else if CheckFigureByClassName(Figure, cTCabinet) then begin TCabinet(Figure).RaiseProperties(CadFigList); if TCabinet(Figure).FType = ct_Virtual then VirtualCabinetExist := True; //else // NeedCheck := True; end else if CheckFigureByClassName(Figure, cTCabinetExt) then begin TCabinetExt(Figure).RaiseProperties(CadFigList); if TCabinetExt(Figure).FType = ct_Virtual then VirtualCabinetExist := True; //else // NeedCheck := True; end else if CheckFigureByClassName(Figure, 'TRichText') then begin ObjIdx := GCadForm.FFrameObjects.IndexOf(IntToStr(TRichText(Figure).DataID)); if ObjIdx <> -1 then GCadForm.FFrameObjects.Objects[ObjIdx] := TRichText(Figure); end else if CheckFigureByClassName(Figure, cTSCSFigureGrp) then TSCSFigureGrp(Figure).RaiseProperties(CadFigList) else if CheckFigureByClassName(Figure, cTHouse) then begin THouse(Figure).RaiseProperties(CadFigList); NeedCheck := True; end; if NeedCheck then begin isDuplicate := False; SCSCatalog := F_ProjMan.GSCSBase.CurrProject.CheckCatalogFromReferencesBySCSID(Figure.ID, GCadForm.FCADListID, isDuplicate); if Assigned(SCSCatalog) then begin // все гуд - найден на том листе что нужно! // проверим на дубли if isDuplicate then begin // есть еще с таким же ИД на других листах // лог КРИТИЧЕСКИЙ, что с таким далее делать - нужно будет думать {TODO} end; end else begin if isDuplicate then begin // не найден, но есть дубли // лог КРИТИЧЕСКИЙ, что с таким далее делать - нужно будет думать {TODO} end else begin // не найден, возможно с таким ИД и есть - но не на нужном нам листе //лог и флаг на удаление //Tolik 27/10/2015 if not Figure.Deleted then // Figure.Deleted := True; {TODO} // в лог добавить end; end; end; end; CheckRestoreConnections; // Tolik 06/11/2018 -- FreeAndNil(CadFigList); if (GCadForm.PCad.NotExistInCatalog > 0) then begin if (GCadForm.PCad.NotExistInCatalog = 1) then begin ProjectNeedResave := true; //SetProjectChanged(True); //GProjectChanged := true; if not GCadForm.PCad.resAutoCreate then begin //не все созданы - сообщить что проект уже битенький PauseProgress(True); ShowMessageByType(0, smtDisplay, cCommon_Mes32, '', MB_ICONINFORMATION or MB_OK); PauseProgress(False); end else begin PauseProgress(True); ShowMessageByType(0, smtDisplay, cCommon_Mes33, '', MB_ICONINFORMATION or MB_OK); PauseProgress(False); end; end else begin PauseProgress(True); ShowMessageByType(0, smtDisplay, cCommon_Mes34, '', MB_ICONINFORMATION or MB_OK); PauseProgress(False); end; end; GCadForm.PCad.resAutoCreate := true; GCadForm.PCad.NotExistInCatalog := 0; a := 0; while a < GCadForm.PCad.FigureCount do begin if TFigure(GCadForm.PCad.Figures[a]).Deleted then begin if CheckFigureByClassName(TFigure(GCadForm.PCad.Figures[a]), cTHouse) then begin //Tolik 27/10/2015 if THouse(GCadForm.PCad.Figures[a]).deleted = False then begin // THouse(GCadForm.PCad.Figures[a]).Deleted := False; THouse(GCadForm.PCad.Figures[a]).Delete; end; a := a + 1; end else begin //Tolik { TFigure(GCadForm.PCad.Figures[a]).destroy; GCadForm.PCad.Figures.Remove(GCadForm.PCad.Figures[a]);} FFigure := TFigure(GCadForm.PCad.Figures[a]); // 10/11/2016-- DeleteFigureFromCadAndPM(FFigure); // {GCadForm.PCad.Figures.Remove(FFigure); FreeAndNil(FFigure);} // end; end else // Tolik -- 16/01/2017 - - удалить ни к чему не привязанные групповые фигуры с КАДа // a := a + 1; begin if ((TFigure(GCadForm.PCad.Figures[a]).ClassName = 'TFigureGrpMod') and (not TFigureGRPMod(GCadForm.PCad.Figures[a]).fHasParent)) then TFigureGRPMod(GCadForm.PCad.Figures[a]).Delete else if ((TFigure(GCadForm.PCad.Figures[a]).ClassName = 'TFigureGrpNotMod') and (not TFigureGRPNotMod(GCadForm.PCad.Figures[a]).fHasParent)) then TFigureGRPNotMod(GCadForm.PCad.Figures[a]).Delete; a := a + 1; end; end; // Tolik -- сюда, теоретически уже не попадаем совсем if GNeedReRaiseProperties then begin i := 0; while i < GCadForm.PCad.FigureCount do begin Figure := TFigure(GCadForm.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; (* for i := 0 to GCadForm.PCad.FigureCount - 1 do begin Figure := TFigure(GCadForm.PCad.Figures.Items[i]); NeedCheck := False; if CheckFigureByClassName(Figure, cTConnectorObject) then begin TConnectorObject(Figure).RaiseProperties; if TConnectorObject(Figure).FHouse = nil then begin //NeedCheck := True; end else begin { for j := 0 to Length(TConnectorObject(Figure).FHouse.FApproachesIndexes) - 1 do begin if TConnectorObject(GCadForm.PCad.Figures.Items[TConnectorObject(Figure).FHouse.FApproachesIndexes[j]]).ID = Figure.ID then begin //NeedCheck := True; break; end; end; } if TConnectorObject(Figure).FIsApproach then begin if F_ProjMan.GSCSBase.CurrProject.GetComponentFromReferencesList(GCadForm.FCADListID, TConnectorObject(Figure).FComponID) = nil then begin SCSCatalog := nil; if TConnectorObject(Figure).FHouse <> nil then SCSCatalog := F_ProjMan.GSCSBase.CurrProject.CheckCatalogFromReferencesBySCSID(TConnectorObject(Figure).FHouse.ID, GCadForm.FCADListID, isDuplicate); SCSCompon := nil; if SCSCatalog <> nil then SCSCompon := SCSCatalog.GetFirstComponent; if SCSCompon <> nil then begin // вернулся дом. теперь по индексу или маркировке попробуем найти нужный чилд for j := 0 to SCSCompon.ChildReferences.Count - 1 do begin if ListOfUse.Indexof(TSCSComponent(SCSCompon.ChildReferences[j])) = -1 then begin TConnectorObject(Figure).FComponID := TSCSComponent(SCSCompon.ChildReferences[j]).ID; ListOfUse.Add(TSCSComponent(SCSCompon.ChildReferences[j])); break; end; end; end else begin {TODO} // удалить из всех мест этот подьезд // выставить Deleted подъезду // НЕ ПРОВТЫКАТЬ ЧТО ИМЕННО В ТОМ МЕСТЕ НЕЛЬЗЯ удалять и что-то чистить - так как пока не прошли все фигуры через RaiseProperties - ничего удалять нельзя с КАДа end; end; end; end; end else if CheckFigureByClassName(Figure, cTOrthoLine) then begin TOrthoLine(Figure).RaiseProperties; //NeedCheck := True; end else if CheckFigureByClassName(Figure, cTFrame) then begin TFrame(Figure).RaiseProperties; end else if CheckFigureByClassName(Figure, cTPlanTrace) then begin TPlanTrace(Figure).RaiseProperties; end else if CheckFigureByClassName(Figure, cTPlanObject) then begin TPlanObject(Figure).RaiseProperties; end else if CheckFigureByClassName(Figure, cTPlanConnector) then begin TPlanConnector(Figure).RaiseProperties; end else if CheckFigureByClassName(Figure, cTCabinet) then begin TCabinet(Figure).RaiseProperties; if TCabinet(Figure).FType = ct_Virtual then VirtualCabinetExist := True; //else // NeedCheck := True; end else if CheckFigureByClassName(Figure, cTCabinetExt) then begin TCabinetExt(Figure).RaiseProperties; if TCabinetExt(Figure).FType = ct_Virtual then VirtualCabinetExist := True; //else // NeedCheck := True; end else if CheckFigureByClassName(Figure, 'TRichText') then begin ObjIdx := GCadForm.FFrameObjects.IndexOf(IntToStr(TRichText(Figure).DataID)); if ObjIdx <> -1 then GCadForm.FFrameObjects.Objects[ObjIdx] := TRichText(Figure); end else if CheckFigureByClassName(Figure, cTSCSFigureGrp) then TSCSFigureGrp(Figure).RaiseProperties else if CheckFigureByClassName(Figure, cTHouse) then begin THouse(Figure).RaiseProperties; NeedCheck := True; end; if NeedCheck then begin isDuplicate := False; SCSCatalog := F_ProjMan.GSCSBase.CurrProject.CheckCatalogFromReferencesBySCSID(Figure.ID, GCadForm.FCADListID, isDuplicate); if Assigned(SCSCatalog) then begin // все гуд - найден на том листе что нужно! // проверим на дубли if isDuplicate then begin // есть еще с таким же ИД на других листах // лог КРИТИЧЕСКИЙ, что с таким далее делать - нужно будет думать {TODO} end; end else begin if isDuplicate then begin // не найден, но есть дубли // лог КРИТИЧЕСКИЙ, что с таким далее делать - нужно будет думать {TODO} end else begin // не найден, возможно с таким ИД и есть - но не на нужном нам листе //лог и флаг на удаление Figure.Deleted := True; {TODO} // в лог добавить end; end; end; end; a := 0; while a < GCadForm.PCad.FigureCount do begin if TFigure(GCadForm.PCad.Figures[a]).Deleted then begin if CheckFigureByClassName(TFigure(GCadForm.PCad.Figures[a]), cTHouse) then begin THouse(GCadForm.PCad.Figures[a]).Deleted := False; THouse(GCadForm.PCad.Figures[a]).Delete; a := a + 1; end else begin //Tolik { TFigure(GCadForm.PCad.Figures[a]).destroy; GCadForm.PCad.Figures.Remove(GCadForm.PCad.Figures[a]);} FFigure := TFigure(GCadForm.PCad.Figures[a]); GCadForm.PCad.Figures.Remove(GCadForm.PCad.Figures[a]); FreeAndNil(FFigure); // end; end else a := a + 1; end; if GNeedReRaiseProperties then begin i := 0; while i < GCadForm.PCad.FigureCount do begin Figure := TFigure(GCadForm.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; *) GCadForm.SetFrameFigures; CorrectStampView; if not VirtualCabinetExist then CreateVirtualCabinetInCAD(GCadForm); SetVisibleCabinetsNumbers(GCadForm.FShowCabinetsNumbers); SetVisibleCabinetsBounds(GCadForm.FShowCabinetsBounds); FindObjectsForConvertClasses; SetCADFrameParams(GCadForm); if GListRaiseWithErrors then begin ShowLog; GListRaiseWithErrors := False; end; end; except on E: Exception do addExceptionToLogEx(cCommon_Mes9 + GCadForm.FCADListName + IntToStr(GCadForm.FCADListIndex) + cCommon_Mes10, E.Message); end; if ListStream <> nil then FreeAndNil(ListStream); // Tolik 10/02/2021 -- (* if GCadForm.FListType = lt_Normal then {$IF Defined(ES_GRAPH_SC)} GCadForm.CurrentLayer := 8; {$else} GCadForm.CurrentLayer := 2; {$ifend} if GCadForm.FListType = lt_DesignBox then GCadForm.CurrentLayer := 1; if GCadForm.FListType = lt_ProjectPlan then GCadForm.CurrentLayer := 1; *) if GCadForm.FListType = lt_Normal then begin {$IF Defined(ES_GRAPH_SC)} GCadForm.CurrentLayer := 8; {$else} GCadForm.CurrentLayer := 2; {$ifend} end else if GCadForm.FListType in [lt_DesignBox, lt_ProjectPlan, lt_ElScheme, lt_AScheme] then GCadForm.CurrentLayer := 1; // if GCadForm.PCad.ZoomScale < 50 then GCadForm.SetZoomScale(50); // Добавить переключатель в панель листов проекта FSCS_Main.pageCADList.DisableAlign; try NewTab := TTabSheet.Create(nil); NewTab.PageControl := FSCS_Main.pageCADList; NewTab.Tag := GCadForm.Handle; NewTab.Caption := ListCaption; FSCS_Main.pageCADList.ActivePage := NewTab; finally FSCS_Main.pageCADList.EnableAlign; end; // Добавить Листы в главное меню for i := 0 to FSCS_Main.mainWindow.Count - 1 do if FSCS_Main.mainWindow.Items[i].Caption = '-' then break; j := 0; inc(i); while FSCS_Main.mainWindow.Count > i do begin MenuItem := FSCS_Main.mainWindow.Items[FSCS_Main.mainWindow.Count - 1]; FSCS_Main.mainWindow.Delete(FSCS_Main.mainWindow.Count - 1); MenuItem.Free; end; for j := 0 to FSCS_Main.pageCADList.PageCount - 1 do begin MenuItem := TMenuItem.Create(nil); MenuItem.Caption := FSCS_Main.pageCADList.Pages[j].Caption; MenuItem.Tag := FSCS_Main.pageCADList.Pages[j].Tag; MenuItem.AutoCheck := True; MenuItem.RadioItem := True; MenuItem.Checked := FSCS_Main.pageCADList.Pages[j] = FSCS_Main.pageCADList.ActivePage; MenuItem.OnClick := FSCS_Main.SwitchWindow; FSCS_Main.mainWindow.Add(MenuItem); end; finally ListOfUse.Free; GCadForm.PCad.EndUpdate; GCadForm.PCad.EnableAlign; //27.12.2011 RefreshFlag := GCanRefreshCad; GCanRefreshCad := True; GCadForm.PCad.SetFocus; // Tolik 04/01/2020 GCadForm.PCad.Refresh; if GCadForm.FListSettings.ShowTracesCrossPoints > 0 then //13/09/2017 -- ShowTracesIntersections(2, GCadForm.FListSettings.ShowTracesCrossPoints); GCanRefreshCad := RefreshFlag; // end; except on E: Exception do addExceptionToLogEx('U_Common.OpenListsInProject', E.Message); end; //GCanRefreshCad := RefreshFlag; end; function CreateListDuplicate(AListParams: TListParams; AListStream: TMemoryStream; AFileName: string = ''; aCopySCSFigures: Boolean=true): TF_CAD; var NewTab: TTabSheet; MenuItem: TMenuItem; i, j: integer; //08.09.2011 Buffer: array[0..1023] of Char; TempPath: string; ListSettings: TListSettingRecord; PrjCaption: string; ListCaption: String; Addlayer: TLayer; ListStream: TMemoryStream; Conn: TConnectorObject; SCSFigureGrp: TSCSFigureGrp; ObjIdx: Integer; Figure: TFigure; ListToDel: TList; //Tolik CadFigList: TList; RefreshFlag: Boolean; // begin Result := nil; BeginProgress; try TF_CAD.Create(FSCS_Main); Result := GCadForm; //07.11.2011 if Result.WindowState <> wsMaximized then Result.WindowState := wsMaximized; try //GCadForm.LockSCSFigures; //07.11.2011 GCadForm.FCADListID := AListParams.ID; GCadForm.FCADListName := AListParams.Name; GCadForm.FCADProjectName := GetCurrProjectName; LoadSettingsForList(GCadForm.FCADListID, False); //EndProgress; Exit; ///// EXIT ///// PrjCaption := GetCurrProjectParams.Caption; ListCaption := GetListParams(GCadForm.FCADListID).Caption; GCadForm.Caption := PrjCaption + ' - ' + ListCaption; GCadForm.PCad.BeginUpdate; //01.07.2013 try if AListStream <> nil then begin TempPath := GetAnsiTempPath; //08.09.2011 SetString(TempPath, Buffer, GetTempPath(Sizeof(Buffer) - 1, Buffer)); AListStream.SaveToFile(TempPath + 'tempCAD.pwd'); // подгрузить из файла GCadForm.PCad.OnObjectInserted := nil; GCadForm.PCad.LoadFromFile(TempPath + 'tempCAD.pwd'); GCadForm.PCad.OnObjectInserted := GCadForm.PCadObjectInserted; end else if AFileName <> '' then begin // подгрузить из файла GCadForm.PCad.OnObjectInserted := nil; GCadForm.PCad.LoadFromFile(AFileName); GCadForm.PCad.OnObjectInserted := GCadForm.PCadObjectInserted; end; CorrectStampView; //01.07.2013 - чтобы объектам рамки установить правильное значение свойства Visible finally GCadForm.PCad.EndUpdate; //01.07.2013 end; //EndProgress; //Exit; ///// EXIT ///// if (AListStream <> nil) or (AFileName <> '') then begin RaiseActiveNet(GCadForm); {//17.11.2011 GCadForm.FFrameProjectName := nil; GCadForm.FFrameListName := nil; GCadForm.FFrameCodeName := nil; GCadForm.FFrameIndexName := nil; GCadForm.FFrameStampDeveloper := nil; GCadForm.FFrameStampChecker := nil;} GCadForm.ClearFrameFigures; GNeedReRaiseProperties := False; //Tolik CadFigList := TList.Create; for i := 0 to GCadForm.PCad.FigureCount - 1 do CadFigList.Add(TFigure(GCadForm.PCad.Figures.Items[i])); (* for i := 0 to GCadForm.PCad.FigureCount - 1 do begin if CheckFigureByClassName(TFigure(GCadForm.PCad.Figures.Items[i]), cTConnectorObject) then begin if TConnectorObject(GCadForm.PCad.Figures.Items[i]).AsEndPoint then TConnectorObject(GCadForm.PCad.Figures.Items[i]).AsEndPoint := False; TConnectorObject(GCadForm.PCad.Figures.Items[i]).RaiseProperties; end; if CheckFigureByClassName(TFigure(GCadForm.PCad.Figures.Items[i]), cTOrthoLine) then TOrthoLine(GCadForm.PCad.Figures.Items[i]).RaiseProperties; if CheckFigureByClassName(TFigure(GCadForm.PCad.Figures.Items[i]), cTFrame) then TFrame(GCadForm.PCad.Figures.Items[i]).RaiseProperties; if CheckFigureByClassName(TFigure(GCadForm.PCad.Figures.Items[i]), cTPlanTrace) then TPlanTrace(GCadForm.PCad.Figures.Items[i]).RaiseProperties; if CheckFigureByClassName(TFigure(GCadForm.PCad.Figures.Items[i]), cTPlanObject) then TPlanObject(GCadForm.PCad.Figures.Items[i]).RaiseProperties; if CheckFigureByClassName(TFigure(GCadForm.PCad.Figures.Items[i]), cTPlanConnector) then TPlanConnector(GCadForm.PCad.Figures.Items[i]).RaiseProperties; if CheckFigureByClassName(TFigure(GCadForm.PCad.Figures.Items[i]), cTCabinet) then TCabinet(GCadForm.PCad.Figures.Items[i]).RaiseProperties; if CheckFigureByClassName(TFigure(GCadForm.PCad.Figures.Items[i]), cTCabinetExt) then TCabinetExt(GCadForm.PCad.Figures.Items[i]).RaiseProperties; if CheckFigureByClassName(TFigure(GCadForm.PCad.Figures.Items[i]), cTHouse) then THouse(GCadForm.PCad.Figures.Items[i]).RaiseProperties; if CheckFigureByClassName(TFigure(GCadForm.PCad.Figures.Items[i]), 'TRichText') then begin {//17.11.2011 if TRichText(GCadForm.PCad.Figures.Items[i]).DataID = 100 then GCadForm.FFrameProjectName := TRichText(GCadForm.PCad.Figures.Items[i]); if TRichText(GCadForm.PCad.Figures.Items[i]).DataID = 200 then GCadForm.FFrameListName := TRichText(GCadForm.PCad.Figures.Items[i]); if TRichText(GCadForm.PCad.Figures.Items[i]).DataID = 300 then GCadForm.FFrameCodeName := TRichText(GCadForm.PCad.Figures.Items[i]); if TRichText(GCadForm.PCad.Figures.Items[i]).DataID = 400 then GCadForm.FFrameIndexName := TRichText(GCadForm.PCad.Figures.Items[i]);} ObjIdx := GCadForm.FFrameObjects.IndexOf(IntToStr(TRichText(GCadForm.PCad.Figures.Items[i]).DataID)); if ObjIdx <> -1 then GCadForm.FFrameObjects.Objects[ObjIdx] := TRichText(GCadForm.PCad.Figures.Items[i]); end; if CheckFigureByClassName(TFigure(GCadForm.PCad.Figures.Items[i]), cTSCSFigureGrp) then begin SCSFigureGrp := TSCSFigureGrp(GCadForm.PCad.Figures.Items[i]); for j := 0 to SCSFigureGrp.InFigures.Count - 1 do begin if CheckFigureByClassName(TFigure(SCSFigureGrp.InFigures[j]), cTConnectorObject) then if TConnectorObject(SCSFigureGrp.InFigures[j]).AsEndPoint then TConnectorObject(SCSFigureGrp.InFigures[j]).AsEndPoint := False; end; TSCSFigureGrp(GCadForm.PCad.Figures.Items[i]).RaiseProperties; end; end;*) for i := 0 to CadFigList.Count - 1 do begin if CheckFigureByClassName(TFigure(CadFigList[i]), cTConnectorObject) then begin if TConnectorObject(CadFigList[i]).AsEndPoint then TConnectorObject(CadFigList[i]).AsEndPoint := False; TConnectorObject(CadFigList[i]).RaiseProperties(CadFigList); end; if CheckFigureByClassName(TFigure(CadFigList[i]), cTOrthoLine) then TOrthoLine(CadFigList[i]).RaiseProperties(CadFigList); if CheckFigureByClassName(TFigure(CadFigList[i]), cTFrame) then TFrame(CadFigList[i]).RaiseProperties; if CheckFigureByClassName(TFigure(CadFigList[i]), cTPlanTrace) then TPlanTrace(CadFigList[i]).RaiseProperties(CadFigList); if CheckFigureByClassName(TFigure(CadFigList[i]), cTPlanObject) then TPlanObject(CadFigList[i]).RaiseProperties(CadFigList); if CheckFigureByClassName(TFigure(CadFigList[i]), cTPlanConnector) then TPlanConnector(CadFigList[i]).RaiseProperties(CadFigList); if CheckFigureByClassName(TFigure(CadFigList[i]), cTCabinet) then TCabinet(CadFigList[i]).RaiseProperties(CadFigList); if CheckFigureByClassName(TFigure(CadFigList[i]), cTCabinetExt) then TCabinetExt(CadFigList[i]).RaiseProperties(CadFigList); if CheckFigureByClassName(TFigure(CadFigList[i]), cTHouse) then THouse(CadFigList[i]).RaiseProperties(CadFigList); if CheckFigureByClassName(TFigure(CadFigList[i]), 'TRichText') then begin ObjIdx := GCadForm.FFrameObjects.IndexOf(IntToStr(TRichText(CadFigList[i]).DataID)); if ObjIdx <> -1 then GCadForm.FFrameObjects.Objects[ObjIdx] := TRichText(CadFigList[i]); end; if CheckFigureByClassName(TFigure(CadFigList[i]), cTSCSFigureGrp) then begin SCSFigureGrp := TSCSFigureGrp(CadFigList[i]); for j := 0 to SCSFigureGrp.InFigures.Count - 1 do begin if CheckFigureByClassName(TFigure(SCSFigureGrp.InFigures[j]), cTConnectorObject) then if TConnectorObject(SCSFigureGrp.InFigures[j]).AsEndPoint then TConnectorObject(SCSFigureGrp.InFigures[j]).AsEndPoint := False; end; TSCSFigureGrp(CadFigList[i]).RaiseProperties(CadFigList); end; end; { if GNeedReRaiseProperties then begin i := 0; while i < GCadForm.PCad.FigureCount do begin Figure := TFigure(GCadForm.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;} // Tolik FreeAndNil(CadFigList); // GCadForm.SetFrameFigures; SetVisibleCabinetsNumbers(GCadForm.FShowCabinetsNumbers); SetVisibleCabinetsBounds(GCadForm.FShowCabinetsBounds); FindObjectsForConvertClasses; SetCADFrameParams(GCadForm); if GListRaiseWithErrors then begin ShowLog; GListRaiseWithErrors := False; end; //18.06.2013 - Удаляем СКС объекты, если флаг сброшен { if Not aCopySCSFigures then begin // Tolik -- 24/07/2017 -*- RefreshFlag := GCanRefreshCad; GCanRefreshCad := False; // try ListToDel := TList.Create; // Tolik -- 28/06/2016 -- //for i := 0 to GCadForm.PCad.FigureCount - 1 do for i := 0 to GCadForm.FSCSFigures.Count - 1 do // begin // Tolik 28/06/2016-- //Figure := TFigure(GCadForm.PCad.Figures.Items[i]); Figure := TFigure(GCadForm.FSCSFigures[i]); // Tolik -- 24/07/2017 -*- if not Figure.deleted then if ListToDel.indexof(Figure) = -1 then begin // if CheckFigureByClassName(Figure, cTConnectorObject) then begin TConnectorObject(Figure).ID := 0; // Tolik -- 06/03/2017 -- if TConnectorObject(Figure).ConnectorType = ct_Clear then begin TConnectorObject(Figure).FID_ConnToPassage := -1; TConnectorObject(Figure).FID_ListToPassage := -1; end; // ListToDel.Add(Figure); end else if CheckFigureByClassName(Figure, cTOrthoLine) then begin TOrthoLine(Figure).ID := 0; ListToDel.Add(Figure); end else if CheckFigureByClassName(Figure, cTSCSFigureGrp) then begin SCSFigureGrp := TSCSFigureGrp(Figure); ListToDel.Add(Figure); end; end; end; if ListToDel.Count > 0 then begin for i := ListToDel.Count - 1 downto 0 do begin Figure := TFigure(ListToDel[i]); if CheckFigureByClassName(Figure, cTConnectorObject) then TConnectorObject(Figure).Delete else if CheckFigureByClassName(Figure, cTOrthoLine) then TOrthoLine(Figure).Delete else if CheckFigureByClassName(Figure, cTSCSFigureGrp) then TSCSFigureGrp(Figure).Delete; end; //RefreshCAD(GCadForm.PCad); end; FreeAndNil(ListToDel); except on E: Exception do AddExceptionToLogExt('U_Common', 'CopyList:removeSCSObjects', E.Message); end; // Tolik 24/07/2017 -- GCanRefreshCad := RefreshFlag; //RefreshCAD(GCadForm.PCad); // end; } end; if AListStream <> nil then FreeAndNil(ListStream); FSCS_Main.aSetSCSLayer.Execute; // Добавить переключатель в панель листов проекта NewTab := TTabSheet.Create(nil); NewTab.PageControl := FSCS_Main.pageCADList; NewTab.Tag := GCadForm.Handle; NewTab.Caption := ListCaption; FSCS_Main.pageCADList.ActivePage := NewTab; // Добавить Листы в главное меню for i := 0 to FSCS_Main.mainWindow.Count - 1 do if FSCS_Main.mainWindow.Items[i].Caption = '-' then break; j := 0; inc(i); while FSCS_Main.mainWindow.Count > i do begin MenuItem := FSCS_Main.mainWindow.Items[FSCS_Main.mainWindow.Count - 1]; FSCS_Main.mainWindow.Delete(FSCS_Main.mainWindow.Count - 1); MenuItem.Free; end; for j := 0 to FSCS_Main.pageCADList.PageCount - 1 do begin MenuItem := TMenuItem.Create(nil); MenuItem.Caption := FSCS_Main.pageCADList.Pages[j].Caption; MenuItem.Tag := FSCS_Main.pageCADList.Pages[j].Tag; MenuItem.AutoCheck := True; MenuItem.RadioItem := True; MenuItem.Checked := FSCS_Main.pageCADList.Pages[j] = FSCS_Main.pageCADList.ActivePage; MenuItem.OnClick := FSCS_Main.SwitchWindow; FSCS_Main.mainWindow.Add(MenuItem); end; if GCadForm.FListType = lt_Normal then begin EnableOptionsForNormalList; end else if GCadForm.FListType = lt_DesignBox then begin DisableOptionsForDesignList; end else if GCadForm.FListType = lt_ProjectPlan then begin DisableOptionsForDesignList; end else if GCadForm.FListType = lt_ElScheme then begin DisableOptionsForEl_Scheme; end else if GCadForm.FListType = lt_AScheme then begin DisableOptionsForEl_Scheme; end; // SkipAllLinesShadows(GCadForm); // установить параметры листа от мастера создания листа // LoadSettingsForListByParams(AListParams); // SaveListParams(GCadForm.FCADListID, AListParams); finally //GCadForm.UnLockSCSFigures; //07.11.2011 end; except on E: Exception do addExceptionToLogEx('U_Common.CreateListDuplicate', E.Message); end; EndProgress; end; procedure SetNewListParams(aCADParams: TCADParams; AMakeEdit: TMakeEdit = meEdit); var i: integer; val: double; ScaleAs: double; ScaleAll: double; KoefAs: double; KoefAll: double; PageKoef: double; GetConnHeight: Double; GetLineHeight: Double; PrjCaption: string; ListCaption: string; valInteger: Integer; valDouble: double; SavedUndoFlag: Boolean; begin SavedUndoFlag := GlobalDisableSaveForUndo; GCanRefreshCad := True; try // ЛИНЕЙКА ScaleAs := 0; ScaleAll := 0; KoefAs := 0; KoefAll := 0; PageKoef := 0; // Tolik -- 04/10/2016 -- // *UNDO* if ((AMakeEdit = meEdit) or ((AMakeEdit = meMake) and (GCadForm.FListType = lt_Normal))) then // Tolik 31/05/2021 -- иначе для листов со схемами по ctrl+Z удалится содержимое begin if GCadForm.FCanSaveForUndo then begin GCadForm.SaveForUndo(uat_None, True, False); GCadForm.FCanSaveForUndo := False; end; end; GlobalDisableSaveForUndo := True; // Блокануть все "УНДЫ" нахер! GCanRefreshCad := True; // //21.09.2010 // // МЕТРИЧЕСКАЯ // if F_MasterNewList.gbRulerModeMetric.Visible then // begin // // для показа отдельного отрезка на экране // if F_MasterNewList.rbm1.Checked then // KoefAs := 100; // if F_MasterNewList.rbsm1.Checked then // KoefAs := 1; // if F_MasterNewList.rbmm1.Checked then // KoefAs := 0.1; // if (F_MasterNewList.rbm1.Checked) Or (F_MasterNewList.rbsm1.Checked) Or (F_MasterNewList.rbmm1.Checked) then // begin // if F_MasterNewList.edSizeAsMetric.Text <> '' then // begin // ScaleAs := StrToFloat_My(F_MasterNewList.edSizeAsMetric.Text) * KoefAs; // valDouble := ScaleAs; // if aCADParams.CADMapScale <> valDouble then // begin // GCadForm.PCad.MapScale := valDouble; // ReScaleAllDimLines; // end; // end; // end; // // для отображения общей длинны на странице // if F_MasterNewList.rbm2.Checked then // KoefAll := 1; // if F_MasterNewList.rbsm2.Checked then // KoefAll := 100; // if F_MasterNewList.rbmm2.Checked then // KoefAll := 1000; // if (F_MasterNewList.rbm2.Checked) Or (F_MasterNewList.rbsm2.Checked) Or (F_MasterNewList.rbmm2.Checked) then // begin // if F_MasterNewList.edSizeAllMetric.Text <> '' then // begin // PageKoef := GCadForm.PCad.WorkWidth / 1000; // ScaleAll := StrToFloat_My(F_MasterNewList.edSizeAllMetric.Text) / PageKoef / KoefAll; // valDouble := ScaleAll; // if aCADParams.CADMapScale <> valDouble then // begin // GCadForm.PCad.MapScale := valDouble; // ReScaleAllDimLines; // end; // end; // end; // end // else // // ДЮЙМОВАЯ // if F_MasterNewList.gbRulerModeWhitworth.Visible then // begin // // для показа отдельного отрезка на экране // if F_MasterNewList.rbin1.Checked then // KoefAs := 1; // if F_MasterNewList.rbft1.Checked then // KoefAs := 12; // if (F_MasterNewList.rbin1.Checked) Or (F_MasterNewList.rbft1.Checked) then // begin // if F_MasterNewList.edSizeAsWhitworth.Text <> '' then // begin // ScaleAs := StrToFloat_My(F_MasterNewList.edSizeAsWhitworth.Text) * KoefAs; // valDouble := ScaleAs; // if aCADParams.CADMapScale <> valDouble then // begin // GCadForm.PCad.MapScale := valDouble; // ReScaleAllDimLines; // end; // end; // end; // // для отображения общей длинны на странице // if F_MasterNewList.rbin2.Checked then // KoefAll := 12; // if F_MasterNewList.rbft2.Checked then // KoefAll := 1; // if (F_MasterNewList.rbin2.Checked) Or (F_MasterNewList.rbft2.Checked) then // begin // if F_MasterNewList.edSizeAllWhitworth.Text <> '' then // begin // PageKoef := GCadForm.PCad.WorkWidth / 304.8 {/ 1000}; // ScaleAll := StrToFloat_My(F_MasterNewList.edSizeAllWhitworth.Text) / PageKoef / KoefAll; // valDouble := ScaleAll; // if aCADParams.CADMapScale <> valDouble then // begin // GCadForm.PCad.MapScale := valDouble; // ReScaleAllDimLines; // end; // end; // end; // end; //21.09.2010 valDouble := F_MasterNewList.CheckMapScaleResult; if (aCADParams.CADMapScale <> valDouble) or (GCadForm.PCad.MapScale <> valDouble) then begin GCadForm.PCad.MapScale := valDouble; ReScaleAllDimLines; end; // *** // коррекция шага сетки valDouble := StrToFloat_My(F_MasterNewList.edStepGrid.Text); if valDouble = 0 then valDouble := 0.1; if aCADParams.CADGridStep <> valDouble then GCadForm.PCad.GridStep := valDouble; // -- Tolik -- 28/06/2016 -- ни х так не работает, только бегает по всем фигурам 2 раза зря ... // в общем, пока -- нах, а там посмотрим // Просто присвоить имена объектам по формату {SetShowNameTypeInCAD(GCadForm.FShowObjectCaptionsType); SetShowNameTypeInCAD(GCadForm.FShowObjectNotesType);} SetShowNameTypeInCAD; // UpdateForLayers; PrjCaption := GetCurrProjectParams.Caption; ListCaption := GetListParams(GCadForm.FCADListID).Caption; // ИМЯ ЛИСТА if F_MasterNewList.edListName.Text <> '' then begin GCadForm.FCADListName := F_MasterNewList.edListName.Text; GCadForm.FCADProjectName := GetCurrProjectName; GCadForm.Caption := PrjCaption + ' - ' + ListCaption; end; SetNewListNameInPM(GCadForm.FCADListID, GCadForm.FCADListName); FSCS_Main.pageCADList.ActivePage.Caption := ListCaption; for i := 0 to FSCS_Main.mainWindow.Count - 1 do begin if FSCS_Main.mainWindow.Items[i].Checked then break; end; FSCS_Main.mainWindow.Items[i].Caption := ListCaption; // тип отображения сетей GCadForm.FShowNetworkTypes := []; if F_MasterNewList.cbAllNetworks.Checked then GCadForm.FShowNetworkTypes := [nt_All]; if F_MasterNewList.cbComputerNetwork.Enabled then if F_MasterNewList.cbComputerNetwork.Checked then GCadForm.FShowNetworkTypes := GCadForm.FShowNetworkTypes + [nt_Computer]; if F_MasterNewList.cbTelephonNetwork.Enabled then if F_MasterNewList.cbTelephonNetwork.Checked then GCadForm.FShowNetworkTypes := GCadForm.FShowNetworkTypes + [nt_Telephon]; if F_MasterNewList.cbElectricNetwork.Enabled then if F_MasterNewList.cbElectricNetwork.Checked then GCadForm.FShowNetworkTypes := GCadForm.FShowNetworkTypes + [nt_Electric]; if F_MasterNewList.cbTelevisionNetwork.Enabled then if F_MasterNewList.cbTelevisionNetwork.Checked then GCadForm.FShowNetworkTypes := GCadForm.FShowNetworkTypes + [nt_Television]; if F_MasterNewList.cbGasNetwork.Enabled then if F_MasterNewList.cbGasNetwork.Checked then GCadForm.FShowNetworkTypes := GCadForm.FShowNetworkTypes + [nt_Gas]; // тип уголка if F_MasterNewList.rbCornerNone.Checked then GCadForm.FDefaultCornerType := crn_None; if F_MasterNewList.rbCornerOut.Checked then GCadForm.FDefaultCornerType := crn_Out; if F_MasterNewList.rbCornerIn.Checked then GCadForm.FDefaultCornerType := crn_In; if F_MasterNewList.rbCornerVertical.Checked then GCadForm.FDefaultCornerType := crn_Vertical; if F_MasterNewList.rbCornerAdapter.Checked then GCadForm.FDefaultCornerType := crn_Adapter; GCadForm.FKeepLineTypesRules := F_MasterNewList.cbKeepLineTypesRules.Checked; SetDimLinesType(GCadForm.FDimLinesType); SetVisibleCabinetsNumbers(GCadForm.FShowCabinetsNumbers); SetVisibleCabinetsBounds(GCadForm.FShowCabinetsBounds); // тип подписи к трассе if aCADParams.CADLinesCaptions <> GCadForm.FShowLineCaptionsType then begin if GCadForm.FShowLineCaptionsType = skExternalSCS then SetAllTracesUserLength else SetAllTracesAutoLength; end; // проверить все кабинеты, переустановить высоты фальш-потолком если нужно // перепроверить все межэтажные подъемы, после изменения высоты этажа if aCADParams.CADHeightRoom <> GCadForm.FRoomHeight then begin CheckAllCabinetsFalseFloorHeights; SetAllBetweenFloorRaises; end; // применить настройки для всех объектов if F_MasterNewList.cbApplyForAllSCSObjects.Checked then begin GetConnHeight := UOMToMetre(StrToFloat_My(F_MasterNewList.edConnTotal.Text)); //Tolik 26/08/2021 -- //GetLineHeight := UOMToMetre(StrToFloat_My(F_MasterNewList.edLineTotal.Text)); GetLineHeight := StrToFloat_My(F_MasterNewList.edLineTotal.Text); // ApplyParamsForAllSCSObject(GetConnHeight, GetLineHeight, GCadForm.FShowObjectCaptionsType, GCadForm.FShowObjectNotesType, GCadForm.FShowLineCaptionsType, GCadForm.FShowLineNotesType, aCADParams); ApplyCornerTypeForConnectors(GCadForm.FDefaultCornerType); ApplyCaptionNotesParams(aCADParams); end; // обновить скроллы GCadForm.ChangeScrollsOnChangeListSize; // обновить навигатор ReAssignNavigatorParams; if (GCadForm <> nil) and (GCadForm.PCad <> nil) then begin RefreshCAD(GCadForm.PCad); end; except ShowMessage(cCommon_Mes11); F_MasterNewList.ModalResult := mrNone; end; GlobalDisableSaveForUndo := SavedUndoFlag; end; procedure SetNewListParamsForMaster(aCADParams: TCADParams); var i: integer; val: double; ScaleAs: double; ScaleAll: double; KoefAs: double; KoefAll: double; PageKoef: double; GetConnHeight: Double; GetLineHeight: Double; PrjCaption: string; ListCaption: string; valInteger: Integer; valDouble: double; FName: string; begin try // ЛИНЕЙКА ScaleAs := 0; ScaleAll := 0; KoefAs := 0; KoefAll := 0; PageKoef := 0; //21.09.2010 // // МЕТРИЧЕСКАЯ // if F_MasterNewListLite.gbRulerModeMetric.Visible then // begin // // для показа отдельного отрезка на экране // if F_MasterNewListLite.rbm1.Checked then // KoefAs := 100; // if F_MasterNewListLite.rbsm1.Checked then // KoefAs := 1; // if F_MasterNewListLite.rbmm1.Checked then // KoefAs := 0.1; // if (F_MasterNewListLite.rbm1.Checked) Or (F_MasterNewListLite.rbsm1.Checked) Or (F_MasterNewListLite.rbmm1.Checked) then // begin // if F_MasterNewListLite.edSizeAsMetric.Text <> '' then // begin // ScaleAs := StrToFloat_My(F_MasterNewListLite.edSizeAsMetric.Text) * KoefAs; // valDouble := ScaleAs; // if aCADParams.CADMapScale <> valDouble then // begin // GCadForm.PCad.MapScale := valDouble; // ReScaleAllDimLines; // end; // end; // end; // // для отображения общей длинны на странице // if F_MasterNewListLite.rbm2.Checked then // KoefAll := 1; // if F_MasterNewListLite.rbsm2.Checked then // KoefAll := 100; // if F_MasterNewListLite.rbmm2.Checked then // KoefAll := 1000; // if (F_MasterNewListLite.rbm2.Checked) Or (F_MasterNewListLite.rbsm2.Checked) Or (F_MasterNewListLite.rbmm2.Checked) then // begin // if F_MasterNewListLite.edSizeAllMetric.Text <> '' then // begin // PageKoef := GCadForm.PCad.WorkWidth / 1000; // ScaleAll := StrToFloat_My(F_MasterNewListLite.edSizeAllMetric.Text) / PageKoef / KoefAll; // valDouble := ScaleAll; // if aCADParams.CADMapScale <> valDouble then // begin // GCadForm.PCad.MapScale := valDouble; // ReScaleAllDimLines; // end; // end; // end; // end // else // // ДЮЙМОВАЯ // if F_MasterNewListLite.gbRulerModeWhitworth.Visible then // begin // // для показа отдельного отрезка на экране // if F_MasterNewListLite.rbin1.Checked then // KoefAs := 1; // if F_MasterNewListLite.rbft1.Checked then // KoefAs := 12; // if (F_MasterNewListLite.rbin1.Checked) Or (F_MasterNewListLite.rbft1.Checked) then // begin // if F_MasterNewListLite.edSizeAsWhitworth.Text <> '' then // begin // ScaleAs := StrToFloat_My(F_MasterNewListLite.edSizeAsWhitworth.Text) * KoefAs; // valDouble := ScaleAs; // if aCADParams.CADMapScale <> valDouble then // begin // GCadForm.PCad.MapScale := valDouble; // ReScaleAllDimLines; // end; // end; // end; // // для отображения общей длинны на странице // if F_MasterNewListLite.rbin2.Checked then // KoefAll := 12; // if F_MasterNewListLite.rbft2.Checked then // KoefAll := 1; // if (F_MasterNewListLite.rbin2.Checked) Or (F_MasterNewListLite.rbft2.Checked) then // begin // if F_MasterNewListLite.edSizeAllWhitworth.Text <> '' then // begin // PageKoef := GCadForm.PCad.WorkWidth / 304.8 {/ 1000}; // ScaleAll := StrToFloat_My(F_MasterNewListLite.edSizeAllWhitworth.Text) / PageKoef / KoefAll; // valDouble := ScaleAll; // if aCADParams.CADMapScale <> valDouble then // begin // GCadForm.PCad.MapScale := valDouble; // ReScaleAllDimLines; // end; // end; // end; // // end; //21.09.2010 valDouble := F_MasterNewListLite.CheckMapScaleResult; if (aCADParams.CADMapScale <> valDouble) or (GCadForm.PCad.MapScale <> valDouble) then begin GCadForm.PCad.MapScale := valDouble; ReScaleAllDimLines; end; // *** PrjCaption := GetCurrProjectParams.Caption; ListCaption := GetListParams(GCadForm.FCADListID).Caption; // ИМЯ ЛИСТА if F_MasterNewList.edListName.Text <> '' then begin GCadForm.FCADListName := F_MasterNewList.edListName.Text; GCadForm.FCADProjectName := GetCurrProjectName; GCadForm.Caption := PrjCaption + ' - ' + ListCaption; end; SetNewListNameInPM(GCadForm.FCADListID, GCadForm.FCADListName); FSCS_Main.pageCADList.ActivePage.Caption := ListCaption; for i := 0 to FSCS_Main.mainWindow.Count - 1 do begin if FSCS_Main.mainWindow.Items[i].Checked then break; end; FSCS_Main.mainWindow.Items[i].Caption := ListCaption; if (F_MasterNewListLite.edSubPath.Text <> '') and (FileExists(F_MasterNewListLite.edSubPath.Text)) then begin FName := F_MasterNewListLite.edSubPath.Text; LoadSubWithMaster(FName); end; // обновить скроллы GCadForm.ChangeScrollsOnChangeListSize; // обновить навигатор ReAssignNavigatorParams; if (GCadForm <> nil) and (GCadForm.PCad <> nil) then RefreshCAD(GCadForm.PCad); except ShowMessage(cCommon_Mes11); F_MasterNewList.ModalResult := mrNone; end; end; procedure ApplyCaptionNotesParams(aCADParams: TCADParams); var i, j: Integer; CurrLine: TOrthoLine; CurrConn: TConnectorObject; valBool: Boolean; isApply: Boolean; begin try // Tolik -- 28/06/2016-- // for i := 0 to GCadForm.PCad.FigureCount - 1 do for i := 0 to GCadForm.FSCSFigures.Count - 1 do begin // Conns //Tolik - -28/06/2016 -- // if CheckFigureByClassName(TFigure(GCadForm.PCad.Figures[i]), cTConnectorObject) then if CheckFigureByClassName(TFigure(GCadForm.FSCSFigures[i]), cTConnectorObject) then begin // Tolik -- 28/06/2016 -- // CurrConn := TConnectorObject(GCadForm.PCad.Figures[i]); CurrConn := TConnectorObject(GCadForm.FSCSFigures[i]); // Selected if not F_MasterNewList.cbApplyForSelectedOnly.Checked then isApply := True else begin if CurrConn.Selected then isApply := True else isApply := False; end; // if isApply then begin if CurrConn.ConnectorType <> ct_Clear then begin // ПРИМЕНИТЬ if TCheckBoxState(F_MasterNewList.cbShowConnectorsCaptions.State) <> cbGrayed then begin valBool := F_MasterNewList.cbShowConnectorsCaptions.Checked; CurrConn.ShowCaptions := F_MasterNewList.cbShowConnectorsCaptions.Checked; //26.05.2011 if aCADParams.CADShowConnObjectCaption <> valBool then begin //26.05.2011 if F_MasterNewList.cbShowConnectorsCaptions.Checked then //26.05.2011 CurrConn.ShowCaptions := True //26.05.2011 else //26.05.2011 CurrConn.ShowCaptions := False; CurrConn.ReCreateCaptionsGroup(false, true); end; end; if TCheckBoxState(F_MasterNewList.cbShowConnectorsNotes.State) <> cbGrayed then begin valBool := F_MasterNewList.cbShowConnectorsNotes.Checked; CurrConn.ShowNotes := F_MasterNewList.cbShowConnectorsNotes.Checked; //26.05.2011 if aCADParams.CADShowConnObjectNote <> valBool then begin //26.05.2011 if F_MasterNewList.cbShowConnectorsNotes.Checked then //26.05.2011 CurrConn.ShowNotes := True //26.05.2011 else //26.05.2011 CurrConn.ShowNotes := False; CurrConn.ReCreateNotesGroup; end; end; end; end; end; // Lines // Tolik -- 28/06/2016 -- // if CheckFigureByClassName(TFigure(GCadForm.PCad.Figures[i]), cTOrthoLine) then if CheckFigureByClassName(TFigure(GCadForm.FSCSFigures[i]), cTOrthoLine) then begin // Tolik -- 28/06/2016 -- // CurrLine := TOrthoLine(GCadForm.PCad.Figures[i]); CurrLine := TOrthoLine(GCadForm.FSCSFigures[i]); // Selected if not F_MasterNewList.cbApplyForSelectedOnly.Checked then isApply := True else begin if CurrLine.Selected then isApply := True else isApply := False; end; // if isApply then begin if not CurrLine.FIsRaiseUpDown then begin // ПРИМЕНИТЬ if TCheckBoxState(F_MasterNewList.cbShowLinesCaptions.State) <> cbGrayed then begin valBool := F_MasterNewList.cbShowLinesCaptions.Checked; CurrLine.ShowCaptions := F_MasterNewList.cbShowLinesCaptions.Checked; //26.05.2011 if aCADParams.CADShowLineObjectCaption <> valBool then begin //26.05.2011if F_MasterNewList.cbShowLinesCaptions.Checked then //26.05.2011 CurrLine.ShowCaptions := True //26.05.2011else //26.05.2011 CurrLine.ShowCaptions := False; CurrLine.ReCreateCaptionsGroup(false, true); end; end; if F_MasterNewList.cbShowLinesLength.Enabled and (TCheckBoxState(F_MasterNewList.cbShowLinesLength.State) <> cbGrayed) then begin valBool := F_MasterNewList.cbShowLinesLength.Checked; CurrLine.ShowLength := F_MasterNewList.cbShowLinesLength.Checked; //26.05.2011 if aCADParams.CADShowLineObjectLength <> valBool then begin //26.05.2011 if F_MasterNewList.cbShowLinesLength.Checked then //26.05.2011 CurrLine.ShowLength := True //26.05.2011 else //26.05.2011 CurrLine.ShowLength := False; CurrLine.UpdateLengthTextBox(false, true); end; end; if TCheckBoxState(F_MasterNewList.cbShowLinesNotes.State) <> cbGrayed then begin valBool := F_MasterNewList.cbShowLinesNotes.Checked; CurrLine.ShowNotes := F_MasterNewList.cbShowLinesNotes.Checked; //26.05.2011 if aCADParams.CADShowLineObjectNote <> valBool then begin //26.05.2011 if F_MasterNewList.cbShowLinesNotes.Checked then //26.05.2011 CurrLine.ShowNotes := True //26.05.2011 else //26.05.2011 CurrLine.ShowNotes := False; CurrLine.ReCreateNotesGroup; end; end; end; end; end; end; except on E: Exception do addExceptionToLogEx('U_Common.ApplyCaptionNotesParams', E.Message); end; end; procedure SetTraceLimitStatus(AID_List, AID_Object: Integer; AStatus: Boolean); var FFigure: TFigure; CurrCadForm: TF_CAD; begin try CurrCadForm := GetListByID(AID_List); if CurrCadForm <> nil then begin FFigure := GetFigureByID(CurrCadForm, AID_Object); if FFigure <> nil then if CheckFigureByClassName(FFigure, cTOrthoLine) then TOrthoLine(FFigure).IsLengthAboveLimit := AStatus; end; except on E: Exception do addExceptionToLogEx('U_Common.SetTraceLimitStatus', E.Message); end; end; procedure CreateDesignList(ABox: TConnectorObject); var ListParams: TListParams; CadFormFromBox: TF_CAD; begin try CadFormFromBox := GCadForm; ListParams := GetListParamsForNewList; ListParams.Caption := GetListDesignedName(ABox.ID); ListParams.Name := ListParams.Caption; ListParams.MarkID := 0; ListParams.Settings.ListType := lt_DesignBox; ListParams.Settings.IDFigureForDesignList := ABox.ID; ListParams.Settings.IDListForDesignList := GCadForm.FCADListID; MakeEditList(meMake, ListParams, False); ABox.FJoinedListIDForBox := GCadForm.FCADListID; GCadForm.FDesignListShowName := F_ChooseDesignBoxParams.cbShowDesignBoxName.Checked; GCadForm.FDesignListShowSign := F_ChooseDesignBoxParams.cbShowDesignBoxSign.Checked; GCadForm.FDesignListShowMark := F_ChooseDesignBoxParams.cbShowDesignBoxMark.Checked; UpdateDesignList(GCadForm, ABox); except on E: Exception do addExceptionToLogEx('U_Common.CreateDesignList', E.Message); end; end; procedure OpenDesignList(ABox: TConnectorObject; AList: TF_CAD); var i: integer; begin try AList.BringToFront; if AList.WindowState <> wsMaximized then AList.WindowState := wsMaximized; UpdateDesignList(AList, ABox); except on E: Exception do addExceptionToLogEx('U_Common.OpenDesignList', E.Message); end; end; procedure CreateOpenDesignListFromPM(AID_List, AID_Box: Integer); var FFigure: TFigure; FList: TF_CAD; begin try FList := GetListByID(AID_List); if FList <> nil then begin FFigure := GetFigureByID(FList, AID_Box); if FFigure <> nil then begin GPopupFigure := FFigure; FSCS_Main.aDesignBox.Execute; end; end; except on E: Exception do addExceptionToLogEx('CreateOpenDesignListFromPM', E.Message); end; end; procedure UpdateDesignList(AList: TF_CAD; ABox: TConnectorObject); var i, j: integer; FileName: string; TopIndent, LeftIndent: Double; DesignParams: TComponentDesignParams; aDescription, aName, aSign, aMark, ServiceStr, str: string; aWidth: Double; aHeightM: Double; aHeightU: Double; OldBoxHeight, OldBoxWidth: Double; NewBoxHeight, NewBoxWidth: Double; BoxHeightKoef, BoxWidthKoef: Double; SlotsWidth: Double; RulerHeight: Double; CadRulerWidth: Double; CadRulerHeight: Double; BegDrawPoint: TDoublePoint; ComponHeight, ComponWidth: Double; OldComponHeight, OldComponWidth: Double; ToBoxPoints: TDoublePoint; ListFormatKoef: Double; aTopBound, aBottomBound, aLeftBound, aRightBound: Double; DescrObject: TRichText; DescrInsObject: TRichText; DescrPoints: TDoublePoint; DescrLHandle: Integer; BlockFig: TBlock; ComponsList: TObjectList; aGraphicalImage: TMemoryStream; TM: TTextMetric; xCanvas: TMetafileCanvas; h, w: double; FigureGrp: TFigureGrp; ListX: double; PanelsHeightBefore: Double; //27.04.2011 Koef1, Koef2, PanelsHeight: Double; //27.04.2011 NeedApplayKoef: boolean; UCount: integer; StampObject: TFigureGrp; UpperStampObj: TRectangle; LHandle: integer; TextField: TRichText; begin try //Koef1_m := 1.227; //Koef2_m := 0.186; {0.1135} Koef1 := 1.01; //1 //0.99; Koef2 := 0.99; //1; NewBoxWidth := 0; //#From Oleg# //14.09.2010 ListFormatKoef := 1; //#From Oleg# //14.09.2010 SlotsWidth := 0; //#From Oleg# //14.09.2010 Alist.PCad.RecordUndo := False; Alist.PCad.UndoCount := 0; {$if Defined(ES_GRAPH_SC)} FileName := ExeDir + '\.blk\TempStream.pwb'; {$else} FileName := ExtractFileDir(Application.ExeName) + '\.blk\TempStream.pwb'; {$ifend} TopIndent := 2.5 + 10 + 15; LeftIndent := 20 + 2; ToBoxPoints.x := 0; ToBoxPoints.y := 0; AList.PCad.Clear(1); ComponsList := GetFigureComponGraphicalImage(ABox.ID); PanelsHeightBefore := 0; PanelsHeight := 0; if Assigned(ComponsList) then begin for i := 0 to ComponsList.Count - 1 do begin try DesignParams := TComponentDesignParams(ComponsList[i]); aGraphicalImage := TMemoryStream(DesignParams.GraphicalImage); aDescription := trim(DesignParams.Description); aName := trim(DesignParams.Name); aSign := trim(DesignParams.NameShort); aMark := trim(DesignParams.NameMark); ServiceStr := '; '; aWidth := DesignParams.Width * 100; aHeightM := DesignParams.Height * 100; aHeightU := DesignParams.HeightInUnits; // по свойствам Дизайна Шкафа сформировать подписи aDescription := ''; if GCadForm.FDesignListShowName then aDescription := aDescription + aName; if GCadForm.FDesignListShowSign then aDescription := aDescription + ServiceStr + aSign; if GCadForm.FDesignListShowMark then aDescription := aDescription + ServiceStr + aMark; BlockFig := nil; if aGraphicalImage <> nil then begin aGraphicalImage.SaveToFile(FileName); BlockFig := TBlock(AList.PCad.InsertBlockwithFileName(1, FileName, LeftIndent, TopIndent)); end else begin if (i <> 0) then begin //StampObject := TFigureGrp.create(1, AList.PCad); LHandle := AList.PCad.GetLayerHandle(1); UpperStampObj := TRectangle.create(0, 0, 70, 20, 2, ord(psSolid), clBlack, ord(bsClear), clRed, LHandle, mydsNormal, AList.PCad); TextField := TRichText.create(15, 8, 60, 15, 1, ord(psSolid), clRed, ord(bsClear), clNone, LHandle, mydsNormal, AList.PCad); TextField.re.WordWrap := True; TextField.re.Font.Name := AList.FFontName; TextField.re.Font.Size := 14; TextField.re.Font.Style := [fsBold]; TextField.re.Font.Color := clRed; TextField.re.Lines.Clear; TextField.re.Lines.Add('NO IMAGE'); BlockFig := TBlock.Create(LHandle, AList.PCad); BlockFig.AddFigure(UpperStampObj); BlockFig.AddFigure(TextField); AList.PCad.AddCustomFigure(1, BlockFig, False); end; end; except on E: Exception do Showmessage(inttostr(i)); end; // Сам ШКАФ if (i = 0) and (aGraphicalImage <> nil) then begin aTopBound := DesignParams.TopBound * 100; aBottomBound := DesignParams.BottomBound * 100; aLeftBound := DesignParams.LeftBound * 100; aRightBound := DesignParams.RightBound * 100; ListFormatKoef := CalcListFormatKoef(aWidth, aHeightM, AList); OldBoxWidth := BlockFig.GetBoundRect.Right - BlockFig.GetBoundRect.Left; OldBoxHeight := BlockFig.GetBoundRect.Bottom - BlockFig.GetBoundRect.Top; ReScaleImage(BlockFig, OldBoxWidth, OldBoxHeight, aWidth * ListFormatKoef, aHeightM * ListFormatKoef); NewBoxWidth := BlockFig.GetBoundRect.Right - BlockFig.GetBoundRect.Left; NewBoxHeight := BlockFig.GetBoundRect.Bottom - BlockFig.GetBoundRect.Top; BlockFig.move(BlockFig.CenterPoint.x + NewBoxWidth / 2, BlockFig.CenterPoint.y + NewBoxHeight / 2); BoxHeightKoef := NewBoxHeight / OldBoxHeight; BoxWidthKoef := NewBoxWidth / OldBoxWidth; aTopBound := aTopBound * BoxHeightKoef; aBottomBound := aBottomBound * BoxHeightKoef; aLeftBound := aLeftBound * BoxWidthKoef; aRightBound := aRightBound * BoxWidthKoef; SlotsWidth := NewBoxWidth - aLeftBound - aRightBound; // ToBoxPoints.x := BlockFig.CenterPoint.x //ToBoxPoints.x := BlockFig.CenterPoint.x + (aLeftBound - aRightBound)/2 * ListFormatKoef; ToBoxPoints.x := BlockFig.CenterPoint.x + (aLeftBound - aRightBound)/2; ToBoxPoints.y := BlockFig.CenterPoint.y - NewBoxHeight / 2 + aTopBound; // нарисовать линейку RulerHeight := aHeightM; RulerHeight := aHeightU; CadRulerWidth := aRightBound; CadRulerHeight := NewBoxHeight - aTopBound - aBottomBound; BegDrawPoint.x := LeftIndent * 2 + NewBoxWidth - aRightBound; BegDrawPoint.y := TopIndent * 2 + NewBoxHeight - aBottomBound; // DrawDesignRulerInMetres(AList, RulerHeight, CadRulerWidth, CadRulerHeight, BegDrawPoint); DrawDesignRulerInUnits(AList, RulerHeight, CadRulerWidth, CadRulerHeight, BegDrawPoint); end else // Его комплектующие begin ComponWidth := BlockFig.GetBoundRect.Right - BlockFig.GetBoundRect.Left; ComponHeight := BlockFig.GetBoundRect.Bottom - BlockFig.GetBoundRect.Top; PanelsHeightBefore := PanelsHeightBefore + ComponHeight; NeedApplayKoef := False; for j := 0 to BlockFig.InFigures.Count - 1 do begin if (TFigure(BlockFig.inFigures[j]) is TWMFObject) or (TFigure(BlockFig.inFigures[j]) is TBMPObject) then begin NeedApplayKoef := True; break; end; end; if NeedApplayKoef then begin //ReScaleImage(BlockFig, ComponWidth, ComponHeight, SlotsWidth{aWidth * ListFormatKoef}, koef1_m * aHeightM * ListFormatKoef); //ReScaleImage(BlockFig, ComponWidth, ComponHeight, SlotsWidth, aHeightM * ListFormatKoef + koef1 * ListFormatKoef); UCount := Trunc(aHeightM / 4.374); ReScaleImage(BlockFig, ComponWidth, ComponHeight, SlotsWidth, aHeightM * ListFormatKoef + (koef1 - (0.006 * UCount)) * ListFormatKoef); ComponHeight := BlockFig.GetBoundRect.Bottom - BlockFig.GetBoundRect.Top; ComponWidth := BlockFig.GetBoundRect.Right - BlockFig.GetBoundRect.Left; //ComponHeight := ComponHeight - ComponHeight * koef2_m; //ComponHeight := ComponHeight - (koef2 * ListFormatKoef); ComponHeight := ComponHeight - ( (koef2 - (0.006 * UCount)) * ListFormatKoef); end else begin ReScaleImage(BlockFig, ComponWidth, ComponHeight, SlotsWidth {aWidth * ListFormatKoef}, aHeightM * ListFormatKoef); ComponHeight := BlockFig.GetBoundRect.Bottom - BlockFig.GetBoundRect.Top; ComponWidth := BlockFig.GetBoundRect.Right - BlockFig.GetBoundRect.Left; end; ToBoxPoints.y := ToBoxPoints.y + ComponHeight / 2; PanelsHeight := PanelsHeight + ComponHeight; //27.04.2011 BlockFig.move(ToBoxPoints.x - BlockFig.CenterPoint.x, ToBoxPoints.y - BlockFig.CenterPoint.y); // Вывести описание DescrPoints.x := LeftIndent * 2 + NewBoxWidth + 2; DescrPoints.y := ToBoxPoints.y - 3;{3 * ListFormatKoef}; DescrLHandle := AList.PCad.GetLayerHandle(1); // СОЗДАНИЕ ТЕКСТА ОПИСАНИЯ DescrObject := TRichText.create(-100, -100, -100, -100, 1, ord(psSolid), clBlack, ord(bsClear), clNone, DescrLHandle, mydsNormal, AList.PCad); DescrObject.re.WordWrap := False; DescrObject.re.Font.Name := AList.FFontName; DescrObject.re.Font.Size := 12; // 14 DescrObject.re.Font.Style := []; DescrObject.re.Lines.Clear; DescrObject.re.Lines.Add(aDescription); // Tolik DescrObject.ttMetaFile:= TMetaFile.Create; DescrObject.ttMetafile.Enhanced := True; xCanvas := TMetafileCanvas.Create(DescrObject.ttMetafile, 0); xCanvas.Font.Name := DescrObject.re.Font.Name; xCanvas.Font.Size := DescrObject.re.Font.Size; xCanvas.Font.Style := DescrObject.re.Font.Style; GetTextMetrics(xCanvas.Handle, TM); h := TM.tmHeight / 4; w := (xCanvas.TextWidth(DescrObject.Re.Lines[0]) + 3) / 4; FreeAndNil(xCanvas); DescrObject.ttMetaFile.Free; FreeAndNil(DescrObject); DescrObject := TRichText.create(DescrPoints.x, DescrPoints.y, DescrPoints.x + w, DescrPoints.y + h, 1, ord(psSolid), clBlack, ord(bsClear), clNone, DescrLHandle, mydsNormal, AList.PCad); DescrObject.re.WordWrap := False; DescrObject.re.Font.Name := AList.FFontName; DescrObject.re.Font.Size := 12; // 14 DescrObject.re.Font.Style := []; DescrObject.re.Lines.Clear; DescrObject.re.Lines.Add(aDescription); DescrInsObject := TRichText(AList.PCad.AddCustomFigure(1, DescrObject, False)); // === {$IF Defined(SCS_PE) or Defined(BASEADM_SCS) or Defined(SCS_PANDUIT)} AList.PCad.DeselectAll(1); BlockFig.Select; DescrInsObject.Select; AList.PCad.GroupSelection; {$IFEND} ToBoxPoints.y := ToBoxPoints.y + ComponHeight / 2; end; if BlockFig <> nil then BlockFig.Deselect; if (i = 0) and (aGraphicalImage = nil) then begin ShowMessage(cCommon_Mes12); if ComponsList <> nil then FreeAndNil(ComponsList); Alist.PCad.RecordUndo := True; Alist.PCad.UndoCount := 0; Exit; end; //else // ToBoxPoints.y := ToBoxPoints.y + aHeightM * ListFormatKoef; //01.10.2012 end; AList.PCad.SelectAll(1); AList.PCad.GroupSelection; FigureGrp := TFigureGrp(AList.PCad.Selection[0]); NewBoxWidth := FigureGrp.GetBoundRect.Right - FigureGrp.GetBoundRect.Left; ListX := AList.PCad.WorkWidth - (15 + 10 + 2 * 5) / 2; // сместить полностью if NewBoxWidth > ListX then begin FigureGrp.Scale(ListX / NewBoxWidth, ListX / NewBoxWidth); FigureGrp.move(LeftIndent - FigureGrp.ap1.x, TopIndent - FigureGrp.ap1.y); end else // сместить только вверх begin FigureGrp.move(LeftIndent - FigureGrp.ap1.x, TopIndent - FigureGrp.ap1.y); end; end; if ComponsList <> nil then FreeAndNil(ComponsList); // AList.CurrentLayer := 1; {$IF Defined(SCS_PE) or Defined(BASEADM_SCS) or Defined(SCS_PANDUIT)} //if FigureGrp <> nil then // FigureGrp.UnGroup; AList.PCad.UngroupSelection; AList.PCad.DeselectAll(1); {$IFEND} RefreshCAD(AList.PCad); Alist.PCad.RecordUndo := True; Alist.PCad.UndoCount := 0; str := GetListParams(AList.FCADListID).Caption; LoadCaptionsOnFrame(AList, GetListParams(AList.FCADListID).Settings.CADStampType); except on E: Exception do addExceptionToLogEx('U_Common.UpdateDesignList', E.Message); end; end; procedure UpdateDesignListOnBoxChange(AListID: Integer; ABoxID: Integer); var Box: TConnectorObject; BoxList: TF_CAD; DesingList: TF_CAD; begin try BoxList := GetListByID(AListID); if BoxList <> nil then begin Box := TConnectorObject(GetFigureByID(BoxList, ABoxID)); if Box <> nil then begin if Box.FJoinedListIDForBox <> - 1 then begin DesingList := GetListByID(Box.FJoinedListIDForBox); if DesingList <> nil then UpdateDesignList(DesingList, Box); end; end; end; except on E: Exception do addExceptionToLogEx('U_Common.UpdateDesignListOnBoxChange', E.Message); end; end; procedure ReScaleImage(aBlock: TBlock; aCurrX, aCurrY, aTotalX, aTotalY: Double); var i: integer; KoefX, KoefY: double; FFigure: TFigure; isScaled: Boolean; begin try KoefX := aTotalX / aCurrX; KoefY := aTotalY / aCurrY; isScaled := True; for i := 0 to aBlock.InFigures.Count - 1 do begin FFigure := TFigure(aBlock.InFigures[i]); if CheckFigureByClassName(FFigure, 'TWMFObject') then begin FFigure.Scale(KoefX, KoefY, FFigure.CenterPoint); isScaled := False; end; end; if isScaled then ABlock.scale(KoefX, KoefY, aBlock.CenterPoint); except on E: Exception do addExceptionToLogEx('U_Common.ReScaleImage', E.Message); end; end; function CalcListFormatKoef(aBoxWidth, aBoxHeight: Double; AList: TF_CAD): Double; var ListWidth: Double; ListHeight: Double; LimitWidth: Double; LimitHeight: Double; KoefWidth: Double; KoefHeight: Double; ListBottomParam: Double; begin Result := 0; try ListWidth := AList.PCad.WorkWidth; ListHeight := AList.PCad.WorkHeight; ListBottomParam := 0; //#From Oleg# //14.09.2010 if AList.FCadStampType = stt_simple then ListBottomParam := 15 else if AList.FCadStampType = stt_extended then ListBottomParam := 40 else if AList.FCadStampType = stt_detailed then ListBottomParam := 55; LimitWidth := ListWidth - (15 + 10 + 2 * 5) / 2; LimitHeight := ListHeight - (5 + 10 + ListBottomParam + 2 * 5 + 20); KoefWidth := LimitWidth / aBoxWidth; KoefHeight := LimitHeight / aBoxHeight; if KoefWidth < KoefHeight then Result := KoefWidth else Result := KoefHeight; except on E: Exception do addExceptionToLogEx('U_Common.CalcListFormatKoef', E.Message); end; end; procedure DrawDesignRulerInMetres(aList: TF_CAD; aRulerHeight, aCadRulerWidth, aCadRulerHeight: Double; aBeginDrawPoint: TDoublePoint); var i: integer; Step: Double; MarkCount: Integer; LimitStep: Double; x1, y1, x2, y2: double; textx, texty: double; LHandle: Integer; LineObject: TLine; TextObject: TText; aTextHeight: Double; aTextWidth: Double; TextGroupObject: TFigureGrp; TextGroupList: TList; begin // Tolik 09/02/2017 -- TextGroupList := nil; // try LHandle := 0; //#From Oleg# //14.09.2010 LimitStep := 2; Step := aCadRulerHeight / aRulerHeight; MarkCount := Round(aRulerHeight); TextGroupList := TList.Create; for i := 0 to MarkCount - 1 do begin x1 := aBeginDrawPoint.x; y1 := aBeginDrawPoint.y - i * Step; y2 := aBeginDrawPoint.y - i * Step; if (i mod 10) = 0 then begin x2 := aBeginDrawPoint.x + 0.7 * aCadRulerWidth; aTextHeight := 3; aTextWidth := 1.5; end else if (i mod 5) = 0 then begin x2 := aBeginDrawPoint.x + 0.5 * aCadRulerWidth; aTextHeight := 2; aTextWidth := 1; end else begin x2 := aBeginDrawPoint.x + 0.3 * aCadRulerWidth; aTextHeight := 1.5; aTextWidth := 0.75; end; if Step < LimitStep then begin if (i mod 5) = 0 then begin LHandle := aList.PCad.GetLayerHandle(1); LineObject := TLine.create(x1, y1, x2, y2, 1, ord(psSolid), clBlack, 0, LHandle, mydsNormal, aList.PCad); LineObject.LockModify := True; LineObject.LockMove := True; TextObject := TText.Create(x2, y2, aTextHeight, aTextWidth, IntToStr(i), GCadForm.FFontName, RUSSIAN_CHARSET, clBlack, LHandle, mydsNormal, aList.PCad); TextObject.Move(- TextObject.TextLength, - TextObject.TextHeight); TextObject.LockModify := True; TextObject.LockMove := True; TextGroupList.Add(LineObject); TextGroupList.Add(TextObject); end end else begin LHandle := aList.PCad.GetLayerHandle(1); LineObject := TLine.create(x1, y1, x2, y2, 1, ord(psSolid), clBlack, 0, LHandle, mydsNormal, aList.PCad); LineObject.LockModify := True; LineObject.LockMove := True; TextGroupList.Add(LineObject); if (i mod 5) = 0 then begin TextObject := TText.Create(x2, y2, aTextHeight, aTextWidth, IntToStr(i), GCadForm.FFontName, RUSSIAN_CHARSET, clBlack, LHandle, mydsNormal, aList.PCad); TextObject.Move(- TextObject.TextLength, - TextObject.TextHeight); TextObject.LockModify := True; TextObject.LockMove := True; TextGroupList.Add(TextObject); end; end; end; TextGroupObject := TFigureGrp.create(LHandle, aList.PCad); for i := 0 to TextGroupList.Count - 1 do TextGroupObject.AddFigure(TFigure(TextGroupList[i])); aList.PCad.AddCustomFigure(1, TextGroupObject, False); if TextGroupList <> nil then FreeAndNil(TextGroupList); except on E: Exception do addExceptionToLogEx('U_Common.DrawDesignRulerInMetres', E.Message); end; end; procedure DrawDesignRulerInUnits(aList: TF_CAD; aRulerHeight, aCadRulerWidth, aCadRulerHeight: Double; aBeginDrawPoint: TDoublePoint); var i: integer; Step: Double; MarkCount: Integer; LimitStep: Double; x1, y1, x2, y2: double; textx, texty: double; LHandle: Integer; LineObject: TLine; TextObject: TRichText; aTextHeight: Double; aTextWidth: Double; TextGroupObject: TFigureGrp; TextGroupList: TList; TM: TTextMetric; xCanvas: TMetafileCanvas; h, w: double; begin // Tolik 09/02/2017 TextGroupList := nil; // try LimitStep := 2; Step := aCadRulerHeight / aRulerHeight; MarkCount := Round(aRulerHeight); TextGroupList := TList.Create; for i := 0 to MarkCount - 1 do begin x1 := aBeginDrawPoint.x; y1 := aBeginDrawPoint.y - i * Step; y2 := aBeginDrawPoint.y - i * Step; if (i mod 5) = 0 then begin x2 := aBeginDrawPoint.x + 0.7 * aCadRulerWidth; aTextHeight := 3; aTextWidth := 1.5; end else begin x2 := aBeginDrawPoint.x + 0.5 * aCadRulerWidth; aTextHeight := 2; aTextWidth := 1; end; if Step < LimitStep then begin if (i mod 5) = 0 then begin LHandle := aList.PCad.GetLayerHandle(1); LineObject := TLine.create(x1, y1, x2, y2, 1, ord(psSolid), clBlack, 0, LHandle, mydsNormal, aList.PCad); LineObject.LockModify := True; LineObject.LockMove := True; TextObject := TRichText.create(-100, -100, -100, -100, 1, ord(psSolid), clBlack, ord(bsClear), clNone, LHandle, mydsNormal, GCadForm.PCad); TextObject.re.Font.Name := GCadForm.FFontName; TextObject.re.Font.Size := 12; TextObject.re.Font.Style := []; TextObject.re.Lines.Clear; TextObject.re.Lines.Add(IntToStr(i)); // Tolik TextObject.ttMetaFile:= TMetaFile.Create; TextObject.ttMetafile.Enhanced := True; xCanvas := TMetafileCanvas.Create(TextObject.ttMetafile, 0); xCanvas.Font.Name := TextObject.re.Font.Name; xCanvas.Font.Size := TextObject.re.Font.Size; xCanvas.Font.Style := TextObject.re.Font.Style; GetTextMetrics(xCanvas.Handle, TM); h := TM.tmHeight / 4; w := (xCanvas.TextWidth(TextObject.Re.Lines[0]) + 3) / 4; FreeAndNil(xCanvas); TextObject.ttMetaFile.Free; FreeAndNil(TextObject); TextObject := TRichText.create(x2, y2, x2 + w, y2 + h, 1, ord(psSolid), clBlack, ord(bsClear), clNone, LHandle, mydsNormal, GCadForm.PCad); TextObject.re.Font.Name := GCadForm.FFontName; TextObject.re.Font.Size := 12; TextObject.re.Font.Style := []; TextObject.re.Lines.Clear; TextObject.re.Lines.Add(IntToStr(i)); TextObject.Move(- w, - h); TextObject.LockModify := True; TextObject.LockMove := True; TextGroupList.Add(LineObject); TextGroupList.Add(TextObject); end end else begin LHandle := aList.PCad.GetLayerHandle(1); LineObject := TLine.create(x1, y1, x2, y2, 1, ord(psSolid), clBlack, 0, LHandle, mydsNormal, aList.PCad); LineObject.LockModify := True; LineObject.LockMove := True; TextGroupList.Add(LineObject); if (i mod 5) = 0 then begin TextObject := TRichText.create(-100, -100, -100, -100, 1, ord(psSolid), clBlack, ord(bsClear), clNone, LHandle, mydsNormal, GCadForm.PCad); TextObject.re.Font.Name := GCadForm.FFontName; TextObject.re.Font.Size := 12; TextObject.re.Font.Style := []; TextObject.re.Lines.Clear; TextObject.re.Lines.Add(IntToStr(i)); // Tolik -- 13/01/2017 TextObject.ttMetaFile:= TMetaFile.Create; TextObject.ttMetafile.Enhanced := True; xCanvas := TMetafileCanvas.Create(TextObject.ttMetaFile, 0); xCanvas.Font.Name := TextObject.re.Font.Name; xCanvas.Font.Size := TextObject.re.Font.Size; xCanvas.Font.Style := TextObject.re.Font.Style; GetTextMetrics(xCanvas.Handle, TM); h := TM.tmHeight / 4; w := (xCanvas.TextWidth(TextObject.Re.Lines[0]) + 3) / 4; FreeAndNil(xCanvas); TextObject.ttMetaFile.Free; FreeAndNil(TextObject); TextObject := TRichText.create(x2, y2, x2 + w, y2 + h, 1, ord(psSolid), clBlack, ord(bsClear), clNone, LHandle, mydsNormal, GCadForm.PCad); TextObject.re.Font.Name := GCadForm.FFontName; TextObject.re.Font.Size := 12; TextObject.re.Font.Style := []; TextObject.re.Lines.Clear; TextObject.re.Lines.Add(IntToStr(i)); TextObject.Move(- w, - h); TextObject.LockModify := True; TextObject.LockMove := True; TextGroupList.Add(TextObject); end; end; end; TextGroupObject := TFigureGrp.create(LHandle, aList.PCad); for i := 0 to TextGroupList.Count - 1 do TextGroupObject.AddFigure(TFigure(TextGroupList[i])); aList.PCad.AddCustomFigure(1, TextGroupObject, False); if TextGroupList <> nil then FreeAndNil(TextGroupList); except on E: Exception do addExceptionToLogEx('U_Common.DrawDesignRulerInUnits', E.Message); end; end; procedure DisableActForReadOnlyMode; var i: integer; begin if GReadOnlyMode then begin for i := 0 to FSCS_Main.ActionManager.ActionCount - 1 do begin if (FSCS_Main.ActionManager.Actions[i].Category = 'Tools') or (FSCS_Main.ActionManager.Actions[i].Category = 'Инструменты') then (FSCS_Main.ActionManager.Actions[i] as TAction).Enabled := False; end; FSCS_Main.aSaveRevision.Enabled := False; FSCS_Main.aViewRevs.Enabled := False; FSCS_Main.aCreateProjectPlan.Enabled := False; FSCS_Main.aCreateNormsOnCad.Enabled := False; FSCS_Main.aMasterAutoTrace.Enabled := False; FSCS_Main.aMasterAutoTraceElectric.Enabled := False; FSCS_Main.aMasterCableTracing.Enabled := False; FSCS_Main.aMasterCableChannel.Enabled := False; FSCS_Main.aMasterUpdateComponPriceFromXF.Enabled := False; FSCS_Main.aToolSelect.Enabled := True; FSCS_Main.aToolPan.Enabled := True; end; end; procedure EnableOptionsForNormalList; begin try FSCS_Main.aSaveAsSubstrate.Enabled := True; FSCS_Main.aImport.Enabled := True; FSCS_Main.aUndo.Enabled := True; FSCS_Main.aRedo.Enabled := True; FSCS_Main.aCopy.Enabled := True; FSCS_Main.aCut.Enabled := True; FSCS_Main.aPaste.Enabled := True; FSCS_Main.aSelectAll.Enabled := True; FSCS_Main.aViewLayers.Enabled := True; FSCS_Main.aRotate.Enabled := True; FSCS_Main.aBackwards.Enabled := True; FSCS_Main.aForward.Enabled := True; FSCS_Main.aGrouping.Enabled := True; FSCS_Main.aUngrouping.Enabled := True; FSCS_Main.aLock.Enabled := True; FSCS_Main.aUnlock.Enabled := True; FSCS_Main.aObjProperties.Enabled := True; FSCS_Main.aLoadSubstrate.Enabled := True; // FSCS_Main.aViewProjectManager.Enabled := True; FSCS_Main.aDelete.Enabled := True; FSCS_Main.aDeleteAll.Enabled := True; FSCS_Main.aDeSelectAll.Enabled := True; FSCS_Main.aInsertText.Enabled := True; FSCS_Main.aInsertBitmap.Enabled := True; FSCS_Main.aPenStyle.Enabled := True; FSCS_Main.aPenWidth.Enabled := True; FSCS_Main.aRowStyle.Enabled := True; FSCS_Main.aBrushStyle.Enabled := True; FSCS_Main.aTextCharset.Enabled := True; FSCS_Main.aFontStyle.Enabled := True; FSCS_Main.aFormatOrder.Enabled := True; FSCS_Main.aFormatAlign.Enabled := True; FSCS_Main.aSnaptoGrid.Enabled := True; FSCS_Main.aSnaptoGuides.Enabled := True; FSCS_Main.aSnaptoNearObject.Enabled := True; FSCS_Main.aSendtoBack.Enabled := True; FSCS_Main.aBringtoFront.Enabled := True; FSCS_Main.aSendBackwards.Enabled := True; FSCS_Main.aBringForwards.Enabled := True; FSCS_Main.aMoveSelection.Enabled := True; FSCS_Main.aRotateSelection.Enabled := True; FSCS_Main.aDuplicateSelection.Enabled := True; FSCS_Main.aMirrorSelection.Enabled := True; FSCS_Main.aToolLine.Enabled := True; FSCS_Main.aToolRectangle.Enabled := True; FSCS_Main.aToolEllipse.Enabled := True; FSCS_Main.aToolCircle.Enabled := True; FSCS_Main.aToolArc.Enabled := True; FSCS_Main.aToolElipticArc.Enabled := True; FSCS_Main.aToolPolyLine.Enabled := True; FSCS_Main.aToolPoint.Enabled := True; FSCS_Main.aToolText.Enabled := True; FSCS_Main.aToolRichText.Enabled := True; FSCS_Main.aToolKnife.Enabled := True; FSCS_Main.aToolHDimLine.Enabled := True; FSCS_Main.aToolVDimLine.Enabled := True; FSCS_Main.aTextFont.Enabled := True; FSCS_Main.aTextSize.Enabled := True; FSCS_Main.aToolMultiLine.Enabled := True; {$if Not Defined(ES_GRAPH_SC)} FSCS_Main.aToolOrthoLine.Enabled := True; FSCS_Main.aToolOrthoLineExt.Enabled := True; {$ifend} FSCS_Main.aSetSubstrateLayer.Enabled := True; FSCS_Main.aSetSCSLayer.Enabled := True; FSCS_Main.aAutoSelectTrace.Enabled := True; FSCS_Main.aOpenProject.Enabled := True; FSCS_Main.aToolText.Enabled := True; FSCS_Main.aViewSCSObjectsProp.Enabled := True; FSCS_Main.aCreateRaise.Enabled := True; FSCS_Main.aDestroyRaise.Enabled := True; FSCS_Main.aMasterAutoTrace.Enabled := True; FSCS_Main.aRaiseLine.Enabled := True; FSCS_Main.aCreateObjectOnClick.Enabled := True; FSCS_Main.aShowConnFullness.Enabled := True; FSCS_Main.aShowCableFullness.Enabled := True; FSCS_Main.aShowCableChannelFullness.Enabled := True; FSCS_Main.aCreateObjectOnClickTool.Enabled := True; FSCS_Main.aCreateBlockToFile.Enabled := True; FSCS_Main.aCreateBlockToNB.Enabled := True; FSCS_Main.aInsertBlock.Enabled := True; {$if Not Defined(ES_GRAPH_SC)} //30.05.2011 FSCS_Main.aShiftUpObject.Enabled := True; //30.05.2011 FSCS_Main.aShiftDownObject.Enabled := True; //30.05.2011 FSCS_Main.aShiftLeftObject.Enabled := True; //30.05.2011 FSCS_Main.aShiftRightObject.Enabled := True; {$ifend} FSCS_Main.aDesignBox.Enabled := True; FSCS_Main.aShowTracesLengthLimit.Enabled := True; FSCS_Main.aNoMoveConnectedObjects.Enabled := True; // Add FSCS_Main.aLoadFPlan.Enabled := True; FSCS_Main.aSaveFPlan.Enabled := True; {$if Not Defined(ES_GRAPH_SC)} FSCS_Main.aConnectionsConfigurator.Enabled := True; FSCS_Main.aMasterCableTracing.Enabled := True; FSCS_Main.aMasterCableChannel.Enabled := True; FSCS_Main.aToolCabinet.Enabled := True; FSCS_Main.aToolCabinetExt.Enabled := True; //Tolik 12/02/2021 FSCS_Main.aToolWallRect.Enabled := True; FSCS_Main.aToolWallPath.Enabled := True; {$ifend} FSCS_Main.cbLayers.Enabled := True; FSCS_Main.aExport.Enabled := True; FSCS_Main.aExportDWG.Enabled := True; // Tolik 12/02/2021 -- FSCS_Main.aToolSCSVDimLine.Enabled := True; FSCS_Main.aToolSCSHDimLine.Enabled := True; FSCS_Main.tb3D.Enabled := True; FSCS_Main.aShowDefectObjects.Enabled := True; FSCS_Main.aShowDisconnectedObjects.Enabled := True; FSCS_Main.aToolSCSArcDimLine.Enabled := True; FSCS_Main.aToolPie.Enabled := True; GCadform.tbShowPathLengthType.Enabled := True; GCadForm.tbShowPathTraceLengthType.Enabled := True; // {$if Not Defined(ES_GRAPH_SC)} FSCS_Main.aToolHouse.Enabled := True; {$ifend} except on E: Exception do addExceptionToLogEx('U_Common.EnableOptionsForNormalList', E.Message); end; DisableActForReadOnlyMode; end; procedure DisableOptionsForDesignList; begin try FSCS_Main.aSaveAsSubstrate.Enabled := False; FSCS_Main.aImport.Enabled := False; FSCS_Main.aUndo.Enabled := True; FSCS_Main.aRedo.Enabled := True; FSCS_Main.aCopy.Enabled := False; FSCS_Main.aCut.Enabled := False; FSCS_Main.aPaste.Enabled := False; FSCS_Main.aSelectAll.Enabled := False; FSCS_Main.aViewLayers.Enabled := False; FSCS_Main.aRotate.Enabled := False; FSCS_Main.aBackwards.Enabled := True; FSCS_Main.aForward.Enabled := True; FSCS_Main.aGrouping.Enabled := True; FSCS_Main.aUngrouping.Enabled := True; FSCS_Main.aLock.Enabled := False; FSCS_Main.aUnlock.Enabled := False; FSCS_Main.aObjProperties.Enabled := False; FSCS_Main.aLoadSubstrate.Enabled := False; // FSCS_Main.aViewProjectManager.Enabled := False; FSCS_Main.aDelete.Enabled := False; FSCS_Main.aDeleteAll.Enabled := False; FSCS_Main.aDeSelectAll.Enabled := False; FSCS_Main.aInsertText.Enabled := True; FSCS_Main.aInsertBitmap.Enabled := True; FSCS_Main.aPenStyle.Enabled := False; FSCS_Main.aPenWidth.Enabled := False; FSCS_Main.aRowStyle.Enabled := False; FSCS_Main.aBrushStyle.Enabled := False; FSCS_Main.aTextCharset.Enabled := False; FSCS_Main.aFontStyle.Enabled := False; FSCS_Main.aFormatOrder.Enabled := False; FSCS_Main.aFormatAlign.Enabled := False; FSCS_Main.aSnaptoGrid.Enabled := False; FSCS_Main.aSnaptoGuides.Enabled := False; FSCS_Main.aSnaptoNearObject.Enabled := False; FSCS_Main.aSendtoBack.Enabled := True; FSCS_Main.aBringtoFront.Enabled := True; FSCS_Main.aSendBackwards.Enabled := True; FSCS_Main.aBringForwards.Enabled := True; FSCS_Main.aMoveSelection.Enabled := False; FSCS_Main.aRotateSelection.Enabled := False; FSCS_Main.aDuplicateSelection.Enabled := False; FSCS_Main.aMirrorSelection.Enabled := False; FSCS_Main.aToolLine.Enabled := False; FSCS_Main.aToolRectangle.Enabled := False; FSCS_Main.aToolEllipse.Enabled := False; FSCS_Main.aToolCircle.Enabled := False; FSCS_Main.aToolArc.Enabled := False; FSCS_Main.aToolElipticArc.Enabled := False; FSCS_Main.aToolPolyLine.Enabled := False; FSCS_Main.aToolPoint.Enabled := False; FSCS_Main.aToolText.Enabled := True; FSCS_Main.aToolRichText.Enabled := True; FSCS_Main.aToolKnife.Enabled := False; FSCS_Main.aToolHDimLine.Enabled := False; FSCS_Main.aToolVDimLine.Enabled := False; FSCS_Main.aTextFont.Enabled := False; FSCS_Main.aTextSize.Enabled := False; FSCS_Main.aToolMultiLine.Enabled := False; FSCS_Main.aToolOrthoLine.Enabled := False; FSCS_Main.aToolOrthoLineExt.Enabled := False; FSCS_Main.aSetSubstrateLayer.Enabled := False; FSCS_Main.aSetSCSLayer.Enabled := False; FSCS_Main.aAutoSelectTrace.Enabled := False; FSCS_Main.aOpenProject.Enabled := False; FSCS_Main.aViewSCSObjectsProp.Enabled := False; FSCS_Main.aCreateRaise.Enabled := False; FSCS_Main.aDestroyRaise.Enabled := False; FSCS_Main.aMasterAutoTrace.Enabled := False; FSCS_Main.aRaiseLine.Enabled := False; FSCS_Main.aNoMoveConnectedObjects.Enabled := False; FSCS_Main.aCreateObjectOnClick.Enabled := False; FSCS_Main.aShowConnFullness.Enabled := False; FSCS_Main.aShowCableFullness.Enabled := False; FSCS_Main.aShowCableChannelFullness.Enabled := False; FSCS_Main.aCreateObjectOnClickTool.Enabled := False; FSCS_Main.aCreateBlockToFile.Enabled := False; FSCS_Main.aCreateBlockToNB.Enabled := False; FSCS_Main.aInsertBlock.Enabled := True; FSCS_Main.aShiftUpObject.Enabled := False; FSCS_Main.aShiftDownObject.Enabled := False; FSCS_Main.aShiftLeftObject.Enabled := False; FSCS_Main.aShiftRightObject.Enabled := False; FSCS_Main.aDesignBox.Enabled := False; FSCS_Main.aShowTracesLengthLimit.Enabled := False; // FSCS_Main.cbLayers.Clear; FSCS_Main.cbLayers.Enabled := False; // Add FSCS_Main.aLoadFPlan.Enabled := False; FSCS_Main.aSaveFPlan.Enabled := False; FSCS_Main.aConnectionsConfigurator.Enabled := False; FSCS_Main.aMasterCableTracing.Enabled := False; FSCS_Main.aMasterCableChannel.Enabled := False; FSCS_Main.aToolCabinet.Enabled := False; FSCS_Main.aToolCabinetExt.Enabled := False; // Tolik 12/02/2021 -- FSCS_Main.aToolWallRect.Enabled := False; FSCS_Main.aToolWallPath.Enabled := False; FSCS_Main.aExport.Enabled := True; FSCS_Main.aExportDWG.Enabled := True; FSCS_Main.aToolHouse.Enabled := False; // Tolik 12/02/2021 -- FSCS_Main.tb3D.Enabled := False; FSCS_Main.aShowDefectObjects.Enabled := False; FSCS_Main.aShowDisconnectedObjects.Enabled := False; GCadform.tbShowPathLengthType.Enabled := False; GCadForm.tbShowPathTraceLengthType.Enabled := False; FSCS_Main.aToolSCSArcDimLine.Enabled := False; FSCS_Main.aToolPie.Enabled := False; FSCS_Main.aToolSCSVDimLine.Enabled := False; FSCS_Main.aToolSCSHDimLine.Enabled := False; // except on E: Exception do addExceptionToLogEx('U_Common.DisableOptionsForDesignList', E.Message); end; end; procedure DisableOptionsForProjectPlan; begin try //aToolArc ? FSCS_Main.aSaveAsSubstrate.Enabled := False; FSCS_Main.aImport.Enabled := False; FSCS_Main.aUndo.Enabled := True; FSCS_Main.aRedo.Enabled := True; FSCS_Main.aCopy.Enabled := False; FSCS_Main.aCut.Enabled := False; FSCS_Main.aPaste.Enabled := False; FSCS_Main.aSelectAll.Enabled := False; FSCS_Main.aViewLayers.Enabled := False; FSCS_Main.aRotate.Enabled := False; FSCS_Main.aBackwards.Enabled := False; FSCS_Main.aForward.Enabled := False; FSCS_Main.aGrouping.Enabled := False; FSCS_Main.aUngrouping.Enabled := False; FSCS_Main.aLock.Enabled := False; FSCS_Main.aUnlock.Enabled := False; FSCS_Main.aObjProperties.Enabled := False; FSCS_Main.aLoadSubstrate.Enabled := False; // FSCS_Main.aViewProjectManager.Enabled := False; FSCS_Main.aDelete.Enabled := False; FSCS_Main.aDeleteAll.Enabled := False; FSCS_Main.aDeSelectAll.Enabled := False; FSCS_Main.aInsertText.Enabled := True; FSCS_Main.aInsertBitmap.Enabled := True; FSCS_Main.aPenStyle.Enabled := False; FSCS_Main.aPenWidth.Enabled := False; FSCS_Main.aRowStyle.Enabled := False; FSCS_Main.aBrushStyle.Enabled := False; FSCS_Main.aTextCharset.Enabled := False; FSCS_Main.aFontStyle.Enabled := False; FSCS_Main.aFormatOrder.Enabled := False; FSCS_Main.aFormatAlign.Enabled := False; FSCS_Main.aSnaptoGrid.Enabled := False; FSCS_Main.aSnaptoGuides.Enabled := False; FSCS_Main.aSnaptoNearObject.Enabled := False; FSCS_Main.aSendtoBack.Enabled := False; FSCS_Main.aBringtoFront.Enabled := False; FSCS_Main.aSendBackwards.Enabled := False; FSCS_Main.aBringForwards.Enabled := False; FSCS_Main.aMoveSelection.Enabled := False; FSCS_Main.aRotateSelection.Enabled := False; FSCS_Main.aDuplicateSelection.Enabled := False; FSCS_Main.aMirrorSelection.Enabled := False; FSCS_Main.aToolLine.Enabled := False; FSCS_Main.aToolRectangle.Enabled := False; FSCS_Main.aToolEllipse.Enabled := False; FSCS_Main.aToolCircle.Enabled := False; FSCS_Main.aToolArc.Enabled := False; FSCS_Main.aToolElipticArc.Enabled := False; FSCS_Main.aToolPolyLine.Enabled := False; FSCS_Main.aToolPoint.Enabled := False; FSCS_Main.aToolText.Enabled := False; FSCS_Main.aToolRichText.Enabled := False; FSCS_Main.aToolKnife.Enabled := False; FSCS_Main.aToolHDimLine.Enabled := False; FSCS_Main.aToolVDimLine.Enabled := False; FSCS_Main.aTextFont.Enabled := False; FSCS_Main.aTextSize.Enabled := False; FSCS_Main.aToolMultiLine.Enabled := False; FSCS_Main.aToolOrthoLine.Enabled := False; FSCS_Main.aToolOrthoLineExt.Enabled := False; FSCS_Main.aSetSubstrateLayer.Enabled := False; FSCS_Main.aSetSCSLayer.Enabled := False; FSCS_Main.aAutoSelectTrace.Enabled := False; FSCS_Main.aOpenProject.Enabled := False; FSCS_Main.aViewSCSObjectsProp.Enabled := False; FSCS_Main.aCreateRaise.Enabled := False; FSCS_Main.aDestroyRaise.Enabled := False; FSCS_Main.aMasterAutoTrace.Enabled := False; FSCS_Main.aRaiseLine.Enabled := False; FSCS_Main.aNoMoveConnectedObjects.Enabled := False; FSCS_Main.aCreateObjectOnClick.Enabled := False; FSCS_Main.aShowConnFullness.Enabled := False; FSCS_Main.aShowCableFullness.Enabled := False; FSCS_Main.aShowCableChannelFullness.Enabled := False; FSCS_Main.aCreateObjectOnClickTool.Enabled := False; FSCS_Main.aCreateBlockToFile.Enabled := False; FSCS_Main.aCreateBlockToNB.Enabled := False; FSCS_Main.aInsertBlock.Enabled := True; FSCS_Main.aShiftUpObject.Enabled := False; FSCS_Main.aShiftDownObject.Enabled := False; FSCS_Main.aShiftLeftObject.Enabled := False; FSCS_Main.aShiftRightObject.Enabled := False; FSCS_Main.aDesignBox.Enabled := False; FSCS_Main.aShowTracesLengthLimit.Enabled := False; //FSCS_Main.cbLayers.Clear; FSCS_Main.cbLayers.Enabled := False; // Add FSCS_Main.aLoadFPlan.Enabled := False; FSCS_Main.aSaveFPlan.Enabled := False; FSCS_Main.aConnectionsConfigurator.Enabled := False; FSCS_Main.aMasterCableTracing.Enabled := False; FSCS_Main.aMasterCableChannel.Enabled := False; FSCS_Main.aExport.Enabled := True; FSCS_Main.aExportDWG.Enabled := True; // FSCS_Main.aToolCabinet.Enabled := False; FSCS_Main.aToolCabinetExt.Enabled := False; FSCS_Main.aToolWallRect.Enabled := False; FSCS_Main.aToolWallPath.Enabled := False; FSCS_Main.aToolSCSVDimLine.Enabled := False; FSCS_Main.aToolSCSHDimLine.Enabled := False; // FSCS_Main.aToolHouse.Enabled := False; // Tolik 12/02/2021 -- FSCS_Main.tb3D.Enabled := False; FSCS_Main.aShowDefectObjects.Enabled := False; FSCS_Main.aShowDisconnectedObjects.Enabled := False; FSCS_Main.aToolSCSArcDimLine.Enabled := False; GCadform.tbShowPathLengthType.Enabled := False; GCadForm.tbShowPathTraceLengthType.Enabled := False; FSCS_Main.aToolPie.Enabled := False; // except on E: Exception do addExceptionToLogEx('U_Common.DisableOptionsForProjectPlan', E.Message); end; end; Procedure DisableOptionsForEl_Scheme; // Tolik 10/02/2021 -- begin try FSCS_Main.aSaveAsSubstrate.Enabled := False; FSCS_Main.aImport.Enabled := False; FSCS_Main.aUndo.Enabled := True; FSCS_Main.aRedo.Enabled := True; FSCS_Main.aCopy.Enabled := True; FSCS_Main.aCut.Enabled := True; FSCS_Main.aPaste.Enabled := True; FSCS_Main.aSelectAll.Enabled := True; FSCS_Main.aViewLayers.Enabled := False; FSCS_Main.aRotate.Enabled := True; FSCS_Main.aBackwards.Enabled := False; FSCS_Main.aForward.Enabled := False; FSCS_Main.aGrouping.Enabled := True; FSCS_Main.aUngrouping.Enabled := True; FSCS_Main.aLock.Enabled := False; FSCS_Main.aUnlock.Enabled := False; FSCS_Main.aObjProperties.Enabled := False; FSCS_Main.aLoadSubstrate.Enabled := False; FSCS_Main.aDelete.Enabled := True; FSCS_Main.aDeleteAll.Enabled := True; FSCS_Main.aDeSelectAll.Enabled := True; FSCS_Main.aInsertText.Enabled := True; FSCS_Main.aInsertBitmap.Enabled := True; FSCS_Main.aPenStyle.Enabled := True; FSCS_Main.aPenWidth.Enabled := True; FSCS_Main.aRowStyle.Enabled := True; FSCS_Main.aBrushStyle.Enabled := True; FSCS_Main.aTextCharset.Enabled := True; FSCS_Main.aFontStyle.Enabled := True; FSCS_Main.aFormatOrder.Enabled := True; FSCS_Main.aFormatAlign.Enabled := True; FSCS_Main.aSnaptoGrid.Enabled := False; FSCS_Main.aSnaptoGuides.Enabled := False; FSCS_Main.aSnaptoNearObject.Enabled := False; FSCS_Main.aSendtoBack.Enabled := True; FSCS_Main.aBringtoFront.Enabled := True; FSCS_Main.aSendBackwards.Enabled := False; FSCS_Main.aBringForwards.Enabled := False; FSCS_Main.aMoveSelection.Enabled := True; FSCS_Main.aRotateSelection.Enabled := True; FSCS_Main.aDuplicateSelection.Enabled := True; FSCS_Main.aMirrorSelection.Enabled := True; FSCS_Main.aToolLine.Enabled := True; FSCS_Main.aToolRectangle.Enabled := True; FSCS_Main.aToolEllipse.Enabled := True; FSCS_Main.aToolCircle.Enabled := True; FSCS_Main.aToolArc.Enabled := True; FSCS_Main.aToolElipticArc.Enabled := True; FSCS_Main.aToolPolyLine.Enabled := True; FSCS_Main.aToolPoint.Enabled := True; FSCS_Main.aToolText.Enabled := True; FSCS_Main.aToolRichText.Enabled := True; FSCS_Main.aToolKnife.Enabled := False; FSCS_Main.aToolHDimLine.Enabled := False; FSCS_Main.aToolVDimLine.Enabled := False; FSCS_Main.aTextFont.Enabled := True; FSCS_Main.aTextSize.Enabled := True; FSCS_Main.aToolMultiLine.Enabled := True; FSCS_Main.aToolOrthoLine.Enabled := False; FSCS_Main.aToolOrthoLineExt.Enabled := False; FSCS_Main.aSetSubstrateLayer.Enabled := False; FSCS_Main.aSetSCSLayer.Enabled := False; FSCS_Main.aAutoSelectTrace.Enabled := False; FSCS_Main.aOpenProject.Enabled := False; FSCS_Main.aViewSCSObjectsProp.Enabled := False; FSCS_Main.aCreateRaise.Enabled := False; FSCS_Main.aDestroyRaise.Enabled := False; FSCS_Main.aMasterAutoTrace.Enabled := False; FSCS_Main.aRaiseLine.Enabled := False; FSCS_Main.aNoMoveConnectedObjects.Enabled := False; FSCS_Main.aCreateObjectOnClick.Enabled := False; FSCS_Main.aShowConnFullness.Enabled := False; FSCS_Main.aShowCableFullness.Enabled := False; FSCS_Main.aShowCableChannelFullness.Enabled := False; FSCS_Main.aCreateObjectOnClickTool.Enabled := False; FSCS_Main.aCreateBlockToFile.Enabled := False; FSCS_Main.aCreateBlockToNB.Enabled := False; FSCS_Main.aInsertBlock.Enabled := True; FSCS_Main.aShiftUpObject.Enabled := False; FSCS_Main.aShiftDownObject.Enabled := False; FSCS_Main.aShiftLeftObject.Enabled := False; FSCS_Main.aShiftRightObject.Enabled := False; FSCS_Main.aDesignBox.Enabled := False; FSCS_Main.aShowTracesLengthLimit.Enabled := False; // FSCS_Main.cbLayers.Clear; FSCS_Main.cbLayers.Enabled := False; // Add FSCS_Main.aLoadFPlan.Enabled := False; FSCS_Main.aSaveFPlan.Enabled := False; FSCS_Main.aConnectionsConfigurator.Enabled := False; FSCS_Main.aMasterCableTracing.Enabled := False; FSCS_Main.aMasterCableChannel.Enabled := False; FSCS_Main.aExport.Enabled := True; FSCS_Main.aExportDWG.Enabled := True; FSCS_Main.aToolCabinet.Enabled := False; FSCS_Main.aToolCabinetExt.Enabled := False; FSCS_Main.aToolWallRect.Enabled := False; FSCS_Main.aToolWallPath.Enabled := False; FSCS_Main.aToolSCSVDimLine.Enabled := False; FSCS_Main.aToolSCSHDimLine.Enabled := False; FSCS_Main.aToolHouse.Enabled := False; FSCS_Main.tb3D.Enabled := False; FSCS_Main.aShowDefectObjects.Enabled := False; FSCS_Main.aShowDisconnectedObjects.Enabled := False; FSCS_Main.aToolSCSArcDimLine.Enabled := True; FSCS_Main.aToolPie.Enabled := True; GCadform.tbShowPathLengthType.Enabled := False; GCadForm.tbShowPathTraceLengthType.Enabled := False; except on E: Exception do addExceptionToLogEx('U_Common.DisableOptionsForEl_Scheme', E.Message); end; end; // функция получения номера layera по его хендлу function GLN(aLHandle: LongInt): integer; var i: integer; begin result := 1; try for i := 0 to GCadForm.PCad.LayerCount - 1 do begin if GCadForm.PCad.GetLayerHandle(i) = aLHandle then begin result := i; break; end; end; except end; end; // процедура для загрузки макета этажа procedure LoadFrameToList(aCad: TF_CAD; aMainStampName, aSideStampName: string; aListFormat: TListFormatType); var i, j: integer; LHandle: integer; FrameFileName: string; StampObject: TFigureGrp; RectangleObj: TRectangle; MainStampObj: TBlock; SideStampObj: TBlock; UpperStampObj: TRectangle; Bnd: TDoubleRect; deltax, deltay: double; FramePos: TDoublePoint; BlockFig: TBlock; InFigure: TFigure; InFigureGrp: TFigureGrp; begin try GAutoDelete := True; RemoveFrameFromList(aCad); GAutoDelete := False; if FileExists(aMainStampName) and FileExists(aSideStampName) then begin LHandle := aCad.PCad.GetLayerHandle(7); FramePos.x := aCad.PCad.WorkWidth / 2; FramePos.y := aCad.PCad.WorkHeight / 2; try // считать основной штамп MainStampObj := TBlock(aCad.PCad.GetFigureByDataID(100)); //10.11.2011 //if MainStampObj = nil then MainStampObj := TBlock(aCad.PCad.InsertBlockwithFileName(7, aMainStampName, -1000, -1000)); MainStampObj.Deselect; // считать боковой штапм SideStampObj := TBlock(aCad.PCad.InsertBlockwithFileName(7, aSideStampName, -1000, -1000)); SideStampObj.Deselect; // нарисовать верхний штамп UpperStampObj := TRectangle.create(-1000, -1000, -1000 + 70, -1000 + 15, 2, ord(psSolid), clBlack, ord(bsClear), clBlack, LHandle, mydsNormal, aCad.PCad); // нарисовать саму рамку Bnd.Left := aListFormat.StampFields.Margins.Left; //20; Bnd.Top := aListFormat.StampFields.Margins.Top; //5; Bnd.Right := aListFormat.PageWidth - aListFormat.StampFields.Margins.Right; //5; Bnd.Bottom := aListFormat.PageHeight - aListFormat.StampFields.Margins.Bottom; //5; RectangleObj := TRectangle.create(Bnd.Left, Bnd.Top, Bnd.Right, Bnd.Bottom, 2, ord(psSolid), clBlack, ord(bsClear), clBlack, LHandle, mydsNormal, aCad.PCad); // передвинуть штампы deltax := Bnd.Left - UpperStampObj.ap1.x; deltay := Bnd.Top - UpperStampObj.ap1.y; UpperStampObj.Move(deltax, deltay); deltax := Bnd.Left - SideStampObj.ap3.x; deltay := Bnd.Bottom - SideStampObj.ap3.y; SideStampObj.move(deltax, deltay); deltax := Bnd.Right - MainStampObj.ap3.x; deltay := Bnd.Bottom - MainStampObj.ap3.y; MainStampObj.move(deltax, deltay); // визибл/инвизибл штампы MainStampObj.Visible := aListFormat.ShowMainStamp; SetAllInFiguresVisible(MainStampObj, aListFormat.ShowMainStamp); SideStampObj.Visible := aListFormat.ShowSideStamp; SetAllInFiguresVisible(SideStampObj, aListFormat.ShowSideStamp); UpperStampObj.Visible := aListFormat.ShowUpperStamp; {$if Defined(SCS_PE) or Defined(SCS_PANDUIT)} RectangleObj.Visible := aListFormat.ShowUpperStamp or aListFormat.ShowSideStamp or aListFormat.ShowMainStamp; {$ifend} RectangleObj.DataID := 99; MainStampObj.DataID := 100; SideStampObj.DataID := 200; UpperStampObj.DataID := 300; // сгруппировать StampObject := TFigureGrp.create(LHandle, aCad.PCad); StampObject.AddFigure(RectangleObj); StampObject.AddFigure(MainStampObj); StampObject.AddFigure(SideStampObj); StampObject.AddFigure(UpperStampObj); GCadForm.PCad.Figures.Remove(MainStampObj); GCadForm.PCad.Figures.Remove(SideStampObj); SetAllStampFiguresLayer(StampObject, LHandle); SetAllStampTextsFont(StampObject, GCadForm.FFontName); aCad.PCad.AddCustomFigure(7, StampObject, False); // выставить подписи LoadCaptionsOnFrame(aCad, aCad.FCadStampType); aCad.FFrameFileName := StampObject.Name; except aCad.FFrameFileName := ''; end; end else begin aCad.FFrameFileName := ''; end; RefreshCAD(aCad.PCad); except on E: Exception do addExceptionToLogEx('U_Common.LoadFrameToList', E.Message); end; end; procedure LoadFrameOnMaket(aPCad: TPowerCad); var i, j: integer; LHandle: integer; FrameFileName: string; StampObject: TFigureGrp; RectangleObj: TRectangle; MainStampObj: TBlock; SideStampObj: TBlock; UpperStampObj: TRectangle; Bnd: TDoubleRect; deltax, deltay: double; FramePos: TDoublePoint; BlockFig: TBlock; InFigure: TFigure; InFigureGrp: TFigureGrp; FullPathName, MainStampName, SideStampName, StampTypeStr, StampLangStr: string; PageWidth, PageHeight: double; begin try aPCad.Clear(0); // определить параметры в именах блоков {$if Defined(ES_GRAPH_SC)} FullPathName := ExeDir + '\Stamp\'; {$else} FullPathName := ExtractFileDir(Application.ExeName) + '\Stamp\'; {$ifend} if F_MasterNewListLite.rbSimple.Checked then StampTypeStr := 'Small'; if F_MasterNewListLite.rbExtended.Checked then StampTypeStr := 'Big'; if F_MasterNewListLite.rbDetailed.Checked then StampTypeStr := 'ExtBig'; // if F_MasterNewListLite.rbRus.Checked then // StampLangStr := 'eng'; if F_MasterNewListLite.rbUkr.Checked then StampLangStr := 'ukr'; if F_MasterNewListLite.rbRus.Checked then StampLangStr := 'rus'; // MainStampName := FullPathName + StampTypeStr + '_Main_' + StampLangStr + '.sch'; SideStampName := FullPathName + StampTypeStr + '_Side_' + StampLangStr + '.sch'; if FileExists(MainStampName) and FileExists(SideStampName) then begin LHandle := aPCad.GetLayerHandle(0); FramePos.x := aPCad.WorkWidth / 2; FramePos.y := aPCad.WorkHeight / 2; PageWidth := StrToFloat_My(F_MasterNewListLite.edWidth.Text); PageHeight := StrToFloat_My(F_MasterNewListLite.edHeight.Text); // считать основной штамп MainStampObj := TBlock(aPCad.InsertBlockwithFileName(0, MainStampName, -1000, -1000)); MainStampObj.Deselect; // считать боковой штапм SideStampObj := TBlock(aPCad.InsertBlockwithFileName(0, SideStampName, -1000, -1000)); SideStampObj.Deselect; // нарисовать верхний штамп UpperStampObj := TRectangle.create(-1000, -1000, -1000 + 70, -1000 + 15, 2, ord(psSolid), clBlack, ord(bsClear), clBlack, LHandle, mydsNormal, aPCad); // нарисовать саму рамку Bnd.Left := F_MasterNewListLite.seStampMarginLeft.Value; //20; Bnd.Top := F_MasterNewListLite.seStampMarginTop.Value; // 5; Bnd.Right := PageWidth - F_MasterNewListLite.seStampMarginRight.Value; //5; Bnd.Bottom := PageHeight - F_MasterNewListLite.seStampMarginBottom.Value; //5; RectangleObj := TRectangle.create(Bnd.Left, Bnd.Top, Bnd.Right, Bnd.Bottom, 2, ord(psSolid), clBlack, ord(bsClear), clBlack, LHandle, mydsNormal, aPCad); // передвинуть штампы deltax := Bnd.Left - UpperStampObj.ap1.x; deltay := Bnd.Top - UpperStampObj.ap1.y; UpperStampObj.Move(deltax, deltay); deltax := Bnd.Left - SideStampObj.ap3.x; deltay := Bnd.Bottom - SideStampObj.ap3.y; SideStampObj.move(deltax, deltay); deltax := Bnd.Right - MainStampObj.ap3.x; deltay := Bnd.Bottom - MainStampObj.ap3.y; MainStampObj.move(deltax, deltay); // визибл/инвизибл штампы MainStampObj.Visible := F_MasterNewListLite.cbShowMainStamp.Checked; SetAllInFiguresVisible(MainStampObj, F_MasterNewListLite.cbShowMainStamp.Checked); SideStampObj.Visible := F_MasterNewListLite.cbShowSideStamp.Checked; SetAllInFiguresVisible(SideStampObj, F_MasterNewListLite.cbShowSideStamp.Checked); UpperStampObj.Visible := F_MasterNewListLite.cbShowUpperStamp.Checked; {$if Defined(SCS_PE) or Defined(SCS_PANDUIT)} RectangleObj.Visible := MainStampObj.Visible or SideStampObj.Visible or UpperStampObj.Visible; {$ifend} RectangleObj.DataID := 99; // сгруппировать StampObject := TFigureGrp.create(LHandle, aPCad); StampObject.AddFigure(RectangleObj); StampObject.AddFigure(MainStampObj); StampObject.AddFigure(SideStampObj); StampObject.AddFigure(UpperStampObj); aPCad.Figures.Remove(MainStampObj); aPCad.Figures.Remove(SideStampObj); SetAllStampFiguresLayer(StampObject, LHandle); SetAllStampTextsFont(StampObject, F_MasterNewListLite.cbFontName.FontName); aPCad.AddCustomFigure(0, StampObject, False); RefreshCAD(aPCad); end; except on E: Exception do AddExceptionToLogEx('U_Common.LoadFrameOnMaket', E.Message); end; end; procedure RemoveFrameFromList(aCad: TF_CAD); var FullPathName: string; FName: string; i: Integer; FrameFigure: TFigure; begin try FullPathName := ExtractSaveDir; FName := ExtractFileName(aCad.FFrameFileName); if FName = '' then FName := 'Unknown.sch'; FullPathName := FullPathName + '\' + FName; {//17.11.2011 if aCad.FFrameProjectName <> nil then begin aCad.PCad.Figures.Remove(aCad.FFrameProjectName); FreeAndNil(aCad.FFrameProjectName); end; if aCad.FFrameListName <> nil then begin aCad.PCad.Figures.Remove(aCad.FFrameListName); FreeAndNil(aCad.FFrameListName); end; if aCad.FFrameCodeName <> nil then begin aCad.PCad.Figures.Remove(aCad.FFrameCodeName); FreeAndNil(aCad.FFrameCodeName); end; if aCad.FFrameIndexName <> nil then begin aCad.PCad.Figures.Remove(aCad.FFrameIndexName); FreeAndNil(aCad.FFrameIndexName); end;} try for i := 0 to aCad.FFrameObjects.Count - 1 do begin FrameFigure := TFigure(aCad.FFrameObjects.Objects[i]); if FrameFigure <> nil then begin aCad.PCad.Figures.Remove(FrameFigure); FreeAndNil(FrameFigure); aCad.FFrameObjects.Objects[i] := nil; end; end; finally aCad.ClearFrameFigures; end; RefreshCAD(aCad.PCad); FSCS_Main.SaveStamp(FullPathName); aCad.PCad.DeselectAll(0); aCad.PCad.SelectAll(7); aCad.PCad.RemoveSelection; RefreshCAD(aCad.PCad); except on E: Exception do addExceptionToLogEx('U_Common.RemoveFrameFromList', E.Message); end; end; procedure LoadCaptionsOnFrame(ACAD: TF_CAD; AStampType: TStampType; ACreateForLack: Boolean=true; AEnabledCaptions: TintList=nil); var aProjectName: string; aListName: string; aCodeName: string; aIndexName: string; LHandle: Integer; aBnd: TDoubleRect; aTextWidth, aTextHeight: Double; aPoint: TDoublePoint; deltax, deltay: double; TextObject: TFigure; _TextX, _TextY: double; ProjParams: TProjectParams; ListParams: TListParams; i: integer; FrameFigure: TFigure; FrameFigureCode: Integer; procedure ReCreateDeveloper; begin // Разработал //aBnd.Left := (ACAD.PCad.WorkWidth {/ GCadForm.FListCountX}) - ACAD.FCadStampMargins.Right - 185.5; //14.11.2011 - 5 - 120; //aBnd.Right := (ACAD.PCad.WorkWidth {/ GCadForm.FListCountX}) - ACAD.FCadStampMargins.Right - 135.5; //14.11.2011 - 5 - 50; //aBnd.Top := (ACAD.PCad.WorkHeight {/ GCadForm.FListCountY}) - ACAD.FCadStampMargins.Bottom - 34.5; //14.11.2011 - 5 - 30; //aBnd.Bottom := (ACAD.PCad.WorkHeight {/ GCadForm.FListCountY}) - ACAD.FCadStampMargins.Bottom - 19.5; //14.11.2011 - 5 - 15; aBnd.Left := (ACAD.PCad.WorkWidth {/ GCadForm.FListCountX}) - ACAD.FStampFields.Margins.Right - 164.5; //14.11.2011 - 5 - 120; aBnd.Right := (ACAD.PCad.WorkWidth {/ GCadForm.FListCountX}) - ACAD.FStampFields.Margins.Right - 104.5; //14.11.2011 - 5 - 50; aBnd.Top := (ACAD.PCad.WorkHeight {/ GCadForm.FListCountY}) - ACAD.FStampFields.Margins.Bottom - 32; //14.11.2011 - 5 - 30; aBnd.Bottom := (ACAD.PCad.WorkHeight {/ GCadForm.FListCountY}) - ACAD.FStampFields.Margins.Bottom - 22; //14.11.2011 - 5 - 15; ACAD.FFrameStampDeveloper := ReCreateStampCaptionToField(ACAD, ACAD.FFrameStampDeveloper, ftDeveloperName, aBnd, ACAD.FStampFields.Developer, ACreateForLack, AEnabledCaptions, false, 10); end; //03.10.2012 procedure ReCreateChecker; begin // Проверил aBnd.Left := (ACAD.PCad.WorkWidth {/ GCadForm.FListCountX}) - ACAD.FStampFields.Margins.Right - 164.5; //14.11.2011 - 5 - 120; aBnd.Right := (ACAD.PCad.WorkWidth {/ GCadForm.FListCountX}) - ACAD.FStampFields.Margins.Right - 104.5; //14.11.2011 - 5 - 50; aBnd.Top := (ACAD.PCad.WorkHeight {/ GCadForm.FListCountY}) - ACAD.FStampFields.Margins.Bottom - 27; //14.11.2011 - 5 - 30; aBnd.Bottom := (ACAD.PCad.WorkHeight {/ GCadForm.FListCountY}) - ACAD.FStampFields.Margins.Bottom - 17; //14.11.2011 - 5 - 15; ACAD.FFrameStampChecker := ReCreateStampCaptionToField(ACAD, ACAD.FFrameStampChecker, ftCheckerName, aBnd, ACAD.FStampFields.Checker, ACreateForLack, AEnabledCaptions, false, 10); end; procedure ReCreateMainEngineer; begin // Главный инженер проекта aBnd.Left := ACAD.PCad.WorkWidth - ACAD.FStampFields.Margins.Right - 164.5; aBnd.Right := ACAD.PCad.WorkWidth - ACAD.FStampFields.Margins.Right - 104.5; aBnd.Top := ACAD.PCad.WorkHeight - ACAD.FStampFields.Margins.Bottom - 22; aBnd.Bottom := ACAD.PCad.WorkHeight - ACAD.FStampFields.Margins.Bottom - 12; ReCreateStampCaptionToField(ACAD, nil, ftMainEngineer, aBnd, ACAD.FStampFields.MainEngineer, ACreateForLack, AEnabledCaptions, false, 10); end; procedure ReCreateApproved; begin // Утвердил aBnd.Left := ACAD.PCad.WorkWidth - ACAD.FStampFields.Margins.Right - 164.5; aBnd.Right := ACAD.PCad.WorkWidth - ACAD.FStampFields.Margins.Right - 104.5; aBnd.Top := ACAD.PCad.WorkHeight - ACAD.FStampFields.Margins.Bottom - 12; aBnd.Bottom := ACAD.PCad.WorkHeight - ACAD.FStampFields.Margins.Bottom - 2; ReCreateStampCaptionToField(ACAD, nil, ftApproved, aBnd, ACAD.FStampFields.Approved, ACreateForLack, AEnabledCaptions, false, 10); end; procedure ReCreateDesignStage; begin // Стадия проектир aBnd.Left := ACAD.PCad.WorkWidth - ACAD.FStampFields.Margins.Right - 20 - 30; aBnd.Right := ACAD.PCad.WorkWidth - ACAD.FStampFields.Margins.Right - 20 - 15; aBnd.Top := ACAD.PCad.WorkHeight - ACAD.FStampFields.Margins.Bottom - 15 - 10; aBnd.Bottom := ACAD.PCad.WorkHeight - ACAD.FStampFields.Margins.Bottom - 15; ReCreateStampCaptionToField(ACAD, nil, ftDesignStage, aBnd, ACAD.FStampFields.DesignStage, ACreateForLack, AEnabledCaptions, true, 12); end; procedure ReCreateListDescription; var aListDescription: String; begin aListDescription := ''; if ListParams.Settings.ListType <> lt_Normal then begin case ListParams.Settings.ListType of lt_DesignBox: if ListParams.Settings.CADStampLang in [stl_ukr, stl_ukr_dstu] then aListDescription := cCommon_Mes25_ukr else aListDescription := cCommon_Mes25; lt_ProjectPlan: if ListParams.Settings.CADStampLang in [stl_ukr, stl_ukr_dstu] then aListDescription := cCommon_Mes26_ukr else aListDescription := cCommon_Mes26; //Tolik 10/02/2021 -- lt_ElScheme: aListDescription := c_ELMes1; // //Tolik 06/2/2023 lt_AScheme: aListDescription := c_ELMes2; end; end; // Описание пренадлежности листа aBnd.Left := ACAD.PCad.WorkWidth - ACAD.FStampFields.Margins.Right - 119; aBnd.Right := ACAD.PCad.WorkWidth - ACAD.FStampFields.Margins.Right - 50; aBnd.Top := ACAD.PCad.WorkHeight - ACAD.FStampFields.Margins.Bottom - 15 - 1; aBnd.Bottom := ACAD.PCad.WorkHeight - ACAD.FStampFields.Margins.Bottom - 1; ReCreateStampCaptionToField(ACAD, nil, ftListDescription, aBnd, aListDescription, ACreateForLack, nil, true, 13); end; procedure ReCreateFillFields; begin // Разработал ReCreateDeveloper; // Проверил ReCreateChecker; // Главный инженер проекта ReCreateMainEngineer; // Утвердил ReCreateApproved; // Стадия проектир ReCreateDesignStage; // Описание пренадлежности листа ReCreateListDescription; end; begin ACAD.PCad.DisableAlign; try ProjParams := GetCurrProjectParams(false); aProjectName := ProjParams.Caption; ListParams := GetListParams(ACAD.FCADListID); aListName := ListParams.Name; if ACAD.FStampFields.ListSign <> '' then aListName := ACAD.FStampFields.ListSign; aCodeName := ListParams.Name; // Tolik 06/06/2021 -- //aIndexName := IntToStr(ListParams.MarkID); if GCadForm.FListType = lt_Normal then aIndexName := IntToStr(ListParams.MarkID); // LHandle := ACAD.PCad.GetLayerHandle(7); // ПРОСТОЙ if AStampType = stt_simple then begin // номер листа aBnd.Left := (ACAD.PCad.WorkWidth {/ GCadForm.FListCountX}) - ACAD.FStampFields.Margins.Right - 10; //14.11.2011 5 - 10; aBnd.Right := (ACAD.PCad.WorkWidth {/ GCadForm.FListCountX}) - ACAD.FStampFields.Margins.Right; //14.11.2011 5; aBnd.Top := (ACAD.PCad.WorkHeight {/ GCadForm.FListCountY}) - ACAD.FStampFields.Margins.Bottom - 8; //14.11.2011 - 5 - 8; aBnd.Bottom := (ACAD.PCad.WorkHeight {/ GCadForm.FListCountY}) - ACAD.FStampFields.Margins.Bottom; //14.11.2011 - 5; //13.09.2010 //if GCadForm.FFrameIndexName = nil then //begin // if ACreateForLack then // begin // GCadForm.FFrameIndexName := CreateStampCaptionToField(aBnd, aIndexName); // GCadForm.FFrameIndexName.DataID := 400; // GCadForm.PCad.AddCustomFigure (GLN(LHandle), GCadForm.FFrameIndexName, False); // end; //end //else //begin // GCadForm.PCad.Figures.Remove(GCadForm.FFrameIndexName); // RefreshCad(GCadForm.PCad); // GCadForm.FFrameIndexName := CreateStampCaptionToField(aBnd, aIndexName); // GCadForm.FFrameIndexName.DataID := 400; // GCadForm.PCad.AddCustomFigure (GLN(LHandle), GCadForm.FFrameIndexName, False); //end; ACAD.FFrameIndexName := ReCreateStampCaptionToField(ACAD, ACAD.FFrameIndexName, 400, aBnd, aIndexName, ACreateForLack, AEnabledCaptions); // лист aBnd.Left := (ACAD.PCad.WorkWidth {/ GCadForm.FListCountX}) - ACAD.FStampFields.Margins.Right - 120; //14.11.2011 - 5 - 120; aBnd.Right := (ACAD.PCad.WorkWidth {/ GCadForm.FListCountX}) - ACAD.FStampFields.Margins.Right - 10; //14.11.2011 - 5 - 10; aBnd.Top := (ACAD.PCad.WorkHeight {/ GCadForm.FListCountY}) - ACAD.FStampFields.Margins.Bottom - 15; //14.11.2011 - 5 - 15; aBnd.Bottom := (ACAD.PCad.WorkHeight {/ GCadForm.FListCountY}) - ACAD.FStampFields.Margins.Bottom; //14.11.2011 - 5; //13.09.2010 //if GCadForm.FFrameListName = nil then //begin // if ACreateForLack then // begin // GCadForm.FFrameListName := CreateStampCaptionToField(aBnd, aListName); // GCadForm.FFrameListName.DataID := 200; // GCadForm.PCad.AddCustomFigure (GLN(LHandle), GCadForm.FFrameListName, False); // end; //end //else //begin // GCadForm.PCad.Figures.Remove(GCadForm.FFrameListName); // RefreshCad(GCadForm.PCad); // GCadForm.FFrameListName := CreateStampCaptionToField(aBnd, aListName); // GCadForm.FFrameListName.DataID := 200; // GCadForm.PCad.AddCustomFigure (GLN(LHandle), GCadForm.FFrameListName, False); //end; ACAD.FFrameListName := ReCreateStampCaptionToField(ACAD, ACAD.FFrameListName, 200, aBnd, aListName, ACreateForLack, AEnabledCaptions); end; // РАСШИРЕННЫЙ if AStampType = stt_extended then begin // номер листа aBnd.Left := (ACAD.PCad.WorkWidth {/ GCadForm.FListCountX}) - ACAD.FStampFields.Margins.Right - 20 - 15; //14.11.2011 - 5 - 20 - 15; aBnd.Right := (ACAD.PCad.WorkWidth {/ GCadForm.FListCountX}) - ACAD.FStampFields.Margins.Right - 20; //14.11.2011 - 5 - 20; aBnd.Top := (ACAD.PCad.WorkHeight {/ GCadForm.FListCountY}) - ACAD.FStampFields.Margins.Bottom - 15 - 10; //14.11.2011 - 5 - 15 - 10; aBnd.Bottom := (ACAD.PCad.WorkHeight {/ GCadForm.FListCountY}) - ACAD.FStampFields.Margins.Bottom - 15; //14.11.2011 - 5 - 15; //13.09.2010 //if GCadForm.FFrameIndexName = nil then //begin // if ACreateForLack then // begin // GCadForm.FFrameIndexName := CreateStampCaptionToField(aBnd, aIndexName); // GCadForm.FFrameIndexName.DataID := 400; // GCadForm.PCad.AddCustomFigure (GLN(LHandle), GCadForm.FFrameIndexName, False); // end; //end //else //begin // GCadForm.PCad.Figures.Remove(GCadForm.FFrameIndexName); // RefreshCad(GCadForm.PCad); // GCadForm.FFrameIndexName := CreateStampCaptionToField(aBnd, aIndexName); // GCadForm.FFrameIndexName.DataID := 400; // GCadForm.PCad.AddCustomFigure (GLN(LHandle), GCadForm.FFrameIndexName, False); //end; ACAD.FFrameIndexName := ReCreateStampCaptionToField(ACAD, ACAD.FFrameIndexName, 400, aBnd, aIndexName, ACreateForLack, AEnabledCaptions); // лист aBnd.Left := (ACAD.PCad.WorkWidth {/ GCadForm.FListCountX}) - ACAD.FStampFields.Margins.Right - 120; //14.11.2011 - 5 - 120; aBnd.Right := (ACAD.PCad.WorkWidth {/ GCadForm.FListCountX}) - ACAD.FStampFields.Margins.Right; //14.11.2011 - 5; aBnd.Top := (ACAD.PCad.WorkHeight {/ GCadForm.FListCountY}) - ACAD.FStampFields.Margins.Bottom - 45; //14.11.2011 - 5 - 45; aBnd.Bottom := (ACAD.PCad.WorkHeight {/ GCadForm.FListCountY}) - ACAD.FStampFields.Margins.Bottom - 30; //14.11.2011 - 5 - 30; //13.09.2010 //if GCadForm.FFrameListName = nil then //begin // if ACreateForLack then // begin // GCadForm.FFrameListName := CreateStampCaptionToField(aBnd, aListName); // GCadForm.FFrameListName.DataID := 200; // GCadForm.PCad.AddCustomFigure (GLN(LHandle), GCadForm.FFrameListName, False); // end; //end //else //begin // GCadForm.PCad.Figures.Remove(GCadForm.FFrameListName); // RefreshCad(GCadForm.PCad); // GCadForm.FFrameListName := CreateStampCaptionToField(aBnd, aListName); // GCadForm.FFrameListName.DataID := 200; // GCadForm.PCad.AddCustomFigure (GLN(LHandle), GCadForm.FFrameListName, False); //end; //18.11.2011 ACAD.FFrameListName := ReCreateStampCaptionToField(ACAD, ACAD.FFrameListName, 200, aBnd, aListName, ACreateForLack, AEnabledCaptions); ACAD.FFrameListName := ReCreateStampCaptionToField(ACAD, ACAD.FFrameListName, 200, aBnd, aListName, ACreateForLack, AEnabledCaptions); // проект aBnd.Left := (ACAD.PCad.WorkWidth {/ GCadForm.FListCountX}) - ACAD.FStampFields.Margins.Right - 120; //14.11.2011 - 5 - 120; aBnd.Right := (ACAD.PCad.WorkWidth {/ GCadForm.FListCountX}) - ACAD.FStampFields.Margins.Right - 50; //14.11.2011 - 5 - 50; aBnd.Top := (ACAD.PCad.WorkHeight {/ GCadForm.FListCountY}) - ACAD.FStampFields.Margins.Bottom - 30; //14.11.2011 - 5 - 30; aBnd.Bottom := (ACAD.PCad.WorkHeight {/ GCadForm.FListCountY}) - ACAD.FStampFields.Margins.Bottom - 15; //14.11.2011 - 5 - 15; //13.09.2010 //if GCadForm.FFrameProjectName = nil then //begin // if ACreateForLack then // begin // GCadForm.FFrameProjectName := CreateStampCaptionToField(aBnd, aProjectName); // GCadForm.FFrameProjectName.DataID := 100; // GCadForm.PCad.AddCustomFigure (GLN(LHandle), GCadForm.FFrameProjectName, False); // end; //end //else //begin // GCadForm.PCad.Figures.Remove(GCadForm.FFrameProjectName); // RefreshCad(GCadForm.PCad); // GCadForm.FFrameProjectName := CreateStampCaptionToField(aBnd, aProjectName); // GCadForm.FFrameProjectName.DataID := 100; // GCadForm.PCad.AddCustomFigure (GLN(LHandle), GCadForm.FFrameProjectName, False); //end; ACAD.FFrameProjectName := ReCreateStampCaptionToField(ACAD, ACAD.FFrameProjectName, 100, aBnd, aProjectName, ACreateForLack, AEnabledCaptions); // Заполняемые поля рамки ReCreateFillFields; end; // ПОДРОБНЫЙ if AStampType = stt_detailed then begin // номер листа aBnd.Left := (ACAD.PCad.WorkWidth {/ GCadForm.FListCountX}) - ACAD.FStampFields.Margins.Right - 20 - 15; //14.11.2011 - 5 - 20 - 15; aBnd.Right := (ACAD.PCad.WorkWidth {/ GCadForm.FListCountX}) - ACAD.FStampFields.Margins.Right - 20; //14.11.2011 - 5 - 20; aBnd.Top := (ACAD.PCad.WorkHeight {/ GCadForm.FListCountY}) - ACAD.FStampFields.Margins.Bottom - 15 - 10; //14.11.2011 - 5 - 15 - 10; aBnd.Bottom := (ACAD.PCad.WorkHeight {/ GCadForm.FListCountY}) - ACAD.FStampFields.Margins.Bottom - 15; //14.11.2011 - 5 - 15; //13.09.2010 //if GCadForm.FFrameIndexName = nil then //begin // if ACreateForLack then // begin // GCadForm.FFrameIndexName := CreateStampCaptionToField(aBnd, aIndexName); // GCadForm.FFrameIndexName.DataID := 400; // GCadForm.PCad.AddCustomFigure (GLN(LHandle), GCadForm.FFrameIndexName, False); // end; //end //else //begin // GCadForm.PCad.Figures.Remove(GCadForm.FFrameIndexName); // RefreshCad(GCadForm.PCad); // GCadForm.FFrameIndexName := CreateStampCaptionToField(aBnd, aIndexName); // GCadForm.FFrameIndexName.DataID := 400; // GCadForm.PCad.AddCustomFigure (GLN(LHandle), GCadForm.FFrameIndexName, False); //end; ACAD.FFrameIndexName := ReCreateStampCaptionToField(ACAD, ACAD.FFrameIndexName, 400, aBnd, aIndexName, ACreateForLack, AEnabledCaptions); // лист aBnd.Left := (ACAD.PCad.WorkWidth {/ GCadForm.FListCountX}) - ACAD.FStampFields.Margins.Right - 120; //14.11.2011 - 5 - 120; aBnd.Right := (ACAD.PCad.WorkWidth {/ GCadForm.FListCountX}) - ACAD.FStampFields.Margins.Right; //14.11.2011 - 5; aBnd.Top := (ACAD.PCad.WorkHeight {/ GCadForm.FListCountY}) - ACAD.FStampFields.Margins.Bottom - 55; //14.11.2011 - 5 - 55; aBnd.Bottom := (ACAD.PCad.WorkHeight {/ GCadForm.FListCountY}) - ACAD.FStampFields.Margins.Bottom - 45; //14.11.2011 - 5 - 45; //13.09.2010 //if GCadForm.FFrameListName = nil then //begin // if ACreateForLack then // begin // GCadForm.FFrameListName := CreateStampCaptionToField(aBnd, aListName); // GCadForm.FFrameListName.DataID := 200; // GCadForm.PCad.AddCustomFigure(GLN(LHandle), GCadForm.FFrameListName, False); // end; //end //else //begin // GCadForm.PCad.Figures.Remove(GCadForm.FFrameListName); // RefreshCad(GCadForm.PCad); // GCadForm.FFrameListName := CreateStampCaptionToField(aBnd, aListName); // GCadForm.FFrameListName.DataID := 200; // GCadForm.PCad.AddCustomFigure (GLN(LHandle), GCadForm.FFrameListName, False); //end; ACAD.FFrameListName := ReCreateStampCaptionToField(ACAD, ACAD.FFrameListName, 200, aBnd, aListName, ACreateForLack, AEnabledCaptions); // Организация aBnd.Left := ACAD.PCad.WorkWidth - ACAD.FStampFields.Margins.Right - 119; aBnd.Right := ACAD.PCad.WorkWidth - ACAD.FStampFields.Margins.Right; aBnd.Top := ACAD.PCad.WorkHeight - ACAD.FStampFields.Margins.Bottom - 45; aBnd.Bottom := ACAD.PCad.WorkHeight - ACAD.FStampFields.Margins.Bottom - 30; ReCreateStampCaptionToField(ACAD, nil, ftOrgName, aBnd, ProjParams.Setting.OrganizationName, ACreateForLack, AEnabledCaptions); // проект //03.10.2012 - дна этом месте теперь название организации //aBnd.Left := ACAD.PCad.WorkWidth - ACAD.FStampFields.Margins.Right - 120; //14.11.2011 - 5 - 120; //aBnd.Right := ACAD.PCad.WorkWidth - ACAD.FStampFields.Margins.Right; //14.11.2011 - 5; //aBnd.Top := ACAD.PCad.WorkHeight - ACAD.FStampFields.Margins.Bottom - 45; //14.11.2011 - 5 - 45; //aBnd.Bottom := ACAD.PCad.WorkHeight - ACAD.FStampFields.Margins.Bottom - 30; //14.11.2011 - 5 - 30; aBnd.Left := ACAD.PCad.WorkWidth - ACAD.FStampFields.Margins.Right - 119; aBnd.Right := ACAD.PCad.WorkWidth - ACAD.FStampFields.Margins.Right - 50; aBnd.Top := ACAD.PCad.WorkHeight - ACAD.FStampFields.Margins.Bottom - 30; aBnd.Bottom := ACAD.PCad.WorkHeight - ACAD.FStampFields.Margins.Bottom - 15; //13.09.2010 //if GCadForm.FFrameProjectName = nil then //begin // if ACreateForLack then // begin // GCadForm.FFrameProjectName := CreateStampCaptionToField(aBnd, aProjectName); // GCadForm.FFrameProjectName.DataID := 100; // GCadForm.PCad.AddCustomFigure (GLN(LHandle), GCadForm.FFrameProjectName, False); // end; //end //else //begin // GCadForm.PCad.Figures.Remove(GCadForm.FFrameProjectName); // RefreshCad(GCadForm.PCad); // GCadForm.FFrameProjectName := CreateStampCaptionToField(aBnd, aProjectName); // GCadForm.FFrameProjectName.DataID := 100; // GCadForm.PCad.AddCustomFigure (GLN(LHandle), GCadForm.FFrameProjectName, False); //end; ACAD.FFrameProjectName := ReCreateStampCaptionToField(ACAD, ACAD.FFrameProjectName, 100, aBnd, aProjectName, ACreateForLack, AEnabledCaptions); // Заполняемые поля рамки ReCreateFillFields; end; // штамп в верхнем углу aBnd.Left := ACAD.FStampFields.Margins.Left; //14.11.2011 20; aBnd.Top := ACAD.FStampFields.Margins.Top; //14.11.2011 5; aBnd.Right := ACAD.FStampFields.Margins.Left + 70; //14.11.2011 20 + 70; aBnd.Bottom := ACAD.FStampFields.Margins.Top + 15; //14.11.2011 5 + 15; //13.09.2010 //if GCadForm.FFrameCodeName = nil then //begin // if ACreateForLack then // begin // GCadForm.FFrameCodeName := CreateStampCaptionToField(aBnd, aCodeName); // GCadForm.FFrameCodeName.DataID := 300; // GCadForm.PCad.AddCustomFigure (GLN(LHandle), GCadForm.FFrameCodeName, False); // GCadForm.FFrameCodeName.rotate(pi, GCadForm.FFrameCodeName.CenterPoint); // end; //end //else //begin // GCadForm.PCad.Figures.Remove(GCadForm.FFrameCodeName); // RefreshCad(GCadForm.PCad); // GCadForm.FFrameCodeName := CreateStampCaptionToField(aBnd, aCodeName); // GCadForm.FFrameCodeName.DataID := 300; // GCadForm.PCad.AddCustomFigure (GLN(LHandle), GCadForm.FFrameCodeName, False); // GCadForm.FFrameCodeName.rotate(pi, GCadForm.FFrameCodeName.CenterPoint); //end; //18.11.2011 ACAD.FFrameCodeName := ReCreateStampCaptionToField(ACAD, ACAD.FFrameCodeName, 300, aBnd, aCodeName, ACreateForLack, AEnabledCaptions); //Tolik 15/11/2016-- нужно учесть настройку листа (выводить наименование листа с номером или без) // ACAD.FFrameCodeName := ReCreateStampCaptionToField(ACAD, ACAD.FFrameCodeName, 300, aBnd, aCodeName+' '+aIndexName, ACreateForLack, AEnabledCaptions); if ListParams.IsIndexWithName = biTrue then ACAD.FFrameCodeName := ReCreateStampCaptionToField(ACAD, ACAD.FFrameCodeName, 300, aBnd, aCodeName+' '+aIndexName, ACreateForLack, AEnabledCaptions) else ACAD.FFrameCodeName := ReCreateStampCaptionToField(ACAD, ACAD.FFrameCodeName, 300, aBnd, aCodeName, ACreateForLack, AEnabledCaptions); if ACAD.FFrameCodeName <> nil then ACAD.FFrameCodeName.rotate(pi, ACAD.FFrameCodeName.CenterPoint); // // выставить визибл/инвизибл подписей {//17.11.2011 if ACAD.FFrameProjectName <> nil then ACAD.FFrameProjectName.Visible := ACAD.FShowMainStamp; if ACAD.FFrameListName <> nil then ACAD.FFrameListName.Visible := ACAD.FShowMainStamp; if ACAD.FFrameCodeName <> nil then ACAD.FFrameCodeName.Visible := ACAD.FShowUpperStamp; if ACAD.FFrameIndexName <> nil then ACAD.FFrameIndexName.Visible := ACAD.FShowMainStamp;} for i := 0 to ACad.FFrameObjects.Count - 1 do begin FrameFigure := TFigure(ACad.FFrameObjects.Objects[i]); FrameFigureCode := StrToint(ACad.FFrameObjects[i]); if (FrameFigure <> nil) then begin if (FrameFigureCode <> ftCodeName) then FrameFigure.Visible := GCadForm.FShowMainStamp else FrameFigure.Visible := ACAD.FShowUpperStamp; end; end; except on E: Exception do addExceptionToLogEx('U_Common.LoadCaptionsOnFrame', E.Message); end; ACAD.PCad.EnableAlign; end; function CreateStampCaptionToField(ACAD: TF_CAD; aFieldBnd: TDoubleRect; const aText: String; ATextHorzCenter: Boolean=true; ATextSize: Integer=14): TRichText; var i, k: integer; LHandle: Integer; TextField: TRichText; FieldCP: TDoublePoint; TM: TTextMetric; xCanvas: TMetafileCanvas; h, w: double; resh, resw: double; HalfField: double; HalfText: double; ModCount: Integer; TextSize: Integer; TextStyle: TFontStyles; delta: double; textx, texty: double; begin Result := nil; try // if aText = 'Лист 1' then // aText := 'iopfgipoed_doiepoefep_efpmep9fkepfiepf_efkepfie0fi0efn_f0efi[0e0fe_epfke0[pfie0f_fmpekfpefke_efjepfjpef_epfjepofjepojfe_ejfepofkopef_lefjepjfpeojfe_elfmepfkekfpeof_emfepfkjepfkoe_felmfepofkjpoefe,_flemfpemfpemnfpe_flefmepf_epof'; delta := 0; textx := abs(aFieldBnd.Right - aFieldBnd.Left); texty := abs(aFieldBnd.Bottom - aFieldBnd.Top); TextStyle := []; LHandle := ACAD.PCad.GetLayerHandle(2); FieldCP.x := (aFieldBnd.Left + aFieldBnd.Right) / 2; FieldCP.y := (aFieldBnd.Top + aFieldBnd.Bottom) / 2; w := 0; //#From Oleg# //14.09.2010 h := 0; //#From Oleg# //14.09.2010 TextSize := 1; //#From Oleg# //14.09.2010 k := ATextSize; //17.11.2011 14; while k >= 1 do begin TextSize := k; TextField := TRichText.create(-100, -100, -100, -100, 1, ord(psSolid), clBlack, ord(bsClear), clNone, LHandle, mydsNormal, ACAD.PCad); TextField.re.WordWrap := False; TextField.re.Font.Name := ACAD.FFontName; TextField.re.Font.Size := TextSize; TextField.re.Font.Style := TextStyle; TextField.re.Font.Color := clBlack; TextField.re.Lines.Clear; TextField.re.Lines.Add(FastReplace(aText,#13#10,' ')); // получить свойства TextField.ttMetaFile:= TMetaFile.Create; TextField.ttMetafile.Enhanced := True; xCanvas := TMetafileCanvas.Create(TextField.ttMetafile, 0); xCanvas.Font.Name := TextField.re.Font.Name; xCanvas.Font.Size := TextField.re.Font.Size; xCanvas.Font.Style := TextField.re.Font.Style; GetTextMetrics(xCanvas.Handle, TM); h := TM.tmHeight / 4; w := xCanvas.TextWidth(TextField.Re.Lines[0]); w := (w + 3) / 4; FreeAndNil(xCanvas); TextField.ttMetafile.Free; TextField.ttMetaFile := nil; if TextField <> nil then FreeAndNil(TextField); // текст вписывается в границы if (w * h) < (textx * texty - 50) then begin Break; end; k := k - 1; end; // контроль по ширине // не больше чем ширина вписуемого поля if textx > w then resw := w else resw := textx; // вычислить высоту исходя из переносов строк { //18.11.2011 if textx > w then h := h * (Round(w / textx) + 1) else h := h * (Round(w / textx) + 1) + 1;} if textx > w then h := h * RoundUp(w / textx) else h := h * RoundUp(w / textx) + 1; // контроль по высоте // небольше чем высота вписуемого поля if texty > h then resh := h else resh := texty; TextField := TRichText.create(-100, -100, -100 + resw, -100 + resh, 1, ord(psSolid), clBlack, ord(bsClear), clNone, LHandle, mydsNormal, ACAD.PCad); TextField.re.WordWrap := True; TextField.re.Font.Name := ACAD.FFontName; TextField.re.Font.Size := TextSize; TextField.re.Font.Style := TextStyle; TextField.re.Font.Color := clBlack; TextField.re.Lines.Clear; TextField.re.Lines.Add(FastReplace(aText,#13#10,' ')); if ATextHorzCenter then TextField.Move(FieldCP.x - TextField.CenterPoint.x, (FieldCP.y - TextField.CenterPoint.y) + delta) else TextField.Move(aFieldBnd.Left - TextField.ap1.x, (FieldCP.y - TextField.CenterPoint.y) + delta); Result := TextField; except on E: Exception do addExceptionToLogEx('U_Common.CreateStampCaptionToField', E.Message); end; end; function ReCreateStampCaptionToField(ACAD: TF_CAD; ACurrStampField: TRichText; ADataID: Integer; aFieldBnd: TDoubleRect; const aText: String; ACreateForLack: Boolean=true; AEnabledCaptions: TintList=nil; ATextHorzCenter: Boolean=true; ATextSize: Integer=14): TRichText; var //CAD: TF_CAD; LHandle: Integer; ObjIdx: Integer; begin result := nil; try if ACurrStampField <> nil then if ACurrStampField.ClassName <> 'TRichText' then ACurrStampField := nil; if ACurrStampField = nil then begin ObjIdx := ACAD.FFrameObjects.IndexOf(IntToStr(ADataID)); if ObjIdx <> -1 then ACurrStampField := TRichText(ACAD.FFrameObjects.Objects[ObjIdx]); end; if ACurrStampField <> nil then if ACurrStampField.ClassName <> 'TRichText' then ACurrStampField := nil; Result := ACurrStampField; if (AEnabledCaptions = nil) or (AEnabledCaptions.IndexOf(ADataID) <> -1) then begin if ACurrStampField = nil then begin if ACreateForLack then begin Result := CreateStampCaptionToField(ACAD, aFieldBnd, aText, ATextHorzCenter, ATextSize); //CAD := TF_CAD(Result.Owner.Owner); Result.DataID := ADataID; LHandle := ACAD.PCad.GetLayerHandle(7); ACAD.PCad.AddCustomFigure (GLN(LHandle), Result, False); end; end else begin //CAD := TF_CAD(ACurrStampField.Owner.Owner); if ACurrStampField.ClassName = 'TRichText' then begin ACAD.PCad.Figures.Remove(ACurrStampField); FreeAndNil(ACurrStampField); end else begin exit; end; RefreshCad(ACAD.PCad); Result := CreateStampCaptionToField(ACAD, aFieldBnd, aText, ATextHorzCenter, ATextSize); Result.DataID := ADataID; LHandle := ACAD.PCad.GetLayerHandle(7); ACAD.PCad.AddCustomFigure (GLN(LHandle), Result, False); end; if Result <> nil then begin ObjIdx := ACAD.FFrameObjects.IndexOf(IntToStr(ADataID)); if ObjIdx <> -1 then ACAD.FFrameObjects.Objects[ObjIdx] := Result; end; end; except end; end; function GetFileNameFromFullPath(aFullPath: string): string; var i, j: integer; strlen: integer; fName: string; begin try strlen := Length(aFullPath); for i := strlen - 1 downto 0 do begin if aFullPath[i] = '\' then break; end; j := 0; SetLength(fName, 0); SetLength(fName, strlen - i); while i <= strlen do begin fName[j] := aFullPath[i]; i := i + 1; j := j + 1; end; Result := fName; except on E: Exception do addExceptionToLogEx('U_Common.GetFileNameFromFullPath', E.Message); end; end; procedure GetConnObjectsByLine(AIDList, AIDLine: Integer; var AConnAtSide1: Integer; var AConnAtSide2: Integer); var FCAD: TF_CAD; FLine: TOrthoLine; JoinedConn1, JoinedConn2: TConnectorObject; begin try AConnAtSide1 := -1; AConnAtSide2 := -1; FCAD := GetListByID(AIDList); if FCAD <> nil then begin FLine := TOrthoLine(GetFigureByID(FCAD, AIDLine)); if FLine <> nil then begin JoinedConn1 := TConnectorObject(FLine.JoinConnector1); JoinedConn2 := TConnectorObject(FLine.JoinConnector2); if JoinedConn1.JoinedConnectorsList.Count > 0 then begin if TConnectorObject(JoinedConn1.JoinedConnectorsList[0]).ConnectorType <> ct_Clear then begin if TConnectorObject(JoinedConn1.JoinedConnectorsList[0]).FIsApproach then AConnAtSide1 := TConnectorObject(JoinedConn1.JoinedConnectorsList[0]).FHouse.ID else AConnAtSide1 := TConnectorObject(JoinedConn1.JoinedConnectorsList[0]).ID; end; end else begin if JoinedConn1.FIsHouseJoined then if JoinedConn1.FHouse <> nil then AConnAtSide1 := JoinedConn1.FHouse.ID; end; if JoinedConn2.JoinedConnectorsList.Count > 0 then begin if TConnectorObject(JoinedConn2.JoinedConnectorsList[0]).ConnectorType <> ct_Clear then begin if TConnectorObject(JoinedConn2.JoinedConnectorsList[0]).FIsApproach then AConnAtSide2 := TConnectorObject(JoinedConn2.JoinedConnectorsList[0]).FHouse.ID else AConnAtSide2 := TConnectorObject(JoinedConn2.JoinedConnectorsList[0]).ID; end; end else begin if JoinedConn2.FIsHouseJoined then if JoinedConn2.FHouse <> nil then AConnAtSide2 := JoinedConn2.FHouse.ID; end; end; end; except on E: Exception do addExceptionToLogEx('U_Common.GetConnObjectsByLine', E.Message); end; end; procedure RenameProjectOnFrame(AOldProjParams: TProjectParams); var i: integer; CurForm: TF_CAD; begin try for i := 0 to FSCS_Main.MDIChildCount - 1 do begin CurForm := TF_CAD(FSCS_Main.MDIChildren[i]); //if (TRichText(GCadForm.FFrameListName).re.Text = '') then // RenameListOnFrame(CurForm, ProjParams, GetListParams(CurForm.FCADListID)); RenameListOnFrame(CurForm, AOldProjParams, GetListParams(CurForm.FCADListID)); RefreshCAD(CurForm.PCad); end; except on E: Exception do addExceptionToLogEx('U_Common.RenameProjectOnFrame', E.Message); end; end; procedure RenameListOnFrame(ACadForm: TF_CAD; AOldProjParams: TProjectParams; AOldListParams: TListParams); var i: integer; Figure: TRichText; FigureCode: Integer; CmpText: String; FrameFig: TFrame; EnabledCaptions: TintList; function CheckRichTextCaption(AObject: TRichText; const ACaption: String): Boolean; var reText: String; i: Integer; begin //Result := (AObject <> nil) and (AObject.re <> nil) and (AObject.re.Lines.Count = 1) and (AObject.re.Lines[0] = ACaption); Result := (AObject <> nil) and (AObject.re <> nil); if Result then begin reText := ''; for i := 0 to AObject.re.Lines.Count - 1 do reText := reText + AObject.re.Lines[i]; Result := reText = ACaption; end; end; begin try //13.09.2010 //if ((GCadForm.FFrameProjectName = nil) or (GCadForm.FFrameProjectName.re.Text = '')) or // ((GCadForm.FFrameListName = nil) or (GCadForm.FFrameListName.re.Text = '')) then //begin // LoadCaptionsOnFrame(ACadForm.FCadStampType); // RefreshCAD(ACadForm.PCad); //end; EnabledCaptions := TintList.Create; {//17.11.2011 // номер листа if CheckRichTextCaption(ACadForm.FFrameIndexName, IntToStr(AOldListParams.MarkID)) then EnabledCaptions.Add(400); // штамп в верхнем углу if CheckRichTextCaption(ACadForm.FFrameCodeName, AOldListParams.Name) then EnabledCaptions.Add(300); // лист if CheckRichTextCaption(ACadForm.FFrameListName, AOldListParams.Name) then EnabledCaptions.Add(200); // проект if CheckRichTextCaption(ACadForm.FFrameProjectName, AOldProjParams.Caption) then EnabledCaptions.Add(100);} for i := 0 to ACadForm.FFrameObjects.Count - 1 do begin Figure := TRichText(ACadForm.FFrameObjects.Objects[i]); if Figure <> nil then begin FigureCode := StrToInt(ACadForm.FFrameObjects[i]); CmpText := ''; case FigureCode of ftProjectName: CmpText := AOldProjParams.Caption; ftOrgName: CmpText := AOldProjParams.Setting.OrganizationName; ftListName: begin if AOldListParams.Settings.CADStampListSign <> '' then CmpText := AOldListParams.Settings.CADStampListSign else CmpText := AOldListParams.Name; end; ftCodeName: // Tolik --15/11/2016 -- //CmpText := AOldListParams.Name +' '+ IntToStr(AOldListParams.MarkID); //18.11.2011 AOldListParams.Name; if AOldListParams.IsIndexWithName = biTrue then CmpText := AOldListParams.Name +' '+ IntToStr(AOldListParams.MarkID) else CmpText := AOldListParams.Name; // ftIndexName: CmpText := IntToStr(AOldListParams.MarkID); ftDeveloperName: CmpText := AOldListParams.Settings.CADStampDeveloper; ftCheckerName: CmpText := AOldListParams.Settings.CADStampChecker; ftMainEngineer: CmpText := AOldListParams.Settings.CADStampMainEngineer; ftApproved: CmpText := AOldListParams.Settings.CADStampApproved; ftDesignStage: CmpText := AOldListParams.Settings.CADStampDesignStage; end; if CheckRichTextCaption(Figure, CmpText) then EnabledCaptions.Add(FigureCode); end; end; if EnabledCaptions.Count > 0 then LoadCaptionsOnFrame(ACadForm, ACadForm.FCadStampType, false, EnabledCaptions); EnabledCaptions.Free; except on E: Exception do addExceptionToLogEx('U_Common.RenameListOnFrame', E.Message); end; end; function CheckByBreakConnector(aClearConn, aPointObject: TConnectorObject): Boolean; var CheckedX, CheckedY: Double; MinX, MinY, MaxX, MaxY: Double; i: integer; Step: Double; // Tolik -- 10/04/2017 -- dim: Double; // begin Result := False; // Tolik 10/04/2017 -- dim := 0.6; // try Step := GCadForm.PCad.GridStep; CheckedX := aClearConn.ActualPoints[1].x; CheckedY := aClearConn.ActualPoints[1].y; if (not APointObject.FDrawFigureMoved)and(APointObject.FDrawFigureAngle = 0) then if not HaveObjectSocketComponent(APointObject.ID) then begin // Tolik 10/04/2017 -*- -- если нет DrawFigure, чтобы не оторвало коннектор от фигуры { MinX := (aPointObject.ActualPoints[1].x - aPointObject.GrpSizeX / 2) - 0.1; MinY := (aPointObject.ActualPoints[1].y - aPointObject.GrpSizeY / 2) - 0.1; MaxX := (aPointObject.ActualPoints[1].x + aPointObject.GrpSizeX / 2) + 0.1; MaxY := (aPointObject.ActualPoints[1].y + aPointObject.GrpSizeY / 2) + 0.1;} MinX := (aPointObject.ActualPoints[1].x - aPointObject.GrpSizeX / 2) - dim; MinY := (aPointObject.ActualPoints[1].y - aPointObject.GrpSizeY / 2) - dim; MaxX := (aPointObject.ActualPoints[1].x + aPointObject.GrpSizeX / 2) + dim; MaxY := (aPointObject.ActualPoints[1].y + aPointObject.GrpSizeY / 2) + dim; // end else //Если конектор не по центру фигуры begin // Tolik 10/04/2017 -- -- если нет DrawFigure, чтобы не оторвало коннектор от фигуры { MinX := (aPointObject.ActualPoints[1].x) - 0.1; MinY := (aPointObject.ActualPoints[1].y - aPointObject.GrpSizeY / 2) - 0.1; MaxX := (aPointObject.ActualPoints[1].x + aPointObject.GrpSizeX) + 0.1; MaxY := (aPointObject.ActualPoints[1].y + aPointObject.GrpSizeY / 2) + 0.1;} MinX := (aPointObject.ActualPoints[1].x) - dim; MinY := (aPointObject.ActualPoints[1].y - aPointObject.GrpSizeY / 2) - dim; MaxX := (aPointObject.ActualPoints[1].x + aPointObject.GrpSizeX) + dim; MaxY := (aPointObject.ActualPoints[1].y + aPointObject.GrpSizeY / 2) + dim; // end else //А этот кусочек нужен если фигура сдвинута или повернута на угол begin // Tolik 10/04/2017 -- если нет DrawFigure, чтобы не оторвало коннектор от фигуры { MinX := aPointObject.DrawFigure.GetBoundRect.Left - 0.1; MinY := aPointObject.DrawFigure.GetBoundRect.Top - 0.1; MaxX := aPointObject.DrawFigure.GetBoundRect.Right + 0.1; MaxY := aPointObject.DrawFigure.GetBoundRect.Bottom + 0.1;} MinX := aPointObject.DrawFigure.GetBoundRect.Left - dim; MinY := aPointObject.DrawFigure.GetBoundRect.Top - dim; MaxX := aPointObject.DrawFigure.GetBoundRect.Right + dim; MaxY := aPointObject.DrawFigure.GetBoundRect.Bottom + dim; // end; if GCadForm.PCad.SnapToGrids then begin MinX := Trunc(MinX / Step) * Step; MinY := Trunc(MinY / Step) * Step; MaxX := Trunc(MaxX / Step) * Step + Step; MaxY := Trunc(MaxY / Step) * Step + Step; end; if (CheckedX < MinX) or (CheckedX > MaxX) or (CheckedY < MinY) or (CheckedY > MaxY) then Result := True; except on E: Exception do addExceptionToLogEx('CheckByBreakConnector', E.Message); end; end; function CheckByBreakConnectorByCoords(aConnPoints: TDoublePoint; aPointObject: TConnectorObject): Boolean; var CheckedX, CheckedY: Double; MinX, MinY, MaxX, MaxY: Double; i: integer; Step: Double; begin Result := False; try Step := GCadForm.PCad.GridStep; CheckedX := aConnPoints.x; CheckedY := aConnPoints.y; MinX := (aPointObject.ActualPoints[1].x - aPointObject.GrpSizeX / 2) - 0.1; MinY := (aPointObject.ActualPoints[1].y - aPointObject.GrpSizeY / 2) - 0.1; MaxX := (aPointObject.ActualPoints[1].x + aPointObject.GrpSizeX / 2) + 0.1; MaxY := (aPointObject.ActualPoints[1].y + aPointObject.GrpSizeY / 2) + 0.1; if GCadForm.PCad.SnapToGrids then begin MinX := Trunc(MinX / Step) * Step; MinY := Trunc(MinY / Step) * Step; MaxX := Trunc(MaxX / Step) * Step + Step; MaxY := Trunc(MaxY / Step) * Step + Step; end; if (CheckedX < MinX) or (CheckedX > MaxX) or (CheckedY < MinY) or (CheckedY > MaxY) then Result := True; except on E: Exception do addExceptionToLogEx('CheckByBreakConnectorByCoords', E.Message); end; end; procedure RefreshCAD_T(aPCAD: TPowerCad; AExecPrev: Boolean=false); begin if AExecPrev and Assigned(GRefreshCad) and FSCS_Main.TimerRefresh.Enabled and Assigned(FSCS_Main.TimerRefresh.OnTimer) then FSCS_Main.TimerRefresh.OnTimer(FSCS_Main.TimerRefresh); GRefreshCad := aPCAD; FSCS_Main.TimerRefresh.Enabled := True; end; procedure RefreshCADs(aCADs: TList); var i: Integer; begin for i := 0 to aCADs.Count - 1 do RefreshCAD(TF_CAD(aCADs[i]).PCad); end; procedure RefreshCAD(aPCAD: TPowerCad); begin try if aPCAD <> nil then aPCAD.Refresh; except on E: Exception do addExceptionToLogEx(cCommon_Mes13, E.Message); end; end; procedure ProcessMessagesEx; function IsKeyMsg(var Msg: TMsg): Boolean; const CN_BASE = $BC00; var Wnd: HWND; begin Result := False; with Msg do if (Message >= WM_KEYFIRST) and (Message <= WM_KEYLAST) then begin Wnd := GetCapture; if Wnd = 0 then begin Wnd := HWnd; if SendMessage(Wnd, CN_BASE + Message, WParam, LParam) <> 0 then Result := True; end else if (LongWord(GetWindowLong(Wnd, GWL_HINSTANCE)) = HInstance) then if SendMessage(Wnd, CN_BASE + Message, WParam, LParam) <> 0 then Result := True; end; end; // 03/11/2016-- Tolik -- оригинал - ниже закомменчен, а эта - для опытов ... // пока все ненужное закомменчено, на случай, если сюда нужно будет еще вернуться function ProcessMessage(var Msg: TMsg): Boolean; var // f : TextFile; aName: array [0..255] of Char; rName: array [0..255] of Char; s: String; i: Integer; ParentHandle: THandle; begin { AssignFile(f, 'd:\PeekMsg.txt'); Append(f); } Result := False; //if PeekMessage(Msg, 0, 0, 0, PM_REMOVE) then if PeekMessage(Msg, 0, WM_KEYFIRST, WM_KEYLAST, PM_REMOVE) then //if PeekMessage(Msg, 0, 0, 0, PM_REMOVE) then begin Result := True; if GIsProgress then begin if (F_NormBase.Tree_Catalog.Handle = Msg.hwnd) or((GCadForm <> nil) and (GCadForm.MProtocol.handle = Msg.hwnd)) then Result := False; end; (*if Result then begin s := ''; for i := 0 to 50 do begin aName[i] := ' '; end; GetClassName(Msg.hWnd, aName, 255); // получить имя класса for i := 0 to 50 do s := s + aName[i]; //if s = 'MSCTFIME UI' then if Pos('MSCTFIME UI', s) > 0 then Result := False; end; *) for i := 0 to 50 do begin rName[i] := ' '; aName[i] := ' '; end; //GetWindowText(Msg.hWnd,rName,255); // получить название s := ''; {for i := 0 to 50 do s := s + rName[i]; s := s + ' --- Class Name: '; for i := 0 to 50 do s := s + aName[i];} //Writeln(f, Inttostr(Msg.hwnd)+ ' --- ' + s); (* ParentHandle := GetParent(Msg.Hwnd); if ParentHandle <> 0 then begin {s := 'Parent Window: '; for i := 0 to 50 do rName[i] := ' '; } GetWindowText(ParentHandle,rName,255); for i := 0 to 50 do s := s + rName[i]; if Pos('Default IME', s) > 0 then Result := False; //Writeln(f, s); end; *) if ((Msg.message >= WM_MOUSEFIRST) and (Msg.message <= WM_MOUSELAST)) or (Msg.message = WM_PAINT) or // ((Msg.message > WM_KEYFIRST) and (Msg.message > WM_KEYLAST)) then ((Msg.message >= WM_KEYFIRST) and (Msg.message <= WM_KEYLAST)) then begin // // Application.BringToFront; // SendMessage(Application.MainForm.Handle, WM_SETREDRAW, 1, 0); //RedrawWindow(Application.MainForm.Handle, nil, 0, RDW_INVALIDATE or RDW_UPDATENOW or RDW_ALLCHILDREN); // TranslateMessage(Msg); DispatchMessage(Msg); end; end; //Close(f); end; { function ProcessMessage(var Msg: TMsg): Boolean; begin Result := False; if PeekMessage(Msg, 0, 0, 0, PM_REMOVE) then begin Result := True; if ((Msg.message > WM_MOUSEFIRST) and (Msg.message > WM_MOUSELAST)) or (Msg.message = WM_PAINT) then begin TranslateMessage(Msg); DispatchMessage(Msg); end; end; end; } {function ProcessMessage(var Msg: TMsg): Boolean; var HandledMsg: Boolean; begin Result := False; if PeekMessage(Msg, 0, 0, 0, PM_REMOVE) then begin Result := True; HandledMsg := False; if Assigned(Application.OnMessage) then Application.OnMessage(Msg, HandledMsg); if Not HandledMsg then if ((Msg.message >= WM_MOUSEFIRST) and (Msg.message <= WM_MOUSELAST)) or (Msg.message = WM_PAINT) or (Msg.message <= WM_TIMER) then begin TranslateMessage(Msg); DispatchMessage(Msg); end; end; end;} var Msg: TMsg; begin while ProcessMessage(Msg) do {loop}; // Application.ProcessMessages; end; procedure ReDrawCurrShadowOnCAD; begin try // Tolik -- 18/04/2016 -- if not GExitProg then // begin if (GCadForm <> nil) and (GCadForm.PCad <> nil) and (FSCS_Main.MDIChildCount > 0) then begin if ((GCadForm.PCad.ToolIdx = toFigure) and (GCadForm.PCad.ToolInfo = 'TOrthoLine')) and (GClickIndex > 0) then begin GCadForm.PCad.Refresh; GCadForm.PCad.Repaint; end; end; end; except on E: Exception do addExceptionToLogEx('U_Common.aReDrawCurrCAD', E.Message); end; end; procedure UnSelectFiguresOnSelectedChange(aSelectedList: TList); var i: integer; CurrFigure: TFigure; CurrConn: TConnectorObject; CurrLine: TOrthoLine; ObjFromRaise: TConnectorObject; begin try // 1. убрать выделение с присоединенных соединителей линий // 2. убирать выделение с с-п если выделена РТ на которой с-п for i := 0 to aSelectedList.Count - 1 do begin CurrFigure := TFigure(aSelectedList[i]); if CheckFigureByClassName(CurrFigure, cTConnectorObject) then begin CurrConn := TConnectorObject(CurrFigure); // вершина с-п if CurrConn.FConnRaiseType <> crt_None then begin // только если вершина с-п - пустой соединитель if CurrConn.ConnectorType = ct_Clear then begin ObjFromRaise := CurrConn.FObjectFromRaise; if ObjFromRaise <> nil then if not CheckNoFigureInList(ObjFromRaise, aSelectedList) then CurrConn.Deselect; end; end; end; if CheckFigureByClassName(CurrFigure, cTOrthoLine) then begin CurrLine := TOrthoLine(CurrFigure); // присоединенные коннекторы линии // if not CheckNoFigureInList(CurrLine.JoinConnector1, aSelectedList) then // CurrLine.JoinConnector1.Deselect; // if not CheckNoFigureInList(CurrLine.JoinConnector2, aSelectedList) then // CurrLine.JoinConnector2.Deselect; if CurrLine.FIsRaiseUpDown then begin ObjFromRaise := CurrLine.FObjectFromRaisedLine; if ObjFromRaise <> nil then if not CheckNoFigureInList(ObjFromRaise, aSelectedList) then CurrLine.Deselect; end; end; end; except on E: Exception do addExceptionToLogEx('UnSelectFiguresOnSelectedChange', E.Message); end; end; procedure ReCalcAllLinesLength; var i: integer; CurrLine: TOrthoLine; begin try if (GCadForm <> nil) and (GCadForm.PCad <> nil) then begin // Tolik -- 16/09/2016-- так быстрее -- {for i := 0 to GCadForm.PCad.FigureCount - 1 do begin if CheckFigureByClassName(TFigure(GCadForm.PCad.Figures[i]), cTOrthoLine) then begin CurrLine := TOrthoLine(GCadForm.PCad.Figures[i]);} for i := 0 to GCadForm.FSCSFigures.Count - 1 do begin if CheckFigureByClassName(TFigure(GCadForm.FSCSFigures[i]), cTOrthoLine) then begin CurrLine := TOrthoLine(GCadForm.FSCSFigures[i]); // if not CurrLine.FIsRaiseUpDown then begin CurrLine.CalculLength := CurrLine.LengthCalc; CurrLine.LineLength := CurrLine.CalculLength; CurrLine.UpdateLengthTextBox(false, true); SetLineFigureLengthInPM(CurrLine.ID, CurrLine.LineLength); end; end; end; end; except on E: Exception do addExceptionToLogEx('ReCalcAllLinesLength', E.Message); end; end; procedure RaiseActiveNet(aCad: TF_CAD); var i: integer; NetObject: TNet; NetExistObject: TNet; begin try //NetExistObject := nil; // for i := 0 to aCad.PCad.FigureCount - 1 do // begin // if CheckFigureByClassName(TFigure(aCad.PCad.Figures[i]), 'TNet') then // NetExistObject := TNet(aCad.PCad.Figures[i]); // end; // // Net // if NetExistObject <> nil then // begin // aCad.FActiveNet := NetExistObject; // ActiveNet := aCad.FActiveNet; // aCad.FActiveNet.MapScale := aCad.PCad.MapScale; // ActiveNet.MapScale := aCad.PCad.Mapscale; // if aCad.PCad.RulerMode = rmWorld then // aCad.FActiveNet.WorldDim := True // else // aCad.FActiveNet.WorldDim := False; // ActiveNet.WorldDim := aCad.FActiveNet.WorldDim; // end // else // begin // if not CheckFigureByClassName(aCad.FActiveNet, 'TNet') then // begin // aCad.FActiveNet := Tnet.create(8, mydsNormal, aCad.PCad); // end; // aCad.PCad.AddCustomFigure(8, aCad.FActiveNet, False); // ActiveNet := aCad.FActiveNet; // end; NetExistObject := nil; for i := 0 to aCad.PCad.FigureCount - 1 do begin if CheckFigureByClassName(TFigure(aCad.PCad.Figures[i]), 'TNet') then begin NetObject := TNet(aCad.PCad.Figures[i]); SetCADParamsToNet(aCad, NetObject); // Если просто арх. план if NetObject.FComponID = 0 then begin NetExistObject := NetObject; aCad.FActiveNet := NetExistObject; ActiveNet := aCad.FActiveNet; end; end; end; if NetExistObject = nil then begin if not CheckFigureByClassName(aCad.FActiveNet, 'TNet') then begin aCad.FActiveNet := Tnet.create(8, mydsNormal, aCad.PCad); end; aCad.PCad.AddCustomFigure(8, aCad.FActiveNet, False); ActiveNet := aCad.FActiveNet; end; // Tolik 14/11/2017 -- Если тут не выставить, а фигура переподнялась после удаления, то больше удаление TNetа на Каде не сработает !!! if GCadForm.FActiveNet <> nil then GCadForm.FActiveNet.FDeleting := False; // except on E: Exception do addExceptionToLogEx('U_Common.RaiseActiveNet', E.Message); end; end; procedure SetCADParamsToNet(aCad: TF_CAD; ANetObj: TObject); var Net: TNet; begin if (aCad <> nil) and (ANetObj <> nil) then begin Net := TNet(ANetObj); Net.MapScale := aCad.PCad.MapScale; if aCad.PCad.RulerMode = rmWorld then Net.WorldDim := True else Net.WorldDim := False; end; end; procedure SetMapScaleToNets(aCad: TF_CAD); var i: integer; NetObject: TNet; begin try for i := 0 to aCad.PCad.FigureCount - 1 do begin if CheckFigureByClassName(TFigure(aCad.PCad.Figures[i]), 'TNet') then begin NetObject := TNet(aCad.PCad.Figures[i]); NetObject.SetMapScale(aCad.PCad.MapScale); //NetObject.MapScale := aCad.PCad.MapScale; end; end; except on E: Exception do AddExceptionToLogEx('SetMapScaleToNets', E.Message); end; end; procedure SetAllInFiguresVisible(AGroup: TFigureGrp; AVisible: Boolean); var i, j: integer; InFigure: TFigure; begin try for i := 0 to AGroup.InFigures.Count - 1 do begin AGroup.Visible := AVisible; InFigure := TFigureGrp(AGroup.InFigures[i]); if (InFigure is TFigureGrp) then begin SetAllInFiguresVisible(TFigureGrp(InFigure), AVisible); end else begin InFigure.Visible := AVisible; end; end; except on E: Exception do addExceptionToLogEx('U_Common.SetAllInFiguresVisible', E.Message); end; end; procedure SetAllStampFiguresLayer(AGroup: TFigureGrp; ALHandle: Integer); var i, j: integer; InFigure: TFigure; begin try for i := 0 to AGroup.InFigures.Count - 1 do begin AGroup.LayerHandle := ALHandle; InFigure := TFigureGrp(AGroup.InFigures[i]); if (InFigure is TFigureGrp) then begin SetAllStampFiguresLayer(TFigureGrp(InFigure), ALHandle); end else begin InFigure.LayerHandle := ALHandle; end; end; except on E: Exception do addExceptionToLogEx('U_Common.GetAllFiguresFromStamp', E.Message); end; end; procedure SetAllStampTextsFont(AGroup: TFigureGrp; aFontName: string); var i, j: integer; InFigure: TFigure; begin try for i := 0 to AGroup.InFigures.Count - 1 do begin InFigure := TFigureGrp(AGroup.InFigures[i]); if (InFigure is TFigureGrp) then begin SetAllStampTextsFont(TFigureGrp(InFigure), aFontName); end else if CheckFigureByClassName(InFigure, 'TText') then begin if TText(InFigure).Font.Name <> aFontName then TText(InFigure).Font.Name := aFontName; end else if CheckFigureByClassName(InFigure, 'TRichText') then begin if TRichText(InFigure).re.Font.Name <> aFontName then TRichText(InFigure).re.Font.Name := aFontName; end; end; except on E: Exception do addExceptionToLogEx('U_Common.SetAllStampTextsFont', E.Message); end; end; // Tolik -- 15/04/2016 -- // Переписана, чтобы свойства шрифта для текстовых объектов подложки применялось только в том // случае, если во время применения параметров листа стоим на подложке { procedure UpdateForTexts(aFontName: string); var i: integer; FFigure: TFigure; Stamp: TFigureGrp; LHandle: Integer; begin try LHandle := GCadForm.PCad.GetLayerHandle(7); // SetAllStampTextsFont(TFigureGrp(GCadForm.FFrame), aFontName); for i := 0 to GCadForm.PCad.FigureCount - 1 do begin FFigure := TFigure(GCadForm.PCad.Figures[i]); if FFigure is TFigureGrp then SetAllStampTextsFont(TFigureGrp(FFigure), aFontName); if CheckFigureByClassName(FFigure, 'TText') then begin if TText(FFigure).Font.Name <> aFontName then TText(FFigure).Font.Name := aFontName; end; if CheckFigureByClassName(FFigure, 'TRichText') then begin if TRichText(FFigure).re.Font.Name <> aFontName then TRichText(FFigure).re.Font.Name := aFontName; end; end; except on E: Exception do addExceptionToLogEx('U_Common.UpdateForTexts', E.Message); end; end; } procedure UpdateForTexts(aFontName: string); var i: integer; FFigure: TFigure; Stamp: TFigureGrp; LHandle: Integer; begin try LHandle := GCadForm.PCad.GetLayerHandle(7); // SetAllStampTextsFont(TFigureGrp(GCadForm.FFrame), aFontName); if GCadForm.PCad.ActiveLayer = 1 then begin for i := 0 to GCadForm.PCad.FigureCount - 1 do begin FFigure := TFigure(GCadForm.PCad.Figures[i]); if FFigure is TFigureGrp then SetAllStampTextsFont(TFigureGrp(FFigure), aFontName); if CheckFigureByClassName(FFigure, 'TText') then begin if TText(FFigure).Font.Name <> aFontName then TText(FFigure).Font.Name := aFontName; end; if CheckFigureByClassName(FFigure, 'TRichText') then begin if TRichText(FFigure).re.Font.Name <> aFontName then TRichText(FFigure).re.Font.Name := aFontName; end; end; end else begin LHandle := GCadForm.PCad.GetLayerHandle(1); for i := 0 to GCadForm.PCad.FigureCount - 1 do begin FFigure := TFigure(GCadForm.PCad.Figures[i]); if FFigure.LayerHandle <> LHandle then begin if FFigure is TFigureGrp then SetAllStampTextsFont(TFigureGrp(FFigure), aFontName); if CheckFigureByClassName(FFigure, 'TText') then begin if TText(FFigure).Font.Name <> aFontName then TText(FFigure).Font.Name := aFontName; end; if CheckFigureByClassName(FFigure, 'TRichText') then begin if TRichText(FFigure).re.Font.Name <> aFontName then TRichText(FFigure).re.Font.Name := aFontName; end; end; end; end; except on E: Exception do addExceptionToLogEx('U_Common.UpdateForTexts', E.Message); end; end; // procedure ChangeObjectID(aListID, aOldID, aNewID: Integer); var FList: TF_CAD; FFigure: TFigure; begin try if aOldID <> aNewID then begin FList := GetListByID(aListID); if FList <> nil then begin FFigure := GetFigureByID(FList, aOldID); if FFigure <> nil then if CheckFigureByClassName(FFigure, cTConnectorObject) or CheckFigureByClassName(FFigure, cTOrthoLine) then FFigure.ID := aNewID; end; end; except on E: Exception do addExceptionToLogEx('U_Common.ChangeObjectID', E.Message); end; end; procedure ChangeCabinetID(aListID, aOldID, aNewID: Integer); var FList: TF_CAD; Cabinet: TFigure; begin try if aOldID <> aNewID then begin FList := GetListByID(aListID); if FList <> nil then begin Cabinet := FindCabinetBySCSID(Flist, aOldID); if Cabinet <> nil then begin if CheckFigureByClassname(Cabinet, cTCabinet) then begin TCabinet(Cabinet).FSCSID := aNewID; TCabinet(Cabinet).ID := aNewID; TCabinet(Cabinet).FNumberObject.FCabinetID := TCabinet(Cabinet).FSCSID; end else if CheckFigureByClassname(Cabinet, cTCabinetExt) then begin TCabinetExt(Cabinet).FSCSID := aNewID; TCabinetExt(Cabinet).ID := aNewID; TCabinetExt(Cabinet).FNumberObject.FCabinetID := TCabinetExt(Cabinet).FSCSID; end; end; end; end; except on E: Exception do addExceptionToLogEx('U_Common.ChangeCabinetID', E.Message); end; end; function GetBetweenFloorObjectsID(AID_List: Integer; aClearJoins: Boolean = False): TIntList; var i, j, k: integer; FList: TF_CAD; FFigure: TFigure; InFigure: TFigure; FConn: TConnectorObject; FLine: TOrthoLine; begin Result := TIntList.Create; try FList := GetListByID(AID_List); if FList <> nil then begin for i := 0 to FList.PCad.FigureCount - 1 do begin FFigure := TFigure(FList.PCad.Figures[i]); if FFigure <> nil then begin // НАйдена группа - искать в ней if CheckFigureByClassName(FFigure, cTSCSFigureGrp) then begin for k := 0 to TSCSFigureGrp(FFigure).InFigures.Count - 1 do begin InFigure := TFigure(TSCSFigureGrp(FFigure).InFigures[k]); if CheckFigureByClassName(InFigure, cTConnectorObject) then begin FConn := TConnectorObject(InFigure); if (FConn.FConnRaiseType = crt_BetweenFloorUp) or (FConn.FConnRaiseType = crt_BetweenFloorDown) or (FConn.FConnRaiseType = crt_TrunkUp) or (FConn.FConnRaiseType = crt_TrunkDown) then begin for j := 0 to FConn.JoinedOrtholinesList.Count - 1 do begin FLine := TOrthoLine(FConn.JoinedOrtholinesList[j]); if FLine.FIsRaiseUpDown then Result.Add(FLine.ID); end; // очистить связи с другими этажами // при копировании листов if aClearJoins then begin FConn.FID_ListToPassage := -1; FConn.FID_ConnToPassage := -1; end; end; end; end; end else // искать на самом КАДе begin if CheckFigureByClassName(FFigure, cTConnectorObject) then begin FConn := TConnectorObject(FFigure); if (FConn.FConnRaiseType = crt_BetweenFloorUp) or (FConn.FConnRaiseType = crt_BetweenFloorDown) or (FConn.FConnRaiseType = crt_TrunkUp) or (FConn.FConnRaiseType = crt_TrunkDown) then begin for j := 0 to FConn.JoinedOrtholinesList.Count - 1 do begin FLine := TOrthoLine(FConn.JoinedOrtholinesList[j]); if FLine.FIsRaiseUpDown then Result.Add(FLine.ID); end; // очистить связи с другими этажами // при копировании листов if aClearJoins then begin FConn.FID_ListToPassage := -1; FConn.FID_ConnToPassage := -1; end; end; end; end; end; end; end; except on E: Exception do addExceptionToLogEx('U_Common.GetBetweenFloorObjectsID', E.Message); end; end; procedure RemoveInFigureGrp(aFigureGrp: TFigureGrp); var i: integer; InFigure: TFigureGrp; FFigure: TFigure; begin try i := 0; while i < aFigureGrp.InFigures.Count do begin if CheckFigureByClassName(TFigure(aFigureGrp.InFigures[i]), 'TFigureGrp') or CheckFigureByClassName(TFigure(aFigureGrp.InFigures[i]), 'TFigureGrpMod') or CheckFigureByClassName(TFigure(aFigureGrp.InFigures[i]), 'TFigureGrpNotMod') then begin InFigure := TFigureGrp(aFigureGrp.InFigures[i]); if Assigned(InFigure.FBeforeDelFromParent) then //22.09.2011 InFigure.FBeforeDelFromParent(InFigure); RemoveInFigureGrp(InFigure); aFigureGrp.RemoveFromGrp(InFigure); //28.04.2011 aFigureGrp.InFigures.Remove(InFigure); try FreeAndNil(InFigure); except end; end else begin FFigure := TFigure(aFigureGrp.InFigures[i]); if Assigned(FFigure.FBeforeDelFromParent) then //22.09.2011 FFigure.FBeforeDelFromParent(FFigure); aFigureGrp.RemoveFromGrp(FFigure); //28.04.2011 aFigureGrp.InFigures.Remove(FFigure); try FreeAndNil(FFigure); except end; end; end; except on E: Exception do addExceptionToLogEx('U_Common.RemoveInFigureGrp', E.Message); end; end; procedure ClearFiguresOnListDelete(aCAD: TF_CAD); 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 AddToDelList(aFigure: TFigure); var i: Integer; inFigure: tFigure; begin if not (aFigure is TFigureGrp) then begin if aFigure.deleted and (NotSCSDelFigList.IndexOf(aFigure) = -1) then NotSCSDelFigList.Add(aFigure); end else begin if TFigureGrp(aFigure).UnGrouped then begin TFigureGrp(aFigure).InFigures.Clear; if NotSCSDelFigList.IndexOf(aFigure) = -1 then NotSCSDelFigList.Add(aFigure); end else if TFigureGrp(aFigure).Deleted then begin if NotSCSDelFigList.IndexOf(aFigure) = -1 then NotSCSDelFigList.Add(aFigure); end; end end; } procedure DeleteGRPFigures(aFigureGrp: TFigureGrp; aCad: TF_Cad); 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); {if figuresTodelList.IndexOf(FFigure) = -1 then figuresTodelList.Add(FFigure);} try if FFigure is TFigureGrp then DeleteGrpFigures(TFigureGrp(FFigure), aCad) else if CheckFigureByClassName(FFigure, 'TBlock') then DeleteGrpFigures(TBlock(FFigure), aCad); except on E: Exception do addExceptionToLogEx('U_Common.RemoveInFigureGrp', E.Message); end; end; aFigureGrp.InFigures.Clear; end; end; except on E: Exception do addExceptionToLogEx('U_Common.RemoveInFigureGrp', E.Message); end; end; begin // Tolik 17/05/2021 -- если пользователь удалил лист в процессе расстановки компонент, во избежание АВ сбросить шадоу объект if Assigned(GShadowObject) then begin GCadForm.PCad.Figures.Remove(GShadowObject); FreeAndNil(GShadowObject); end; // CadRefreshFlag := GCanRefreshCad; GCanRefreshCad := False; //figuresTodelList := Nil; //figuresTodelList := TList.Create; AddrList := THashedStringListMy.Create; AddrList.CaseSensitive := True; FigList := TList.Create; try GClearFigures := True; // чтобы было видно, что можно удалить коннектор из ПМ на дестрое! BeginProgress; // Tolik 23/03/*2017 -- aCAD.PCad.OnGUIEvent := Nil; // //GrpFigList := TList.Create; OldTick := GetTickCount; aCAD.PCad.DisableAlign; aCAD.PCad.BeginMultiDeselect; //02.04.2012 aCad.PCad.Locked := true; try // Tolik 02/12/2016 -- готовим на удаление и памяти тех фигур, которые не СКС и были удалены пользователем // и пока еще сидят в памяти (шлепаем их здесь) //NotSCSDelFigList := TList.Create; if aCad.FNotSCSDeletedFiguresList <> nil then begin for i := aCad.FNotSCSDeletedFiguresList.Count - 1 downto 0 do begin // строим список //if not TFigure(GCadForm.FNotSCSDeletedFiguresList[i]).Deleted then begin FFigure := TFigure(aCad.FNotSCSDeletedFiguresList[i]); if FFigure <> nil then begin if FFigure.deleted then begin aCAD.FNotSCSDeletedFiguresList.Remove(FFigure); FreeAndNil(FFigure); end else begin if (FFigure is TFigureGrp) and TFigureGrp(FFigure).Ungrouped then begin aCAD.FNotSCSDeletedFiguresList.Remove(FFigure); TFigureGrp(FFigure).InFigures.Clear; FreeAndNil(FFigure); end; end; end; end; end; // Удаляем список удаленных групповых фигур (не SCS) FreeAndNil(aCAD.FNotSCSDeletedFiguresList); // end; for i := 0 to aCad.PCad.FigureCount - 1 do begin FFigure := TFigure(aCad.PCad.Figures[i]); FigList.Add(FFigure); end; for i := 0 to FigList.Count - 1 do begin FFigure := TFigure(FigList[i]); if FFigure <> nil then begin try // проверить, если межэтажный то удалить на другом этаже // ЕСЛИ ЛИСТ УДАЛЯЕТСЯ САМ (не закрытие проекта) if aCad.FNeedDelete then begin if CheckFigureByClassName(FFigure, cTConnectorObject) then if (TConnectorObject(FFigure).FConnRaiseType = crt_BetweenFloorUp) or (TConnectorObject(FFigure).FConnRaiseType = crt_BetweenFloorDown) or (TConnectorObject(FFigure).FConnRaiseType = crt_TrunkUp) or (TConnectorObject(FFigure).FConnRaiseType = crt_TrunkDown) then DeleteRaiseOtherFloor(TConnectorObject(FFigure)); end; //try FigureString := IntToStr(Integer(Pointer(FFigure))); AddrList.Add(FigureString); {if figuresTodelList.IndexOf(FFigure) = -1 then figuresTodelList.Add(FFigure);} if FFigure is TFigureGrp then begin DeleteGRPFigures(TFigureGrp(FFigure), aCAD) end else if CheckFigureByClassName(FFigure, 'TBlock') then DeleteGrpFigures(TBlock(FFigure), aCad); 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; // это чтобы не попытался перерисовать то, чего нет (вдруг при закрытии листа куча компонент выбрана) aCad.PCad.Selection.Clear; // {GrpFigList.Clear; FreeAndNil(GrpFigList);} aCad.PCad.Figures.Clear; aCad.FSCSFigures.Clear; finally aCAD.PCad.EndMultiDeselect; aCAD.PCad.EnableAlign; end; CurrTick := GetTickCount - OldTick; CurrTick := GetTickCount - OldTick; 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; procedure ClearFiguresOnListUndoRedo; 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_Common.RemoveInFigureGrp', E.Message); end; end; aFigureGrp.InFigures.Clear; end; end; except on E: Exception do addExceptionToLogEx('U_Common.RemoveInFigureGrp', E.Message); end; end; begin if Assigned(GCadForm) then begin // Tolik 17/05/2021 -- если пользователь удалил лист в процессе расстановки компонент, во избежание АВ сбросить шадоу объект if Assigned(GShadowObject) then begin GCadForm.PCad.Figures.Remove(GShadowObject); FreeAndNil(GShadowObject); end; // CadRefreshFlag := GCanRefreshCad; GCanRefreshCad := False; AddrList := THashedStringListMy.Create; AddrList.CaseSensitive := True; FigList := TList.Create; try GClearFigures := True; // чтобы было видно, что можно удалить коннектор из ПМ на дестрое! BeginProgress; // Tolik 23/03/*2017 -- GCadForm.PCad.OnGUIEvent := Nil; GCadForm.PCad.DisableAlign; GCadForm.PCad.BeginMultiDeselect; //02.04.2012 GCadForm.PCad.Locked := true; try // Tolik 02/12/2016 -- готовим на удаление и памяти тех фигур, которые не СКС и были удалены пользователем // и пока еще сидят в памяти (шлепаем их здесь) if GCadForm.FNotSCSDeletedFiguresList <> nil then begin for i := GCadForm.FNotSCSDeletedFiguresList.Count - 1 downto 0 do begin // строим список begin FFigure := TFigure(GCadForm.FNotSCSDeletedFiguresList[i]); if FFigure <> nil then begin if FFigure.deleted then begin GCadForm.FNotSCSDeletedFiguresList.Remove(FFigure); FreeAndNil(FFigure); end else begin if (FFigure is TFigureGrp) and TFigureGrp(FFigure).Ungrouped then begin GCadForm.FNotSCSDeletedFiguresList.Remove(FFigure); TFigureGrp(FFigure).InFigures.Clear; FreeAndNil(FFigure); end; end; end; end; end; // Удаляем список удаленных групповых фигур (не SCS) FreeAndNil(GCadForm.FNotSCSDeletedFiguresList); // end; for i := 0 to GCadForm.PCad.FigureCount - 1 do begin FFigure := TFigure(GCadForm.PCad.Figures[i]); FigList.Add(FFigure); end; for i := 0 to FigList.Count - 1 do begin FFigure := TFigure(FigList[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; DeleteObjectFromPM(FFigure.ID, FFigure.Name); end else if CheckFigurebyClassName(FFigure, cTConnectorObject) then begin TConnectorObject(FFigure).JoinedOrtholinesList.Clear; TConnectorObject(FFigure).JoinedConnectorsList.Clear; TConnectorObject(FFigure).RemJoined.Clear; TConnectorObject(FFigure).JoinedFigures.Clear; DeleteObjectFromPM(FFigure.ID, FFigure.Name); end else if CheckFigurebyClassName(FFigure, cTCabinet) then DeleteObjectFromPM(FFigure.ID, FFigure.Name) else if CheckFigurebyClassName(FFigure, cTCabinetExt) then DeleteObjectFromPM(FFigure.ID, FFigure.Name); FreeAndNil(FFigure); end; except on E: Exception do begin addExceptionToLogEx('U_Common.ClearFiguresonListDelete', E.Message); end; end; end; end; // это чтобы не попытался перерисовать то, чего нет (вдруг при закрытии листа куча компонент выбрана) GCadForm.PCad.Selection.Clear; GCadForm.PCad.Figures.Clear; GCadForm.FSCSFigures.Clear; finally GCadForm.PCad.EndMultiDeselect; GCadForm.PCad.EnableAlign; end; CurrTick := GetTickCount - OldTick; CurrTick := GetTickCount - OldTick; GClearFigures := False; except on E: Exception do begin GClearFigures := False; // на всякий addExceptionToLogEx('U_Common.ClearFiguresonListDelete', E.Message); EndProgress; end; end; AddrList.Clear; FreeAndNil(AddrList); FreeAndNil(FigList); EndProgress; GClearFigures := False; GCanRefreshCad := CadRefreshFlag; end; end; (* // Tolik это содрано и переделано немножко совсем ... оригинал закомменчен - см.ниже, // так как в нем не уничтожались сами групповые фигуры procedure ClearFiguresOnListDelete(aCAD: TF_CAD); var i, j: integer; FFigure: TFigure; FigList, GrpFigList: TList; // Tolik 28/08/2019 -- //OldTick, CurrTick: Cardinal; OldTick, CurrTick: DWord; // FigureString: String; FigPos: Integer; AddrList: THashedStringListMy; DelFigList: TStringList; res: PPHashItem; // Tolik 07/12/2016-- NotSCSDelFigList: TList; f : TextFile; //figuresTodelList: TList; figuresTodelList: TMyList; s: string; CadRefreshFlag: Boolean; //sList: TStringList; procedure DeleteGRPFigures(aFigureGrp: TFigureGrp; aCad: TF_Cad); 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]); if figuresTodelList.IndexOf(FFigure) = -1 then figuresTodelList.Add(FFigure); try if FFigure is TFigureGrp then DeleteGrpFigures(TFigureGrp(FFigure), aCad) else if CheckFigureByClassName(FFigure, 'TBlock') then DeleteGrpFigures(TBlock(FFigure), aCad); except on E: Exception do addExceptionToLogEx('U_Common.RemoveInFigureGrp', E.Message); end; end; aFigureGrp.InFigures.Clear; end; end; except on E: Exception do addExceptionToLogEx('U_Common.RemoveInFigureGrp', E.Message); end; end; begin // Tolik 16/12/2019 -- aCAD.PCad.DeselectAll(2); // CadRefreshFlag := GCanRefreshCad; GCanRefreshCad := False; //figuresTodelList := Nil; //figuresTodelList := TList.Create; figuresTodelList := TMyList.Create; FigList := TList.Create; try BeginProgress; // Tolik 23/03/*2017 -- aCAD.PCad.OnGUIEvent := Nil; // //GrpFigList := TList.Create; OldTick := GetTickCount; aCAD.PCad.DisableAlign; aCAD.PCad.BeginMultiDeselect; //02.04.2012 aCad.PCad.Locked := true; try // Tolik 02/12/2016 -- готовим на удаление и памяти тех фигур, которые не СКС и были удалены пользователем // и пока еще сидят в памяти (шлепаем их здесь) //NotSCSDelFigList := TList.Create; if aCad.FNotSCSDeletedFiguresList <> nil then begin for i := aCad.FNotSCSDeletedFiguresList.Count - 1 downto 0 do begin // строим список //if not TFigure(GCadForm.FNotSCSDeletedFiguresList[i]).Deleted then begin FFigure := TFigure(aCad.FNotSCSDeletedFiguresList[i]); if FFigure <> nil then begin if FFigure.deleted then begin aCad.PCad.Figures.Remove(FFigure); aCAD.FNotSCSDeletedFiguresList.Remove(FFigure); FreeAndNil(FFigure); end else begin if (FFigure is TFigureGrp) and TFigureGrp(FFigure).Ungrouped then begin aCAD.FNotSCSDeletedFiguresList.Remove(FFigure); aCad.PCad.Figures.Remove(FFigure); TFigureGrp(FFigure).InFigures.Clear; FreeAndNil(FFigure); end; end; end; end; end; // Удаляем список удаленных групповых фигур (не SCS) FreeAndNil(aCAD.FNotSCSDeletedFiguresList); // end; for i := 0 to aCad.PCad.FigureCount - 1 do begin FFigure := TFigure(aCad.PCad.Figures[i]); FigList.Add(FFigure); end; for i := 0 to FigList.Count - 1 do begin FFigure := TFigure(FigList[i]); if FFigure <> nil then begin try // проверить, если межэтажный то удалить на другом этаже // ЕСЛИ ЛИСТ УДАЛЯЕТСЯ САМ (не закрытие проекта) if aCad.FNeedDelete then begin if CheckFigureByClassName(FFigure, cTConnectorObject) then if (TConnectorObject(FFigure).FConnRaiseType = crt_BetweenFloorUp) or (TConnectorObject(FFigure).FConnRaiseType = crt_BetweenFloorDown) or (TConnectorObject(FFigure).FConnRaiseType = crt_TrunkUp) or (TConnectorObject(FFigure).FConnRaiseType = crt_TrunkDown) then DeleteRaiseOtherFloor(TConnectorObject(FFigure)); end; if figuresTodelList.IndexOf(FFigure) = -1 then figuresTodelList.Add(FFigure); if FFigure is TFigureGrp then begin DeleteGRPFigures(TFigureGrp(FFigure), aCAD) end else if CheckFigureByClassName(FFigure, 'TBlock') then DeleteGrpFigures(TBlock(FFigure), aCad); except end; end; end; // это чтобы не попытался перерисовать то, чего нет (вдруг при закрытии листа куча компонент выбрана) aCad.PCad.Selection.Clear; // {GrpFigList.Clear; FreeAndNil(GrpFigList);} aCad.PCad.Figures.Clear; aCad.FSCSFigures.Clear; { AssignFile(f, 'C:\DelfigDups.txt'); rewrite(f); sList := TStringList.Create;} While figuresTodelList.Count > 0 do begin FFigure := TFigure(figuresTodelList[0]); if FFigure <> nil then begin { s := Format('$%x',[ Integer(Pointer(FFigure)) ]) + ' ' + inttostr(FFigure.Id) + ' ' + FFigure.CName; if sList.IndexOf(s) <> -1 then begin writeln(f,s); end; sList.Add(s); } try i := figuresTodelList.Remove(FFigure); while i >= 0 do begin if figuresTodelList.Count > 0 then i := figuresTodelList.Remove(FFigure) else i := -1; end; FFigure.Selected := False; // 19/11/2019 -- if FFigure.ClassName = 'TPlanTrace' then TPlanTrace(FFigure).Caption := nil; // Tolik 24/12/2019 -- FFigure.Free; except on E: Exception do addExceptionToLogEx('U_Common.ClearFiguresonListDelete' + FFigure.CName, E.Message); end; end else figuresTodelList.Pack; end; // closeFile(f); // sList.SaveToFile('c:\DelFigList_.txt'); // это чтобы не попытался перерисовать то, чего нет (вдруг при закрытии листа куча компонент выбрана) // aCad.PCad.Selection.Clear; // {GrpFigList.Clear; FreeAndNil(GrpFigList);} { aCad.PCad.Figures.Clear; aCad.FSCSFigures.Clear;} finally aCAD.PCad.EndMultiDeselect; aCAD.PCad.EnableAlign; end; CurrTick := GetTickCount - OldTick; CurrTick := GetTickCount - OldTick; except on E: Exception do begin 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; GCanRefreshCad := CadRefreshFlag; end; *) function CanListsInterchange(AIDMoveList, AID_List2: Integer; aMessRes: PInteger=nil; aMsg: Boolean=true): Boolean; var i, j: Integer; FList1, FList2: TF_CAD; FFiguresList1: TList; FFiguresList2: TList; OtherList: TF_CAD; Conn: TConnectorObject; Line: TOrthoLine; IsRaiseExist, IsRaiseExistOnMoveList: Boolean; mess: string; MessStyle: Integer; //04.04.2012 vLists: TList; SavedGCadForm: TF_CAD; DelObjs: Boolean; MessRes: Integer; begin Result := False; FFiguresList1 := TList.Create; FFiguresList2 := TList.Create; vLists := TList.create; try IsRaiseExist := False; IsRaiseExistOnMoveList := false; FList1 := GetListByID(AIDMoveList); FList2 := GetListByID(AID_List2); if (FList1 = nil) or (FList2 = nil) then begin // Tolik -- 18/05/2018 -- if FList1 <> nil then FList1.Free; if FList2 <> nil then FList2.Free; FFiguresList1.Free; FFiguresList2.Free; vLists.Free; // Exit; end; vLists.Add(FList1); vLists.Add(FList2); for i := 0 to FList1.PCad.FigureCount - 1 do begin if CheckFigureByClassName(TFigure(FList1.PCad.Figures[i]), cTConnectorObject) then if (TConnectorObject(FList1.PCad.Figures[i]).FConnRaiseType = crt_BetweenFloorUp) or (TConnectorObject(FList1.PCad.Figures[i]).FConnRaiseType = crt_BetweenFloorDown) or (TConnectorObject(FList1.PCad.Figures[i]).FConnRaiseType = crt_TrunkUp) or (TConnectorObject(FList1.PCad.Figures[i]).FConnRaiseType = crt_TrunkDown) then begin IsRaiseExist := True; IsRaiseExistOnMoveList := true; Conn := TConnectorObject(FList1.PCad.Figures[i]); FFiguresList1.Add(Conn); // связующие этажи кроме тех которые уже в списке OtherList := GetListByID(Conn.FID_ListToPassage); if OtherList <> nil then if CheckNoCadInList(OtherList, vLists) then vLists.Add(OtherList); end; end; for i := 0 to FList2.PCad.FigureCount - 1 do begin if CheckFigureByClassName(TFigure(FList2.PCad.Figures[i]), cTConnectorObject) then if (TConnectorObject(FList2.PCad.Figures[i]).FConnRaiseType = crt_BetweenFloorUp) or (TConnectorObject(FList2.PCad.Figures[i]).FConnRaiseType = crt_BetweenFloorDown) or (TConnectorObject(FList2.PCad.Figures[i]).FConnRaiseType = crt_TrunkUp) or (TConnectorObject(FList2.PCad.Figures[i]).FConnRaiseType = crt_TrunkDown) then begin IsRaiseExist := True; Conn := TConnectorObject(FList2.PCad.Figures[i]); FFiguresList2.Add(Conn); // связующие этажи кроме тех которые уже в списке OtherList := GetListByID(Conn.FID_ListToPassage); if OtherList <> nil then if CheckNoCadInList(OtherList, vLists) then vLists.Add(OtherList); end; end; if IsRaiseExist then begin //04.04.2012 mess := cCommon_Mes14; if aMsg then begin // Если есть на перемещаемом листе, то предлагаем разорвать связи //04.04.2012 if MessageBox(FSCS_Main.Handle, PAnsiChar(mess), cCommon_Mes15, MB_YESNO) then DelObjs := false; MessRes := -1; if aMessRes <> nil then MessRes := aMessRes^; if MessRes = -1 then begin if IsRaiseExistOnMoveList then begin mess := cCommon_Mes14; MessStyle := MB_YESNO; end else begin mess := cCommon_Mes14_2; MessStyle := MB_YESNOCANCEL; end; MessRes := MessageModal(mess, cCommon_Mes15, MessStyle); if aMessRes <> nil then aMessRes^ := MessRes; end; if MessRes = IDYes then DelObjs := true; if DelObjs then begin SaveForProjectUndo(vLists, True, False); BeginProgress; try SavedGCadForm := GCadForm; // удаление всех м-э с-п for i := 0 to FFiguresList1.Count - 1 do begin Conn := TConnectorObject(FFiguresList1[i]); GCadForm := FList1; Conn.Delete; end; for i := 0 to FFiguresList2.Count - 1 do begin Conn := TConnectorObject(FFiguresList2[i]); GCadForm := FList2; Conn.Delete; end; Result := True; RefreshCAD(FList1.PCad); RefreshCAD(FList2.PCad); GCadForm := SavedGCadForm; finally EndProgress; end; end else Result := False; end else Result := False; end else Result := True; except on E: Exception do addExceptionToLogEx('U_Common.CanListsInterchange', E.Message); end; FreeAndNil(FFiguresList1); FreeAndNil(FFiguresList2); FreeAndNil(vLists); end; function CheckListWithFloorRaise(aListID: Integer): Boolean; var List: TF_CAD; i: Integer; Fig: TFigure; begin Result := false; List := GetListByID(aListID); if List <> nil then // Tolik -- 14/03/2016 -- // for i := 0 to List.PCad.Figures.Count - 1 do for i := 0 to List.FSCSFigures.Count - 1 do // begin // Tolik -- 04/03/2016 - - // Fig := TFigure(List.PCad.Figures[i]); Fig := TFigure(List.FSCSFigures[i]); // if CheckFigureByClassName(TFigure(Fig), cTConnectorObject) then if (TConnectorObject(Fig).FConnRaiseType = crt_BetweenFloorUp) or (TConnectorObject(Fig).FConnRaiseType = crt_BetweenFloorDown) or (TConnectorObject(Fig).FConnRaiseType = crt_TrunkUp) or (TConnectorObject(Fig).FConnRaiseType = crt_TrunkDown) then begin Result := true; Break; //// BREAK //// end; end; end; function GetTraceInfo(AID_List: Integer): TList; var FList: TF_CAD; i: integer; CurrTrace: TOrthoLine; ptrTraceInfo: PTraceInfo; begin Result := TList.Create; try FList := GetListByID(AID_List); if FList <> nil then begin // Tolik -- 28/06/2016 -- // for i := 0 to FList.PCad.FigureCount - 1 do for i := 0 to FList.FSCSFigures.Count - 1 do // begin if CheckFigureByClassName(TFigure(FList.FSCSFigures[i]), cTOrthoLine) then begin CurrTrace := TOrthoLine(FList.FSCSFigures[i]); New(ptrTraceInfo); ptrTraceInfo.FigureID := CurrTrace.ID; ptrTraceInfo.HeightSide1 := CurrTrace.ActualZOrder[1]; ptrTraceInfo.HeightSide2 := CurrTrace.ActualZOrder[2]; ptrTraceInfo.IsSelected := CurrTrace.Selected; if (CurrTrace.FIsRaiseUpDown) or (CurrTrace.FIsVertical) then begin ptrTraceInfo.Position := tpVertical; end else begin if CurrTrace.ActualZOrder[1] = CurrTrace.ActualZOrder[2] then ptrTraceInfo.Position := tpHorizontal else ptrTraceInfo.Position := tpIncline; end; Result.Add(ptrTraceInfo); end; end; end; except on E: Exception do addExceptionToLogEx('U_Common.GetTraceInfo', E.Message); end; end; function IsStringListsDifferent(aStringList: TStringList; aStrings: TStrings): Boolean; var i, j: integer; begin Result := False; try if (aStringList = nil) or (aStrings = nil) then begin Result := True; Exit; end; if aStringList.Count <> aStrings.Count then begin Result := True; end else begin for i := 0 to aStringList.Count - 1 do begin if aStringList[i] <> aStrings[i] then Result := True; end; end; except on E: Exception do addExceptionToLogEx('TF_SCSObjectsProp.IsCompareStringLists', E.Message); end; end; procedure FindObjectsForConvertClasses; var i, j: integer; FLine: TOrthoLine; FConn: TConnectorObject; NotesCaptions: TRichTextMod; Captions: TRichTextMod; LinesList, ConnsList: TList; Str: string; Background: TRectangle; SCSFigureGrp: TSCSFigureGrp; begin LinesList := TList.Create; ConnsList := TList.Create; try for i := 0 to GCadForm.PCad.FigureCount - 1 do begin if CheckFigureByClassName(TFigure(GCadForm.PCad.Figures[i]), cTOrthoLine) then begin LinesList.Add(TFigure(GCadForm.PCad.Figures[i])); end; if CheckFigureByClassName(TFigure(GCadForm.PCad.Figures[i]), cTConnectorObject) then begin ConnsList.Add(TFigure(GCadForm.PCad.Figures[i])); end; // В ГРУППЕ if CheckFigureByClassName(TFigure(GCadForm.PCad.Figures[i]), cTSCSFigureGrp) then begin SCSFigureGrp := TSCSFigureGrp(GCadForm.PCad.Figures[i]); for j := 0 to SCSFigureGrp.InFigures.Count - 1 do begin if CheckFigureByClassName(TFigure(SCSFigureGrp.InFigures[j]), cTConnectorObject) then TConnectorObject(SCSFigureGrp.InFigures[j]).CaptionsGroup := TRichTextMod(TConnectorObject(SCSFigureGrp.InFigures[j]).tmpCaptionsGroup); if CheckFigureByClassName(TFigure(SCSFigureGrp.InFigures[j]), cTOrthoLine) then TOrthoLine(SCSFigureGrp.InFigures[j]).CaptionsGroup := TFigureGrpNotMod(TOrthoLine(SCSFigureGrp.InFigures[j]).tmpCaptionsGroup); end; end; end; // Конвертить классы for i := 0 to LinesList.Count - 1 do begin FLine := TOrthoLine(LinesList[i]); // CaptionGroup if FLine.tmpCaptionsGroup <> nil then begin // старые форматы if FLine.tmpCaptions = nil then begin GCadForm.PCad.Figures.Remove(FLine.tmpCaptionsGroup); FreeAndNil(FLine.tmpCaptionsGroup); FLine.ReCreateCaptionsGroup(True, false); end // самый новый формат else begin FLine.CaptionsGroup := TFigureGrpNotMod(FLine.tmpCaptionsGroup); end; FLine.CaptionsGroup.LockModify := True; FLine.tmpCaptionsGroup := nil; FLine.tmpCaptions := nil; end else begin FLine.CalculLength := FLine.LengthCalc; FLine.LineLength := FLine.CalculLength; if FLine.OutTextCaptions.Count = 0 then begin Str := GetLineCaptionFormat(FLine, GCadForm.FShowLineCaptionsType); FLine.OutTextCaptions.Add(Str); end else begin Str := GetLineCaptionFormat(FLine, GCadForm.FShowLineCaptionsType); FLine.OutTextCaptions[0] := Str; end; FLine.ReCreateCaptionsGroup(True, false); end; // NotesCaptions if FLine.tmpNotesCaptions <> nil then begin if CheckFigureByClassName(FLine.tmpNotesCaptions, cTFigureGrpNotMod) then begin FLine.NotesGroup := ConvertNotesGroupToRichText(FLine.NotesGroup, True); FLine.ReCreateNotesGroup; end; FLine.NotesGroup.LockModify := True; FLine.tmpNotesCaptions := nil; end else begin FLine.ReCreateNotesGroup(True); end; end; for i := 0 to ConnsList.Count - 1 do begin FConn := TConnectorObject(ConnsList[i]); // CaptionGroup if FConn.ConnectorType = ct_Clear then begin if FConn.tmpCaptionsGroup <> nil then begin if CheckFigureByClassName(FConn.tmpCaptionsGroup, cTFigureGrpNotMod) then RemoveInFigureGrp(TFigureGrp(FConn.tmpCaptionsGroup)); GCadForm.PCad.Figures.Remove(FConn.tmpCaptionsGroup); FreeAndNil(FConn.tmpCaptionsGroup); end; end; if FConn.tmpCaptionsGroup <> nil then begin if CheckFigureByClassName(FConn.tmpCaptionsGroup, cTFigureGrpNotMod) then begin FConn.CaptionsGroup := ConvertCaptionsGroupToRichText(TFigureGrpNotMod(FConn.tmpCaptionsGroup), False); FConn.ReCreateCaptionsGroup(false, false); FConn.DefRaizeDrawFigurePos; end else begin FConn.CaptionsGroup := TRichTextMod(FConn.tmpCaptionsGroup); end; FConn.CaptionsGroup.LockModify := True; FConn.tmpCaptionsGroup := nil; end; // NotesCaptions if FConn.ConnectorType = ct_Clear then begin if FConn.NotesGroup <> nil then begin RemoveInFigureGrp(TFigureGrp(FConn.NotesGroup)); GCadForm.PCad.Figures.Remove(FConn.NotesGroup); FreeAndNil(FConn.NotesGroup); end; end; if FConn.NotesGroup <> nil then if FConn.tmpNotesCaptions <> nil then begin if CheckFigureByClassName(FConn.tmpNotesCaptions, cTFigureGrpNotMod) then begin FConn.NotesGroup := ConvertNotesGroupToRichText(FConn.NotesGroup, False); FConn.ReCreateNotesGroup; end else begin end; FConn.NotesGroup.LockModify := True; FConn.tmpNotesCaptions := nil; end; end; except on E: Exception do addExceptionToLogEx('U_Common.FindObjectsForConvertClasses', E.Message); end; FreeAndNil(LinesList); FreeAndNil(ConnsList); end; Function ConvertCaptionsGroupToRichText(aCaptionsGroup: TFigureGrpNotMod; aIsLine: Boolean): TRichTextMod; var i: integer; tempstr: string; StrList: TStringList; LHandle: Integer; CPoints: TDoublePoint; Angle: Double; RichTextMod: TRichTextMod; TM: TTextMetric; xCanvas: TMetafileCanvas; h, w: double; begin Result := nil; StrList := TStringList.Create; try // сохранить данные с FigureGroup CPoints := aCaptionsGroup.CenterPoint; LHandle := aCaptionsGroup.LayerHandle; Angle := aCaptionsGroup.AngletoPoint; for i := 0 to aCaptionsGroup.InFigures.Count - 1 do begin tempstr := TText(aCaptionsGroup.InFigures[i]).Text; StrList.Add(tempstr); end; // удалить FigureGroup RemoveInFigureGrp(aCaptionsGroup); GCadForm.PCad.Figures.Remove(aCaptionsGroup); FreeAndNil(aCaptionsGroup); // Создать и Обработать RichText if aIsLine then RichTextMod := TRichTextMod.create(-100, -100, -100, -100, 1, ord(psSolid), clBlack, ord(bsClear), clBlack, LHandle, mydsNormal, GCadForm.PCad, rot_Line, rnt_Caption) else RichTextMod := TRichTextMod.create(-100, -100, -100, -100, 1, ord(psSolid), clBlack, ord(bsClear), clBlack, LHandle, mydsNormal, GCadForm.PCad, rot_Conn, rnt_Caption); RichTextMod.RE.Lines.Clear; for i := 0 to StrList.Count - 1 do begin StrList.Strings[i] := FastReplace(StrList.Strings[i],#13#10,' '); RichTextMod.re.Lines.Add(StrList.Strings[i]); end; GCadForm.PCad.AddCustomFigure(GLN (LHandle), RichTextMod, False); RefreshCAD(GCadForm.PCad); // Tolik -- 13/01/2017 RichTextMod.ttMetaFile:= TMetaFile.Create; RichTextMod.ttMetafile.Enhanced := True; // xCanvas := TMetafileCanvas.Create(RichTextMod.ttMetafile, 0); xCanvas.Font.Name := RichTextMod.re.Font.Name; xCanvas.Font.Size := RichTextMod.re.Font.Size; GetTextMetrics(xCanvas.Handle, TM); h := TM.tmHeight / 4 * RichTextMod.re.Lines.Count + 1; w := 0; for i := 0 to RichTextMod.re.Lines.Count - 1 do begin if w < xCanvas.TextWidth(RichTextMod.Re.Lines[i]) then w := xCanvas.TextWidth(RichTextMod.Re.Lines[i]); end; w := (w + 3) / 4 ; FreeAndNil(xCanvas); RichTextMod.ttMetaFile.Free; GCadForm.PCad.Figures.Remove(RichTextMod); FreeAndNil(RichTextMod); if aIsLine then RichTextMod := TRichTextMod.create(-100, -100, -100 + w, -100 + h, 1, ord(psSolid), clBlack, ord(bsClear), clBlack, LHandle, mydsNormal, GCadForm.PCad, rot_Line, rnt_Caption) else RichTextMod := TRichTextMod.create(-100, -100, -100 + w, -100 + h, 1, ord(psSolid), clBlack, ord(bsClear), clBlack, LHandle, mydsNormal, GCadForm.PCad, rot_Conn, rnt_Caption); RichTextMod.RE.Lines.Clear; for i := 0 to StrList.Count - 1 do begin StrList.Strings[i] := FastReplace(StrList.Strings[i],#13#10,' '); RichTextMod.re.Lines.Add(StrList.Strings[i]); end; RichTextMod.Move(CPoints.x - RichTextMod.CenterPoint.x, CPoints.y - RichTextMod.CenterPoint.y); RichTextMod.rotate(Angle, RichTextMod.CenterPoint); GCadForm.PCad.AddCustomFigure(GLN (LHandle), RichTextMod, False); // Result := RichTextMod; except on E: Exception do addExceptionToLogEx('U_Common.ConvertCaptionsGroupToRichText', E.Message); end; FreeAndNil(StrList); end; Function ConvertNotesGroupToRichText(aNotesGroup: TFigureGrpNotMod; aIsLine: Boolean): TFigureGrpNotMod; var i: integer; tempstr: string; StrList: TStringList; LHandle: Integer; CPoints: TDoublePoint; Angle: Double; RichTextMod: TRichTextMod; TM: TTextMetric; xCanvas: TMetafileCanvas; h, w: double; NotesCaptions: TFigureGrpNotMod; begin Result := nil; StrList := TStringList.Create; try NotesCaptions := TFigureGrpNotMod(aNotesGroup.InFigures[1]); // сохранить данные с FigureGroup CPoints := NotesCaptions.CenterPoint; LHandle := NotesCaptions.LayerHandle; Angle := NotesCaptions.AngletoPoint; for i := 0 to NotesCaptions.InFigures.Count - 1 do begin tempstr := TText(NotesCaptions.InFigures[i]).Text; StrList.Add(tempstr); end; // удалить FigureGroup RemoveInFigureGrp(NotesCaptions); aNotesGroup.RemoveFromGrp(NotesCaptions); //28.04.2011 aNotesGroup.InFigures.Remove(NotesCaptions); FreeAndNil(NotesCaptions); // Создать и Обработать RichText if aIsLine then RichTextMod := TRichTextMod.create(-100, -100, -100, -100, 1, ord(psSolid), clBlack, ord(bsClear), clBlack, LHandle, mydsNormal, GCadForm.PCad, rot_Line, rnt_Note) else RichTextMod := TRichTextMod.create(-100, -100, -100, -100, 1, ord(psSolid), clBlack, ord(bsClear), clBlack, LHandle, mydsNormal, GCadForm.PCad, rot_Conn, rnt_Note); RichTextMod.RE.Lines.Clear; for i := 0 to StrList.Count - 1 do begin StrList.Strings[i] := FastReplace(StrList.Strings[i],#13#10,' '); RichTextMod.re.Lines.Add(StrList.Strings[i]); end; GCadForm.PCad.AddCustomFigure(GLN (LHandle), RichTextMod, False); RefreshCAD(GCadForm.PCad); // Tolik -- 13/01/2017 RichTextMod.ttMetaFile:= TMetaFile.Create; RichTextMod.ttMetafile.Enhanced := True; // xCanvas := TMetafileCanvas.Create(RichTextMod.ttMetafile, 0); xCanvas.Font.Name := RichTextMod.re.Font.Name; xCanvas.Font.Size := RichTextMod.re.Font.Size; GetTextMetrics(xCanvas.Handle, TM); h := TM.tmHeight / 4 * RichTextMod.re.Lines.Count + 1; w := 0; for i := 0 to RichTextMod.re.Lines.Count - 1 do begin if w < xCanvas.TextWidth(RichTextMod.Re.Lines[i]) then w := xCanvas.TextWidth(RichTextMod.Re.Lines[i]); end; w := (w + 3) / 4; FreeAndNil(xCanvas); RichTextMod.ttMetaFile.Free; GCadForm.PCad.Figures.Remove(RichTextMod); FreeAndNil(RichTextMod); if aIsLine then RichTextMod := TRichTextMod.create(-100, -100, -100 + w, -100 + h, 1, ord(psSolid), clBlack, ord(bsClear), clBlack, LHandle, mydsNormal, GCadForm.PCad, rot_Line, rnt_Note) else RichTextMod := TRichTextMod.create(-100, -100, -100 + w, -100 + h, 1, ord(psSolid), clBlack, ord(bsClear), clBlack, LHandle, mydsNormal, GCadForm.PCad, rot_Conn, rnt_Note); RichTextMod.RE.Lines.Clear; for i := 0 to StrList.Count - 1 do begin StrList.Strings[i] := FastReplace(StrList.Strings[i],#13#10,' '); RichTextMod.re.Lines.Add(StrList.Strings[i]); end; RichTextMod.Move(CPoints.x - RichTextMod.CenterPoint.x, CPoints.y - RichTextMod.CenterPoint.y); RichTextMod.rotate(Angle, RichTextMod.CenterPoint); aNotesGroup.AddFigure(RichTextMod); // Result := aNotesGroup; except on E: Exception do addExceptionToLogEx('U_Common.ConvertCaptionsGroupToRichText', E.Message); end; FreeAndNil(StrList); end; Function GetFiguresByLevel(aFigure: TFigure; X, Y: Double; aSameType: Boolean; ASort: Boolean=false): TList; var i: integer; FFigure: TFigure; FLine: TOrthoLine; FConn: TConnectorObject; CurrLine: TOrthoLine; CurrConn: TConnectorObject; function GetItemHeight(AFigure: TFigure): Double; begin Result := 0; if CheckFigureByClassName(AFigure, cTOrthoLine) then if TOrthoLine(AFigure).ActualZOrder[1] = TOrthoLine(AFigure).ActualZOrder[2] then Result := TOrthoLine(AFigure).ActualZOrder[1] else Result := Min(TOrthoLine(AFigure).ActualZOrder[1], TOrthoLine(AFigure).ActualZOrder[2]); if CheckFigureByClassName(AFigure, cTConnectorObject) then Result := TConnectorObject(AFigure).ActualZOrder[1]; end; function CompareMenuItems(Item1, Item2: Pointer): Integer; var h1, h2: Double; begin Result := 0; h1 := GetItemHeight(TFigure(Item1)); h2 := GetItemHeight(TFigure(Item2)); if h1 > h2 then Result := 1 else if h1 < h2 then Result := -1; end; begin Result := TList.Create; try // Трасса if aSameType then begin if CheckFigureByClassName(aFigure, cTOrthoLine) then begin FLine := TOrthoLine(aFigure); Result.Add(FLine); if GCadForm.FNeedUpdateCheckedFigures then GCadForm.UpdateCheckedFigures; //for i := 0 to GCadForm.PCad.FigureCount - 1 do for i := 0 to GCadForm.FCheckedFigures.Count - 1 do begin //if CheckFigureByClassName(TFigure(GCadForm.PCad.Figures[i]), cTOrthoLine) then if CheckFigureByClassName(TFigure(GCadForm.FCheckedFigures[i]), cTOrthoLine) then begin //CurrLine := TOrthoLine(GCadForm.PCad.Figures[i]); CurrLine := TOrthoLine(GCadForm.FCheckedFigures[i]); if FLine <> CurrLine then begin if CurrLine.IsPointIn(X, Y) then Result.Add(CurrLine); end; end; end; end; // Коннектор if CheckFigureByClassName(aFigure, cTConnectorObject) then begin FConn := TConnectorObject(aFigure); Result.Add(FConn); if GCadForm.FNeedUpdateCheckedFigures then GCadForm.UpdateCheckedFigures; //for i := 0 to GCadForm.PCad.FigureCount - 1 do for i := 0 to GCadForm.FCheckedFigures.Count - 1 do begin //if CheckFigureByClassName(TFigure(GCadForm.PCad.Figures[i]), cTConnectorObject) then if CheckFigureByClassName(TFigure(GCadForm.FCheckedFigures[i]), cTConnectorObject) then begin //CurrConn := TConnectorObject(GCadForm.PCad.Figures[i]); CurrConn := TConnectorObject(GCadForm.FCheckedFigures[i]); if FConn <> CurrConn then begin if CurrConn.ConnectorType = ct_Clear then begin if CurrConn.JoinedConnectorsList.Count = 0 then if CurrConn.IsPointIn(X, Y) then Result.Add(CurrConn); end else begin if CurrConn.IsPointIn(X, Y) then Result.Add(CurrConn); end; end; end; end; end; end else begin Result.Add(aFigure); if GCadForm.FNeedUpdateCheckedFigures then GCadForm.UpdateCheckedFigures; //for i := 0 to GCadForm.PCad.FigureCount - 1 do for i := 0 to GCadForm.FCheckedFigures.Count - 1 do begin //FFigure := TFigure(GCadForm.PCad.Figures[i]); FFigure := TFigure(GCadForm.FCheckedFigures[i]); if CheckFigureByClassName(FFigure, cTConnectorObject) then begin CurrConn := TConnectorObject(FFigure); if aFigure <> CurrConn then begin if CurrConn.ConnectorType = ct_Clear then begin if CurrConn.JoinedConnectorsList.Count = 0 then if CurrConn.IsPointIn(X, Y) then Result.Add(CurrConn); end else begin if CurrConn.IsPointIn(X, Y) then Result.Add(CurrConn); end; end; end; if CheckFigureByClassName(FFigure, cTOrthoLine) then begin CurrLine := TOrthoLine(FFigure); if aFigure <> CurrLine then begin if CurrLine.IsPointIn(X, Y) then Result.Add(CurrLine); end; end; end; end; if ASort then Result.Sort(@CompareMenuItems); except on E: Exception do addExceptionToLogEx('U_Common.GetFiguresByLevel', E.Message); end; if Result.Count > 0 then begin for i := Result.Count - 1 downto 0 do begin if CheckFigureByClassName(TFigure(Result[i]), cTConnectorObject) then if TConnectorObject(Result[i]).isToRaise then Result.Delete(i); end; end; end; //Tolik 11/04/2018 -- Function GetVLinesOnConnector(AConnector: TConnectorObject): TList; var i, j: Integer; JoinedConn: TConnectorObject; JoinedLine: TOrthoLine; vLine1, vLine2: TOrthoLine; NextConn: TConnectorObject; Function GetNextVConn(aLine: TOrthoLine; aConn: TconnectorObject): TConnectorObject; begin Result := TConnectorObject(aLine.JoinConnector1); if Result.JoinedConnectorsList.Count = 0 then begin if aConn.ConnectorType = ct_Clear then begin if aConn.ID = Result.ID then Result := TConnectorObject(aLine.JoinConnector2); end else begin if aConn.JoinedConnectorsList.IndexOf(Result) <> -1 then Result := TConnectorObject(ALine.JoinConnector2); end; end else begin Result := TConnectorObject(Result.JoinedConnectorsList[0]); if aConn.ConnectorType = ct_Clear then begin if Result.JoinedConnectorsList.IndexOf(AConn) <> -1 then Result := TConnectorObject(aLine.JoinConnector2); end else if aConn.ConnectorType = ct_Nb then begin if Result.ID = aConn.ID then Result := TConnectorObject(aLine.JoinConnector2); end; if Result.ConnectorType = ct_Clear then if Result.JoinedConnectorsList.Count > 0 then Result := TConnectorObject(Result.JoinedConnectorsList[0]); end; end; Procedure FindNextVLine(aConn: TConnectorObject); var NextConn: TConnectorObject; JoinedLine: TOrthoLine; i,j: Integer; begin NextConn := Nil; if AConn.ConnectorType = ct_Clear then begin for i := 0 to AConn.JoinedOrtholinesList.Count - 1 do begin JoinedLine := TOrthoLine(AConn.JoinedOrtholinesList[i]); if JoinedLine.FIsVertical then if Result.IndexOf(JoinedLine) = -1 then begin Result.Add(JoinedLine); NextConn := GetNextVConn(JoinedLine, AConn); break; end; end; end else begin JoinedLine := Nil; for i := 0 to AConn.JoinedConnectorsList.Count - 1 do begin JoinedConn := TConnectorObject(AConn.JoinedConnectorsList[i]); for j := 0 to JoinedConn.JoinedOrtholinesList.Count - 1 do begin JoinedLine := TOrthoLine(JoinedConn.JoinedOrtholinesList[j]); if JoinedLine.FIsVertical then if Result.IndexOf(JoinedLine) = -1 then begin Result.Add(JoinedLine); NextConn := GetNextVConn(JoinedLine, AConn); JoinedLine := Nil; break; end; end; if JoinedLine = nil then break; end; end; if NextConn <> nil then FindNextVLine(NextConn); end; begin Result := TList.Create; vLine1 := Nil; vLine2 := Nil; if AConnector.ConnectorType = ct_Clear then begin for i := 0 to AConnector.JoinedOrtholinesList.Count - 1 do begin JoinedLine := TOrthoLine(AConnector.JoinedOrtholinesList[i]); if JoinedLine.FIsVertical then begin if vLine1 = nil then vLine1 := JoinedLine else begin vLine2 := JoinedLine; break; end; end; end; end else if AConnector.ConnectorType = ct_NB then begin for i := 0 to AConnector.JoinedConnectorsList.Count - 1 do begin JoinedConn := TConnectorObject(AConnector.JoinedConnectorsList[i]); for j := 0 to JoinedConn.JoinedOrtholinesList.Count - 1 do begin JoinedLine := TOrthoLine(JoinedConn.JoinedOrtholinesList[j]); if vLine1 = nil then vLine1 := JoinedLine else begin vLine2 := JoinedLine; break; end; end; if vLine2 <> nil then break; end; end; if vLine1 <> nil then begin NextConn := GetNextVConn(vLine1, AConnector); FindNextVLine(NextConn); end; if vLine2 <> nil then begin NextConn := GetNextVConn(vLine1, AConnector); FindNextVLine(NextConn); end; end; // //Tolik 23/04/2018 -- переписана...Старая закомменчена -- смотри ниже. Здесь исключены все объекты, которые // напрямую или косвенно подключены к объекту, который двигаем (чтобы при отпускании мыши после драга не получить // в списке объектов для снапа те, которые подключены к объекту, который двигаем, а то кака-то херня...) Function GetObjectsByVertical(aSelf, aSnapConnector: TConnectorObject): TList; var i: integer; FFigure: TFigure; FLine: TOrthoLine; FConn: TConnectorObject; CurrLine: TOrthoLine; CurrConn, LineConn, NextConn: TConnectorObject; X, Y, Z: double; SelfConnectedList: TList; PassedList: TList; Procedure GetSelfConnectedList(aConn: TConnectorObject); var i, j: Integer; RaiseLine, vLine1, vLine2, JoinedLine: TOrthoLine; JoinedConn: TConnectorObject; begin RaiseLine := nil; vLine1 := nil; vLine2 := nil; NextConn := Nil; if SelfConnectedList.IndexOf(aConn) = -1 then SelfConnectedList.Add(AConn); if aConn.ConnectorType = ct_Clear then begin for i := 0 to aConn.JoinedOrthoLinesList.Count - 1 do begin JoinedLine := TOrthoLine(aConn.JoinedOrthoLinesList[i]); if SelfConnectedList.IndexOf(JoinedLine) = -1 then SelfConnectedList.Add(JoinedLine); if PassedList.IndexOf(JoinedLine) = -1 then begin if JoinedLine.FisRaiseUpDown then begin PassedList.Add(JoinedLine); RaiseLine := JoinedLine end else if JoinedLine.FisVertical then begin PassedList.Add(JoinedLine); if vLine1 = nil then vLine1 := JoinedLine else vLine2 := JoinedLine; end else begin if TConnectorObject(JoinedLine.JoinConnector1).Id = AConn.ID then JoinedConn := TConnectorObject(JoinedLine.JoinConnector2) else JoinedConn := TConnectorObject(JoinedLine.JoinConnector1); if SelfConnectedList.IndexOf(JoinedConn) = -1 then SelfConnectedList.Add(JoinedConn); if JoinedConn.JoinedConnectorsList.Count > 0 then begin JoinedConn := TConnectorObject(JoinedConn.JoinedConnectorsList[0]); if SelfConnectedList.IndexOf(JoinedConn) = -1 then SelfConnectedList.Add(JoinedConn); end; end; end; end; end else begin for i := 0 to AConn.JoinedConnectorsList.Count - 1 do begin JoinedConn := TConnectorObject(AConn.JoinedConnectorsList[i]); for j := 0 to JoinedConn.JoinedOrthoLinesList.Count - 1 do begin JoinedLine := TOrthoLine(JoinedConn.JoinedOrthoLinesList[j]); if SelfConnectedList.IndexOf(JoinedLine) = -1 then SelfConnectedList.Add(JoinedLine); if PassedList.IndexOf(JoinedLine) = -1 then begin if JoinedLine.FisRaiseUpDown then begin PassedList.Add(JoinedLine); RaiseLine := JoinedLine end else if JoinedLine.FisVertical then begin PassedList.Add(JoinedLine); if vLine1 = nil then vLine1 := JoinedLine else vLine2 := JoinedLine; end else begin if TConnectorObject(JoinedLine.JoinConnector1).Id = JoinedConn.ID then LineConn := TConnectorObject(JoinedLine.JoinConnector2) else LineConn := TConnectorObject(JoinedLine.JoinConnector1); if SelfConnectedList.IndexOf(LineConn) = -1 then SelfConnectedList.Add(LineConn); if LineConn.JoinedConnectorsList.Count > 0 then begin LineConn := TConnectorObject(LineConn.JoinedConnectorsList[0]); if SelfConnectedList.IndexOf(LineConn) = -1 then SelfConnectedList.Add(LineConn); end; end; end; end; end; end; if RaiseLine <> nil then begin if aConn.ConnectorType = ct_Clear then begin if TConnectorObject(RaiseLine.JoinConnector1).ID = aConn.ID then NextConn := TConnectorObject(RaiseLine.JoinConnector2) else NextConn := TConnectorObject(RaiseLine.JoinConnector1); end else begin if AConn.JoinedConnectorsList.IndexOf(RaiseLine.JoinConnector1) = -1 then NextConn := TConnectorObject(RaiseLine.JoinConnector1) else NextConn := TConnectorObject(RaiseLine.JoinConnector2); end; if NextConn.JoinedConnectorsList.Count > 0 then NextConn := TConnectorObject(NextConn.JoinedConnectorsList[0]); GetSelfConnectedList(NextConn); end else if vLine1 <> nil then begin if aConn.ConnectorType = ct_Clear then begin if TConnectorObject(vLine1.JoinConnector1).ID = aConn.ID then NextConn := TConnectorObject(vLine1.JoinConnector2) else NextConn := TConnectorObject(vLine1.JoinConnector1); end else begin if AConn.JoinedConnectorsList.IndexOf(vLine1.JoinConnector1) = -1 then NextConn := TConnectorObject(vLine1.JoinConnector1) else NextConn := TConnectorObject(vLine1.JoinConnector2); end; if NextConn.JoinedConnectorsList.Count > 0 then NextConn := TConnectorObject(NextConn.JoinedConnectorsList[0]); GetSelfConnectedList(NextConn); if vLine2 <> nil then begin if aConn.ConnectorType = ct_Clear then begin if TConnectorObject(vLine1.JoinConnector1).ID = aConn.ID then NextConn := TConnectorObject(vLine1.JoinConnector2) else NextConn := TConnectorObject(vLine1.JoinConnector1); end else begin if AConn.JoinedConnectorsList.IndexOf(vLine1.JoinConnector1) = -1 then NextConn := TConnectorObject(vLine1.JoinConnector1) else NextConn := TConnectorObject(vLine1.JoinConnector2); end; if NextConn.JoinedConnectorsList.Count > 0 then NextConn := TConnectorObject(NextConn.JoinedConnectorsList[0]); GetSelfConnectedList(NextConn); end; end; if NextConn = nil then exit; end; begin Result := TList.Create; SelfConnectedList := TList.Create; PassedList := TList.Create; GetSelfConnectedList(aSelf); PassedList.Free; try Result.Add(aSnapConnector); X := aSnapConnector.ActualPoints[1].x; Y := aSnapConnector.ActualPoints[1].y; Z := aSelf.ActualZOrder[1]; if GCadForm.FNeedUpdateCheckedFigures then GCadForm.UpdateCheckedFigures; //for i := 0 to GCadForm.PCad.FigureCount - 1 do for i := 0 to GCadForm.FCheckedFigures.Count - 1 do begin //FFigure := TFigure(GCadForm.PCad.Figures[i]); FFigure := TFigure(GCadForm.FCheckedFigures[i]); if CheckFigureByClassName(FFigure, cTConnectorObject) then begin CurrConn := TConnectorObject(FFigure); if (CurrConn <> aSelf) and (CurrConn <> aSnapConnector) then begin if CurrConn.ConnectorType = ct_Clear then begin if CurrConn.JoinedConnectorsList.Count = 0 then if CurrConn.IsPointIn(X, Y) then if SelfConnectedList.IndexOf(CurrConn) = -1 then Result.Add(CurrConn); end else begin if CurrConn.IsPointIn(X, Y) then if SelfConnectedList.IndexOf(CurrConn) = -1 then Result.Add(CurrConn); end; end; end; if CheckFigureByClassName(FFigure, cTOrthoLine) then begin CurrLine := TOrthoLine(FFigure); if CurrLine.FIsVertical then begin if CurrLine.IsPointIn(X, Y) then if CheckVerticalInInterval(CurrLine, Z) then if SelfConnectedList.IndexOf(CurrLine) = -1 then Result.Add(CurrLine); end; end; end; except on E: Exception do addExceptionToLogEx('U_Common.GetObjectsByVertical', E.Message); end; SelfConnectedList.Free; end; Function GetLinesByVertical(aSelf: TConnectorObject; aSnapLine: TOrthoLine): TList; var i: integer; FFigure: TFigure; FLine: TOrthoLine; FConn: TConnectorObject; CurrLine: TOrthoLine; CurrConn: TConnectorObject; X, Y: double; begin Result := TList.Create; try Result.Add(aSnapLine); X := aSnapLine.ActualPoints[1].x; Y := aSnapLine.ActualPoints[1].y; for i := 0 to GCadForm.PCad.FigureCount - 1 do begin FFigure := TFigure(GCadForm.PCad.Figures[i]); if CheckFigureByClassName(FFigure, cTOrthoLine) then begin CurrLine := TOrthoLine(FFigure); if CurrLine <> aSnapLine then if CurrLine.FIsVertical then begin if CurrLine.IsPointIn(X, Y) then Result.Add(CurrLine); end; end; end; except on E: Exception do addExceptionToLogEx('U_Common.GetFiguresByLevel', E.Message); end; end; Function CheckVerticalInInterval(aVertical: TOrthoLine; aZ: Double): Boolean; var z1, z2: double; begin Result := False; try if (aVertical.ActualZOrder[2] > aVertical.ActualZOrder[1]) then begin z1 := aVertical.ActualZOrder[1]; z2 := aVertical.ActualZOrder[2]; end else begin z1 := aVertical.ActualZOrder[2]; z2 := aVertical.ActualZOrder[1]; end; if (aZ >= z1) and (aZ <= z2) then Result := True; except on E: Exception do AddExceptionToLogEx('U_Common.CheckVerticalInInterval', E.Message); end; end; // Tolik 17/12/2020 -- немножко тут переписано, чтобы не удалить коннектор вместе с присоединенными трассами, если их больше одной, // а то что-то как-то.... не так Procedure DeleteRaiseOtherFloor(aItRaise: TConnectorObject); var ListOfPassage: TF_CAD; ConnOfPassage: TConnectorObject; CurGCadForm: TF_CAD; SCSFigureGrp: TSCSFigureGrp; RaiseLine: TOrthoLine; i: integer; CanDelConn: Boolean; begin try ListOfPassage := GetListOfPassage(aItRaise.FID_ListToPassage); if ListOfPassage <> nil then begin ConnOfPassage := TConnectorObject(GetFigureByID(ListOfPassage, aItRaise.FID_ConnToPassage)); if ConnOfPassage <> nil then begin CurGCadForm := GCadForm; GCadForm := ListOfPassage; RaiseLine := nil; ConnOfPassage.FConnRaiseType := crt_None; if ConnOfPassage.FGroupObject = nil then begin //ConnOfPassage.Delete(True) CanDelConn := False; if Assigned(ConnOfPassage.JoinedOrtholinesList) then begin if ConnOfPassage.JoinedOrtholinesList.Count <= 1 then CandelConn := True else begin for i := 0 to ConnOfPassage.JoinedOrtholinesList.Count - 1 do begin if TOrthoLine(ConnOfPassage.JoinedOrtholinesList[i]).FIsRaiseUpDown then RaiseLine := TOrthoLine(ConnOfPassage.JoinedOrtholinesList[i]); end; end; end; if CanDelConn then ConnOfPassage.Delete(True) else if RaiseLine <> nil then RaiseLine.Delete; end else begin SCSFigureGrp := ConnOfPassage.FGroupObject; DeleteObjectFromSCSFigureGrp(SCSFigureGrp, ConnOfPassage); end; RefreshCAD(GCadForm.PCad); GCadForm := CurGCadForm; end end; except on E: Exception do addExceptionToLogEx('U_Common.DeleteRaiseOtherFloor', E.Message); end; end; // // Tolik -- 22/11/2016 -- старая -- вообще пизнец из-за того, что есть групповая фигура и // объект никогда не вернется как nil (потому что ищется в FSCSFigures) { Procedure DeleteRaiseOtherFloor(aItRaise: TConnectorObject); var ListOfPassage: TF_CAD; ConnOfPassage: TConnectorObject; CurGCadForm: TF_CAD; SCSFigureGrp: TSCSFigureGrp; begin try ListOfPassage := GetListOfPassage(aItRaise.FID_ListToPassage); if ListOfPassage <> nil then begin ConnOfPassage := TConnectorObject(GetFigureByID(ListOfPassage, aItRaise.FID_ConnToPassage)); if ConnOfPassage <> nil then begin CurGCadForm := GCadForm; GCadForm := ListOfPassage; ConnOfPassage.FConnRaiseType := crt_None; if ConnOfPassage.FGroupObject = nil then ConnOfPassage.Delete(True) else begin SCSFigureGrp := ConnOfPassage.FGroupObject; DeleteObjectFromSCSFigureGrp(SCSFigureGrp, ConnOfPassage); end; RefreshCAD(GCadForm.PCad); GCadForm := CurGCadForm; end end; except on E: Exception do addExceptionToLogEx('U_Common.DeleteRaiseOtherFloor', E.Message); end; end; } { Procedure DeleteRaiseOtherFloor(aItRaise: TConnectorObject); var ListOfPassage: TF_CAD; ConnOfPassage: TConnectorObject; CurGCadForm: TF_CAD; SCSFigureGrp: TSCSFigureGrp; begin try ListOfPassage := GetListOfPassage(aItRaise.FID_ListToPassage); if ListOfPassage <> nil then begin ConnOfPassage := TConnectorObject(GetFigureByID(ListOfPassage, aItRaise.FID_ConnToPassage)); if ConnOfPassage <> nil then begin CurGCadForm := GCadForm; GCadForm := ListOfPassage; ConnOfPassage.FConnRaiseType := crt_None; ConnOfPassage.Delete(True); RefreshCAD(GCadForm.PCad); GCadForm := CurGCadForm; end else begin SCSFigureGrp := GetSCSFigureGrp(ListOfPassage, aItRaise.FID_ConnToPassage); if SCSFigureGrp <> nil then begin ConnOfPassage := TConnectorObject(GetFigureByIDInSCSFigureGrp(SCSFigureGrp, aItRaise.FID_ConnToPassage)); if ConnOfPassage <> nil then begin CurGCadForm := GCadForm; GCadForm := ListOfPassage; ConnOfPassage.FConnRaiseType := crt_None; DeleteObjectFromSCSFigureGrp(SCSFigureGrp, ConnOfPassage); RefreshCAD(GCadForm.PCad); GCadForm := CurGCadForm; end; end; end; end; except on E: Exception do addExceptionToLogEx('U_Common.DeleteRaiseOtherFloor', E.Message); end; end; } Function MirrorCables(aClearConn: TConnectorObject; aNearTracedLine: TOrthoLine): Integer; var i,j: integer; CurrConn: TConnectorObject; CurrLine: TOrthoLine; mess: string; Count: Integer; MessBoxResult: Integer; Side: Integer; begin Result := 0; try for i := 0 to aClearConn.JoinedOrtholinesList.Count - 1 do begin CurrLine := TOrthoLine(aClearConn.JoinedOrtholinesList[i]); if CurrLine <> aNearTracedLine then begin Side := 1; //#From Oleg# //14.09.2010 if CurrLine.JoinConnector1 = aClearConn then Side := 1; if CurrLine.JoinConnector2 = aClearConn then Side := 2; Count := GetCablesCountFromTrace(CurrLine.ID, Side, GDropComponent.ID); if count > 1 then begin mess := cCommon_Mes16 + IntTostr(Count) + cCommon_Mes17 + #13#10 + cCommon_Mes18; //MessBoxResult := MessageBoxA(FSCS_Main.Handle, PAnsiChar(mess), cCommon_Mes19, MB_YESNOCANCEL); MessBoxResult := MessageBox(FSCS_Main.Handle, PChar(mess), PChar(cCommon_Mes19), MB_YESNOCANCEL); if MessBoxResult = IDYes then begin Result := Count; exit; end else if MessBoxResult = IDNo then Result := 1; if MessBoxResult = IDCancel then exit; end else begin Result := 1; end; end; end; except on E: Exception do addExceptionToLogEx('U_Common.MirrorCables', E.Message); end; end; Function CheckCanTracingBetweenFloor(aLists: TIntList; aRaises: TList): Boolean; var i: integer; begin Result := True; try if aLists.Count <> aRaises.Count + 1 then Result := False; for i := 0 to aRaises.Count - 1 do if aRaises[i] = Nil then Result := False; except on E: Exception do addExceptionToLogEx('U_Common.CheckCanTracingBetweenFloor', E.Message); end; end; Function GetSortedListOfRaises(var aLists: TIntList; aRaiseType: TConnRaiseType; aEndPoint, aBeginPoint: TConnectorObject): TList; var i, j: Integer; RaiseConn: TConnectorObject; ListID: Integer; CurCad: TF_CAD; RaisesList: TList; ResList: TList; ListIndex: Integer; GlobalExit: Boolean; aRaiseType1, aRaiseType2: TConnRaiseType; OtherListIndex: Integer; ResListOfLists: TList; Procedure DoFindRaises(aCadForm: TF_CAD; aRaiseType: TConnRaiseType; aConnFrom, aConnTo: TConnectorObject; aListIndex: Integer); var i, j: integer; CurrRaise: TConnectorObject; OtherRaise: TConnectorObject; OtherCadList: TF_CAD; RaisesList: TList; AllTrace: TList; begin // Tolik 09/02/2017 -- RaisesList := nil; AllTrace := nil; // try RaisesList := TList.Create; if aCadForm <> nil then begin // если последний лист if aListIndex = ListIndex then begin AllTrace := GetAllTraceInCAD(aConnFrom, aBeginPoint); if AllTrace <> nil then begin GlobalExit := True; // Tolik -- 07/02/2017 -- FreeAndNil(RaisesList); FreeAndNil(AllTrace); // Exit; end; end // иначе снова искать с-п else begin aRaiseType1 := crt_none; aRaiseType2 := crt_none; if aRaiseType = crt_BetweenFloorUp then begin aRaiseType1 := crt_BetweenFloorUp; aRaiseType2 := crt_TrunkUp; end; if aRaiseType = crt_BetweenFloorDown then begin aRaiseType1 := crt_BetweenFloorDown; aRaiseType2 := crt_TrunkDown; end; for i := 0 to aCadForm.PCad.FigureCount - 1 do if CheckFigureByClassName(TFigure(aCadForm.PCad.Figures[i]), cTConnectorObject) then if (TConnectorObject(aCadForm.PCad.Figures[i]).FConnRaiseType = aRaiseType1) or (TConnectorObject(aCadForm.PCad.Figures[i]).FConnRaiseType = aRaiseType2) then RaisesList.Add(TConnectorObject(aCadForm.PCad.Figures[i])); end; // Tolik 09/02/2017 -- if AllTrace <> nil then FreeAndNil(AllTrace); end; if RaisesList.Count > 0 then begin for i := 0 to RaisesList.Count - 1 do begin if GlobalExit then begin // Tolik -- 07/02/2017 -- FreeAndNil(RaisesList); // Exit; end; CurrRaise := TConnectorObject(RaisesList[i]); AllTrace := GetAllTraceInCAD(aConnFrom, CurrRaise); if AllTrace <> nil then begin OtherCadList := GetListByID(CurrRaise.FID_ListToPassage); OtherRaise := TConnectorObject(GetFigureByID(OtherCadList, CurrRaise.FID_ConnToPassage)); if (OtherRaise <> nil) and (OtherCadList <> nil) then begin ResList.Add(CurrRaise); OtherListIndex := aLists.IndexOf(OtherCadList.FCADListID); // &&& ResListOfLists.Add(OtherCadList); // &&& DoFindRaises(OtherCadList, aRaiseType, OtherRaise, aBeginPoint, OtherListIndex {aListIndex + 1}); end; // Tolik 07/0/2017 -- FreeAndNil(AllTrace); // end; end; end; begin if GlobalExit then begin FreeAndNil(RaisesList); Exit; end; if ResList.Count > 0 then ResList.Delete(ResList.Count - 1); if ResListOfLists.Count > 0 then ResListOfLists.Delete(ResListOfLists.Count - 1); Exit; end; if RaisesList <> nil then FreeAndNil(RaisesList); if AllTrace <> nil then FreeAndNil(AllTrace); except on E: Exception do addExceptionToLogEx('U_Common.GetBetweenFloorRaises', E.Message); end; end; begin ResList := TList.Create; try ResListOfLists := TList.Create; ListIndex := aLists.Count - 1; ListID := aLists[0]; CurCad := GetListByID(ListID); GlobalExit := False; // &&& ResListOfLists.Add(CurCad); // &&& DoFindRaises(CurCad, aRaiseType, aEndPoint, aBeginPoint, 0); Result := ResList; aLists := CadsToIntCads(ResListOfLists); // Tolik 09/02/2017 -- FreeAndNil(ResListOfLists); // except on E: Exception do addExceptionToLogEx('U_Common.GetSortedListOfRaises', E.Message); end; end; // ***************************************************************************** Function GetSortedListOfRaisesFromCurr(var aLists: TIntList; aRaiseType: TConnRaiseType; aBeginPoint, aEndPoint: TConnectorObject): TList; var i, j: Integer; RaiseConn: TConnectorObject; ListID: Integer; CurCad: TF_CAD; RaisesList: TList; ResList: TList; ListIndex: Integer; GlobalExit: Boolean; aRaiseType1, aRaiseType2: TConnRaiseType; ResListOfLists: TList; function GetMarkedCount(aCurrList: TList): Integer; var i: Integer; vFigure: TFigure; begin Result := 0; for i := 0 to aCurrList.Count - 1 do begin vFigure := TFigure(aCurrList[i]); if CheckFigureByClassName(vFigure, cTOrthoLine) then if TOrthoLine(vFigure).FMarkTracing then Result := Result + 1; end; end; function GetMaxMarkedCount(aList: TList): Integer; var i: Integer; AllTraces: TList; MaxMarked: Integer; CurMarked: Integer; begin Result := 0; try MaxMarked := 0; if aList <> nil then begin for i := 0 to aList.Count - 1 do begin AllTraces := TList(aList[i]); CurMarked := GetMarkedCount(AllTraces); if CurMarked > MaxMarked then MaxMarked := CurMarked; end; end; Result := MaxMarked; except on E: Exception do addExceptionToLogEx('U_Common.GetMaxMarkedCount', E.Message); end; end; function GetSortedRaisesByMarked(aCurrConn: TConnectorObject; aRaises: TList): TList; var i, j: Integer; CurrRaise: TConnectorObject; ListOfAllTraces: TList; CurMarked, MaxMarked: Integer; MaxIndex: Integer; // Tolik k: Integer; // begin // Tolik -- 07/02/2017 -- ListOfAllTraces := nil; // Result := TList.create; try i := 0; MaxIndex := 0; while i < aRaises.Count do begin CurrRaise := TConnectorObject(aRaises[i]); ListOfAllTraces := nil; ListOfAllTraces := GetAllTraceInCADByMarked(CurrRaise, aCurrConn); // Tolik -- 27/04/2017 -- if (ListOfAllTraces <> nil) and (ListOfAllTraces.Count > 0) then begin // CurMarked := GetMaxMarkedCount(ListOfAllTraces); // Tolik 07/02/2017 -- утечка памяти !!! if ListOfAllTraces <> nil then begin // а здесь Толян провтыкал что тут ListOfAllTraces -- понимать как список списков //поэтому: for k := 0 to ListOfAllTraces.Count - 1 do TList(ListOfAllTraces[k]).Free; FreeAndNil(ListOfAllTraces); end; // MaxMarked := CurMarked; MaxIndex := 0; for j := 1 to aRaises.Count - 1 do begin CurrRaise := TConnectorObject(aRaises[j]); ListOfAllTraces := GetAllTraceInCADByMarked(CurrRaise, aCurrConn); CurMarked := GetMaxMarkedCount(ListOfAllTraces); // Tolik 07/02/2017 -- утечка памяти !!! if ListOfAllTraces <> nil then // тут ListOfAllTraces -- понимать как список списков begin // вот здесь Толян наврочил в свое время //for k := 0 to ListOfAllTraces.Count - 1 do // TList(ListOfAllTraces).Free; for k := 0 to ListOfAllTraces.Count - 1 do TList(ListOfAllTraces[k]).Free; FreeAndNil(ListOfAllTraces); end; // if CurMarked > MaxMarked then begin MaxMarked := CurMarked; MaxIndex := j; end; end; Result.Add(aRaises[MaxIndex]); end else FreeAndNil(ListOfAllTraces); aRaises.Delete(MaxIndex); end; except on E: Exception do addExceptionToLogEx('U_Common.GetSortedRaisesByMarked', E.Message); end; end; Procedure DoFindRaises(aCadForm: TF_CAD; aRaiseType: TConnRaiseType; aConnFrom, aConnTo: TConnectorObject; aListIndex: Integer); var i, j: integer; CurrRaise: TConnectorObject; OtherRaise: TConnectorObject; OtherCadList: TF_CAD; RaisesList: TList; AllTrace: TList; OtherListIndex: Integer; begin AllTrace := nil; // //Tolik на всякий RaisesList := TList.Create; try if aCadForm <> nil then begin // если последний лист if aListIndex = ListIndex then begin AllTrace := GetAllTraceInCAD(aConnFrom, aEndPoint); if AllTrace <> nil then begin GlobalExit := True; FreeAndNil(RaisesList); if AllTrace <> nil then FreeAndNil(AllTrace); Exit; end; end // иначе снова искать с-п else begin aRaiseType1 := crt_none; aRaiseType2 := crt_none; if aRaiseType = crt_BetweenFloorUp then begin aRaiseType1 := crt_BetweenFloorUp; aRaiseType2 := crt_TrunkUp; end; if aRaiseType = crt_BetweenFloorDown then begin aRaiseType1 := crt_BetweenFloorDown; aRaiseType2 := crt_TrunkDown; end; for i := 0 to aCadForm.PCad.FigureCount - 1 do if CheckFigureByClassName(TFigure(aCadForm.PCad.Figures[i]), cTConnectorObject) then if (TConnectorObject(aCadForm.PCad.Figures[i]).FConnRaiseType = aRaiseType1) or (TConnectorObject(aCadForm.PCad.Figures[i]).FConnRaiseType = aRaiseType2) then RaisesList.Add(TConnectorObject(aCadForm.PCad.Figures[i])); end; end; if RaisesList.Count > 0 then begin // это первый лист, искать по отмеченным трассам if aListIndex = 0 then begin RaisesList := GetSortedRaisesByMarked(aConnFrom, RaisesList); end; for i := 0 to RaisesList.Count - 1 do begin if GlobalExit then begin FreeAndNil(RaisesList); Exit; end; CurrRaise := TConnectorObject(RaisesList[i]); AllTrace := GetAllTraceInCAD(aConnFrom, CurrRaise); if AllTrace <> nil then begin OtherCadList := GetListByID(CurrRaise.FID_ListToPassage); OtherRaise := TConnectorObject(GetFigureByID(OtherCadList, CurrRaise.FID_ConnToPassage)); if (OtherRaise <> nil) and (OtherCadList <> nil) then begin ResList.Add(CurrRaise); OtherListIndex := aLists.IndexOf(OtherCadList.FCADListID); // &&& ResListOfLists.Add(OtherCadList); // &&& DoFindRaises(OtherCadList, aRaiseType, OtherRaise, aBeginPoint, OtherListIndex{aListIndex + 1}); end; // Tolik 07/02/2017 -- FreeAndNil(AllTrace); // end; end; end; begin if GlobalExit then begin FreeAndNil(RaisesList); Exit; end; if ResList.Count > 0 then ResList.Delete(ResList.Count - 1); // &&& if ResListOfLists.Count > 0 then ResListOfLists.Delete(ResListOfLists.Count - 1); // &&& // Tolik -- 08/02/2017 -- if RaisesList <> nil then FreeAndNil(RaisesList); if AllTrace <> nil then FreeAndNil(AllTrace); // Exit; // end; except on E: Exception do addExceptionToLogEx('U_Common.GetBetweenFloorRaises', E.Message); end; if RaisesList <> nil then FreeAndNil(RaisesList); if AllTrace <> nil then FreeAndNil(AllTrace); end; begin ResList := TList.Create; try ResListOfLists := TList.Create; ListIndex := aLists.Count - 1; ListID := aLists[0]; CurCad := GetListByID(ListID); GlobalExit := False; // &&& ResListOfLists.Add(CurCad); // &&& DoFindRaises(CurCad, aRaiseType, aBeginPoint, aEndPoint, 0); Result := ResList; aLists := CadsToIntCads(ResListOfLists); // Tolik 09/02/2017 -- FreeAndNil(ResListOfLists); // except on E: Exception do addExceptionToLogEx('U_Common.GetSortedListOfRaisesFromCurr', E.Message); end; end; Function IsBetweenFloorObject(AListID, AIDFigure: Integer; var AIDOtherFloorFigure: Integer): Boolean; var i, j: Integer; ItList, OtherList: TF_CAD; ItRaiseLine, OtherRaiseLine: TFigure; ItRaiseConn, OtherRaiseConn: TConnectorObject; begin Result := False; try AIDOtherFloorFigure := -1; ItList := GetListByID(AListID); if ItList <> nil then begin ItRaiseLine := GetFigureByID(ItList, AIDFigure); if ItRaiseLine <> nil then begin if CheckFigureByClassName(ItRaiseLine, cTOrthoLine) then begin if TOrthoLine(ItRaiseLine).FIsRaiseUpDown then begin ItRaiseConn := TConnectorObject(TOrthoLine(ItRaiseLine).JoinConnector1); if (ItRaiseConn.FConnRaiseType = crt_BetweenFloorUp) or (ItRaiseConn.FConnRaiseType = crt_BetweenFloorDown) or (ItRaiseConn.FConnRaiseType = crt_TrunkUp) or (ItRaiseConn.FConnRaiseType = crt_TrunkDown) then begin Result := True; OtherList := GetListByID(ItRaiseConn.FID_ListToPassage); if OtherList <> nil then begin OtherRaiseConn := TConnectorObject(GetFigureByID(OtherList, ItRaiseConn.FID_ConnToPassage)); if OtherRaiseConn <> nil then begin for i := 0 to OtherRaiseConn.JoinedOrtholinesList.Count - 1 do if TOrthoLine(OtherRaiseConn.JoinedOrtholinesList[i]).FIsRaiseUpDown then AIDOtherFloorFigure := TOrthoLine(OtherRaiseConn.JoinedOrtholinesList[i]).ID; end; end; end; ItRaiseConn := TConnectorObject(TOrthoLine(ItRaiseLine).JoinConnector2); if (ItRaiseConn.FConnRaiseType = crt_BetweenFloorUp) or (ItRaiseConn.FConnRaiseType = crt_BetweenFloorDown) or (ItRaiseConn.FConnRaiseType = crt_TrunkUp) or (ItRaiseConn.FConnRaiseType = crt_TrunkDown) then begin Result := True; OtherList := GetListByID(ItRaiseConn.FID_ListToPassage); if OtherList <> nil then begin OtherRaiseConn := TConnectorObject(GetFigureByID(OtherList, ItRaiseConn.FID_ConnToPassage)); if OtherRaiseConn <> nil then begin for i := 0 to OtherRaiseConn.JoinedOrtholinesList.Count - 1 do if TOrthoLine(OtherRaiseConn.JoinedOrtholinesList[i]).FIsRaiseUpDown then AIDOtherFloorFigure := TOrthoLine(OtherRaiseConn.JoinedOrtholinesList[i]).ID; end; end; end; end; end; end; end; except on E: Exception do addExceptionToLogEx('U_Common.IsBetweenFloorObject', E.Message); end; end; Function SetCADParamsStruct(aListParams: TListParams): TCADParams; begin try // Вкладка "Общие" Result.CADHeightRoom := aListParams.Settings.HeightRoom; Result.CADHeightFalseFloor := aListParams.Settings.HeightCeiling; Result.CADHeightConns := aListParams.Settings.HeightSocket; Result.CADHeightLines := aListParams.Settings.HeightCorob; Result.CADIndexPointObjects := aListParams.IndexPointObj + 1; Result.CADIndexConnector := aListParams.IndexConnector + 1; Result.CADIndexLine := aListParams.IndexLine + 1; // Вкладка "CAD" Result.CADPageSizeIndex := aListParams.Settings.CADPageSizeIndex; Result.CADPageOrient := aListParams.Settings.CADPageOrient; Result.CADStampType := aListParams.Settings.CADStampType; Result.CADStampLang := aListParams.Settings.CADStampLang; Result.CADStampMargins := aListParams.Settings.CADStampMargins; Result.CADWidth := aListParams.Settings.CADWidth; Result.CADHeight := aListParams.Settings.CADHeight; Result.CADListCountX := aListParams.Settings.CADListCountX; Result.CADListCountY := aListParams.Settings.CADListCountY; Result.CADFontName := aListParams.Settings.CADFontName; Result.CADGridStep := aListParams.Settings.CADGridStep; Result.CADShowMainStamp := aListParams.Settings.CADShowMainStamp; Result.CADShowUpperStamp := aListParams.Settings.CADShowUpperStamp; Result.CADShowSideStamp := aListParams.Settings.CADShowSideStamp; //Result.CADShowPathLineType := aListParams.Settings.CADShowPathLineType; //#From Oleg# //21.09.2010 //try // if (GCadForm <> nil) and (GCadForm.PCad <> nil) then // Result.CADMapScale := GCadForm.PCad.MapScale // else // Result.CADMapScale := 100; //except // Result.CADMapScale := 100; //end; Result.CADMapScale := 0; //21.09.2010 Result.CADTraceColor := aListParams.Settings.CADTraceColor; Result.CADTraceStyle := aListParams.Settings.CADTraceStyle; Result.CADTraceWidth := aListParams.Settings.CADTraceWidth; Result.CADBlockStep := aListParams.Settings.CADBlockStep; Result.CADObjectCaptions := aListParams.Settings.ShowObjectTypeCAD; Result.CADLinesCaptions := aListParams.Settings.CADCaptionsKind; Result.CADObjectNotes := aListParams.Settings.CADShowObjectNotesType; Result.CADLinesNotes := aListParams.Settings.CADNotesKind; Result.CADNotePrefix := aListParams.Settings.NoteCountPrefix; Result.CADShowLineObjectCaption := aListParams.Settings.ShowLineObjectCaption; Result.CADShowLineObjectLength := aListParams.Settings.ShowLineObjectLength; Result.CADShowLineObjectNote := aListParams.Settings.ShowLineObjectNote; Result.CADShowConnObjectCaption := aListParams.Settings.ShowConnObjectCaption; Result.CADShowConnObjectNote := aListParams.Settings.ShowConnObjectNote; Result.CADShowRaise := aListParams.Settings.CADShowRaise; Result.CADShowRaiseDrawFigure := aListParams.Settings.CADShowRaiseDrawFigure; Result.CADPutCableInTrace := aListParams.Settings.PutCableInTrace; Result.CADLinesCaptionsColor := aListParams.Settings.CADLinesCaptionsColor; Result.CADConnectorsCaptionsColor := aListParams.Settings.CADConnectorsCaptionsColor; Result.CADLinesNotesColor := aListParams.Settings.CADLinesNotesColor; Result.CADConnectorsNotesColor := aListParams.Settings.CADConnectorsNotesColor; Result.CADLinesCaptionsFontSize := aListParams.Settings.CADLinesCaptionsFontSize; Result.CADConnectorsCaptionsFontSize := aListParams.Settings.CADConnectorsCaptionsFontSize; Result.CADLinesNotesFontSize := aListParams.Settings.CADLinesNotesFontSize; Result.CADConnectorsNotesFontSize := aListParams.Settings.CADConnectorsNotesFontSize; Result.CADLinesCaptionsFontBold := aListParams.Settings.CADLinesCaptionsFontBold; Result.CADCrossATSFontSize := aListParams.Settings.CADCrossATSFontSize; Result.CADCrossATSFontBold := aListParams.Settings.CADCrossATSFontBold; Result.CADDistribCabFontSize := aListParams.Settings.CADDistribCabFontSize; Result.CADDistribCabFontBold := aListParams.Settings.CADDistribCabFontBold; Result.CADPrintType := aListParams.Settings.CADPrintType; Result.SCSType := aListParams.Settings.SCSType; Result.CADTraceStepRotate := aListParams.Settings.CADTraceStepRotate; Result.AutoCadMouse := aListParams.Settings.AutoCadMouse; Result.ScaleByCursor := aListParams.Settings.ScaleByCursor; Result.AutoPosTraceBetweenRM := aListParams.Settings.CADAutoPosTraceBetweenRM; Result.CADSaveUndoCount := aListParams.Settings.CADSaveUndoCount; Result.CADAllowSupplieskind := aListParams.Settings.CADAllowSuppliesKind; //11.10.2012 Result.CADNewTraceLengthType := aListParams.Settings.CADNewTraceLengthType; // Tolik -- 16/09/2016-- Result.CADShowRaiseHeights := aListParams.Settings.ShowRaiseHeights; // except on E: Exception do addExceptionToLogEx('U_Common.SetCADParamsStruct', E.Message); end; end; Procedure CheckByCaptionsNotes(X, Y: Double); var i, j: Integer; CheckCaptionNote: TFigure; CurrFigure: TFigure; FindSCSObject: TFigure; NotesCaptions: TRichTextMod; begin try FindSCSObject := nil; CheckCaptionNote := GCadForm.PCad.CheckByPoint(0, X, Y); // Caption if CheckCaptionNote <> nil then begin if CheckFigureByClassName(CheckCaptionNote, cTRichTextMod) then begin for i := 0 to GCadForm.PCad.FigureCount - 1 do begin CurrFigure := TFigure(GCadForm.PCad.Figures[i]); if CheckFigureByClassName(CurrFigure, cTConnectorObject) then if TConnectorObject(CurrFigure).CaptionsGroup <> nil then if TConnectorObject(CurrFigure).CaptionsGroup.ID = CheckCaptionNote.ID then FindSCSObject := CurrFigure; if CheckFigureByClassName(CurrFigure, cTOrthoLine) then if TOrthoLine(CurrFigure).CaptionsGroup <> nil then if TOrthoLine(CurrFigure).CaptionsGroup.ID = CheckCaptionNote.ID then FindSCSObject := CurrFigure; end; if FindSCSObject <> nil then begin FSCS_Main.aViewSCSObjectsProp.Checked := True; CheckCaptionNote.Deselect; OpenCaptionAtPos(FindSCSObject, TRichTextMod(CheckCaptionNote), X, Y); end; end; // Note if CheckFigureByClassName(CheckCaptionNote, cTFigureGrpNotMod) then begin for i := 0 to GCadForm.PCad.FigureCount - 1 do begin CurrFigure := TFigure(GCadForm.PCad.Figures[i]); if CheckFigureByClassName(CurrFigure, cTConnectorObject) then if TConnectorObject(CurrFigure).NotesGroup <> nil then if TConnectorObject(CurrFigure).NotesGroup.ID = CheckCaptionNote.ID then begin NotesCaptions := TRichTextMod(TFigureGrpNotMod(CheckCaptionNote).InFigures[1]); if NotesCaptions.isPointIn(X, Y) then FindSCSObject := CurrFigure; end; if CheckFigureByClassName(CurrFigure, cTOrthoLine) then if TOrthoLine(CurrFigure).NotesGroup <> nil then if TOrthoLine(CurrFigure).NotesGroup.ID = CheckCaptionNote.ID then begin NotesCaptions := TRichTextMod(TFigureGrpNotMod(CheckCaptionNote).InFigures[1]); if NotesCaptions.isPointIn(X, Y) then FindSCSObject := CurrFigure; end; end; if FindSCSObject <> nil then begin FSCS_Main.aViewSCSObjectsProp.Checked := True; CheckCaptionNote.Deselect; OpenNoteAtPos(FindSCSObject, TRichTextMod(TFigureGrpNotMod(CheckCaptionNote).InFigures[1]), X, Y); end; end; end; except on E: Exception do addExceptionToLogEx('U_Common.CheckByCaptionsNotes', E.Message); end; end; Procedure OpenCaptionAtPos(aObject: TFigure; aCaption: TRichTextMod; X, Y: Double); var i: Integer; Point: TPoint; Bnd: TDoubleRect; y1, y2: Double; height: double; Count: Integer; ItemSize: Double; DeltaPos: Double; SelItem: Integer; StartPos: Integer; begin try aObject.Select; RefreshCAD(GCadForm.PCad); GetCursorPos(Point); F_SCSObjectsProp.Left := Point.X; F_SCSObjectsProp.Top := Point.Y; F_SCSObjectsProp.Show; Bnd := aCaption.GetBoundRect; y1 := Bnd.Top; y2 := Bnd.Bottom; height := abs(Bnd.Bottom - Bnd.Top); Count := aCaption.re.Lines.Count; ItemSize := height / Count; DeltaPos := abs(Y - y1); SelItem := Round(DeltaPos / ItemSize); if CheckFigureByClassName(aObject, cTConnectorObject) then begin F_SCSObjectsProp.PageSCSObjects.ActivePageIndex := 0; F_SCSObjectsProp.ConnectorPropertiesForNormal(TConnectorObject(aObject).ConnectorType); F_SCSObjectsProp.LoadConnectorProperties(TConnectorObject(aObject)); F_SCSObjectsProp.bConnOK.Enabled := True; if F_SCSObjectsProp.mConnCaptionsGroup.Enabled then begin F_SCSObjectsProp.mConnCaptionsGroup.SetFocus; F_SCSObjectsProp.mConnCaptionsGroup.SelStart := 0; F_SCSObjectsProp.mConnCaptionsGroup.SelLength := 0; StartPos := 0; for i := 0 to SelItem - 1 do begin StartPos := StartPos + Length(F_SCSObjectsProp.mConnCaptionsGroup.Lines[i]); StartPos := StartPos + 2; end; F_SCSObjectsProp.mConnCaptionsGroup.SelStart := StartPos; if SelItem >= 0 then F_SCSObjectsProp.mConnCaptionsGroup.SelLength := length(F_SCSObjectsProp.mConnCaptionsGroup.Lines[SelItem]) + 1; end; end; if CheckFigureByClassName(aObject, cTOrthoLine) then begin F_SCSObjectsProp.PageSCSObjects.ActivePageIndex := 1; // если это с-п if TOrthoLine(aObject).FIsRaiseUpDown then begin F_SCSObjectsProp.OrtholinePropertiesForRaise; end else begin F_SCSObjectsProp.OrtholinePropertiesForNormal; end; F_SCSObjectsProp.LoadOrtholineProperties(TOrthoLine(aObject)); F_SCSObjectsProp.bLineOK.Enabled := True; if F_SCSObjectsProp.mLineCaptionsGroup.Enabled then begin if TOrthoLine(aObject).ShowLength then SelItem := SelItem - 1; F_SCSObjectsProp.mLineCaptionsGroup.SetFocus; F_SCSObjectsProp.mLineCaptionsGroup.SelStart := 0; F_SCSObjectsProp.mLineCaptionsGroup.SelLength := 0; StartPos := 0; for i := 0 to SelItem - 1 do begin StartPos := StartPos + Length(F_SCSObjectsProp.mLineCaptionsGroup.Lines[i]); StartPos := StartPos + 2; end; F_SCSObjectsProp.mLineCaptionsGroup.SelStart := StartPos; if SelItem >= 0 then F_SCSObjectsProp.mLineCaptionsGroup.SelLength := length(F_SCSObjectsProp.mLineCaptionsGroup.Lines[SelItem]) + 1; end; end; except on E: Exception do addExceptionToLogEx('U_Common.OpenCaptionAtPos', E.Message); end; end; Procedure OpenNoteAtPos(aObject: TFigure; aNote: TRichTextMod; X, Y: Double); var i: Integer; Point: TPoint; Bnd: TDoubleRect; y1, y2: Double; height: double; Count: Integer; ItemSize: Double; DeltaPos: Double; SelItem: Integer; StartPos: Integer; begin try aObject.Select; RefreshCAD(GCadForm.PCad); GetCursorPos(Point); F_SCSObjectsProp.Left := Point.X; F_SCSObjectsProp.Top := Point.Y; F_SCSObjectsProp.Show; Bnd := aNote.GetBoundRect; y1 := Bnd.Top; y2 := Bnd.Bottom; height := abs(Bnd.Bottom - Bnd.Top); Count := aNote.re.Lines.Count; ItemSize := height / Count; DeltaPos := abs(Y - y1); SelItem := Round(DeltaPos / ItemSize); if CheckFigureByClassName(aObject, cTConnectorObject) then begin F_SCSObjectsProp.PageSCSObjects.ActivePageIndex := 0; F_SCSObjectsProp.ConnectorPropertiesForNormal(TConnectorObject(aObject).ConnectorType); F_SCSObjectsProp.LoadConnectorProperties(TConnectorObject(aObject)); F_SCSObjectsProp.bConnOK.Enabled := True; if F_SCSObjectsProp.mConnCaptionsGroup.Enabled then begin F_SCSObjectsProp.mConnNotesGroup.SetFocus; F_SCSObjectsProp.mConnNotesGroup.SelStart := 0; F_SCSObjectsProp.mConnNotesGroup.SelLength := 0; StartPos := 0; for i := 0 to SelItem - 1 do begin StartPos := StartPos + Length(F_SCSObjectsProp.mConnNotesGroup.Lines[i]); StartPos := StartPos + 2; end; F_SCSObjectsProp.mConnNotesGroup.SelStart := StartPos; if SelItem >= 0 then F_SCSObjectsProp.mConnNotesGroup.SelLength := length(F_SCSObjectsProp.mConnNotesGroup.Lines[SelItem]) + 1; end; end; if CheckFigureByClassName(aObject, cTOrthoLine) then begin F_SCSObjectsProp.PageSCSObjects.ActivePageIndex := 1; // если это с-п if TOrthoLine(aObject).FIsRaiseUpDown then begin F_SCSObjectsProp.OrtholinePropertiesForRaise; end else begin F_SCSObjectsProp.OrtholinePropertiesForNormal; end; F_SCSObjectsProp.LoadOrtholineProperties(TOrthoLine(aObject)); F_SCSObjectsProp.bLineOK.Enabled := True; if F_SCSObjectsProp.mLineNotesGroup.Enabled then begin F_SCSObjectsProp.mLineNotesGroup.SetFocus; F_SCSObjectsProp.mLineNotesGroup.SelStart := 0; F_SCSObjectsProp.mLineNotesGroup.SelLength := 0; StartPos := 0; for i := 0 to SelItem - 1 do begin StartPos := StartPos + Length(F_SCSObjectsProp.mLineNotesGroup.Lines[i]); StartPos := StartPos + 2; end; F_SCSObjectsProp.mLineNotesGroup.SelStart := StartPos; if SelItem >= 0 then F_SCSObjectsProp.mLineNotesGroup.SelLength := length(F_SCSObjectsProp.mLineNotesGroup.Lines[SelItem]) + 1; end; end; except on E: Exception do addExceptionToLogEx('U_Common.OpenNotesAtPos', E.Message); end; end; procedure ModifyConnNoteAfterMove(aConn: TConnectorObject; aDeltaX, aDeltaY: Double); var NotesRows: TFigureGrpNotMod; Row1: TLine; Row2: TLine; ConnX, ConnY: Double; ResPointX, ResPointY: Double; begin try NotesRows := TFigureGrpNotMod(aConn.NotesGroup.InFigures[0]); Row1 := TLine(NotesRows.InFigures[0]); Row2 := TLine(NotesRows.InFigures[1]); // перерисовать стрелки Row2.ActualPoints[1] := DoublePoint(Row2.ActualPoints[1].x + adeltax, Row2.ActualPoints[1].y + adeltay); Row2.ActualPoints[2] := DoublePoint(Row2.ActualPoints[2].x + adeltax, Row2.ActualPoints[2].y + adeltay); Row1.ActualPoints[2] := Row2.ActualPoints[1]; // установить новый тип отображения стрелки ConnX := aConn.ActualPoints[1].x; ConnY := aConn.ActualPoints[1].y; ResPointX := Row1.ActualPoints[2].x; ResPointY := Row1.ActualPoints[2].y; if ResPointX >= ConnX then begin if ResPointY <= ConnY then aConn.FNotesRowsType := nr_UpRightSide else if ResPointY > ConnY then aConn.FNotesRowsType := nr_DownRightSide; end else if ResPointX < ConnX then begin if ResPointY >= ConnY then aConn.FNotesRowsType := nr_DownLeftSide else if ResPointY < ConnY then aConn.FNotesRowsType := nr_UpLeftSide; end; aConn.ReCreateNotesGroup(True); except on E: Exception do addExceptionToLogEx('U_Common.ModifyConnNoteAfterMove', E.Message); end; end; procedure ModifyLineNoteAfterMove(aLine: TOrthoLine; aDeltaX, aDeltaY: Double); var NotesRows: TFigureGrpNotMod; Row1: TLine; Row2: TLine; Row3: TLine; LineX, LineY: Double; ResPointX, ResPointY: Double; begin try NotesRows := TFigureGrpNotMod(aLine.NotesGroup.InFigures[0]); Row1 := TLine(NotesRows.InFigures[0]); Row2 := TLine(NotesRows.InFigures[1]); Row3 := TLine(NotesRows.InFigures[2]); // перерисовать стрелки Row3.ActualPoints[1] := DoublePoint(Row3.ActualPoints[1].x + adeltax, Row3.ActualPoints[1].y + adeltay); Row3.ActualPoints[2] := DoublePoint(Row3.ActualPoints[2].x + adeltax, Row3.ActualPoints[2].y + adeltay); Row2.ActualPoints[2] := Row3.ActualPoints[1]; // установить новый тип отображения стрелки LineX := Row2.ActualPoints[1].x; LineY := Row2.ActualPoints[1].y; ResPointX := Row2.ActualPoints[2].x; ResPointY := Row2.ActualPoints[2].y; if ResPointX >= LineX then begin if ResPointY <= LineY then aLine.FNotesRowsType := nr_UpRightSide else if ResPointY > LineY then aLine.FNotesRowsType := nr_DownRightSide; end else if ResPointX < LineX then begin if ResPointY >= LineY then aLine.FNotesRowsType := nr_DownLeftSide else if ResPointY < LineY then aLine.FNotesRowsType := nr_UpLeftSide; end; aLine.ReCreateNotesGroup(True); except on E: Exception do addExceptionToLogEx('U_Common.ModifyLineNoteAfterMove', E.Message); end; end; procedure SetFigureCoordZ(AIDList, AIDFigure: Integer; ACoordZ: Double); var vList: TF_CAD; SavedCadForm: TF_CAD; FFigure: TFigure; FConn: TConnectorObject; FLine: TOrthoLine; ObjFromRaise: TConnectorObject; mess: string; begin vList := GetListByID(AIDList); if vList <> nil then begin FFigure := GetFigureByID(vList, AIDFigure); if FFigure <> nil then begin SavedCadForm := GCadForm; GCadForm := vList; // RT if CheckFigureByClassName(FFigure, cTConnectorObject) then begin FConn := TConnectorObject(FFigure); // если высоты не совпадают - применить if FConn.ActualZOrder[1] <> ACoordZ then begin if ACoordZ <> - 1 then FConn.ActualZOrder[1] := ACoordZ else FConn.ActualZOrder[1] := vList.FConnHeight; // ================= // Он не с-п и на нем нет с-п if (FConn.FConnRaiseType = crt_None) and (GetRaiseConn(FConn) = nil) then begin if FConn.JoinedConnectorsList.Count = 0 then begin SetConFigureCoordZInPM(FConn.ID, FConn.ActualZOrder[1]); end else CreateRaiseOnPointObject(FConn, FConn.ActualZOrder[1]); end else // на нем есть с-п if GetRaiseConn(FConn) <> nil then begin // только подъем-спуск begin if FConn.JoinedConnectorsList.Count = 0 then begin SetConFigureCoordZInPM(FConn.ID, FConn.ActualZOrder[1]); end else ChangeRaiseOnPointObject(FConn, FConn.ActualZOrder[1]); end; end else // это с-п if (FConn.FConnRaiseType = crt_OnFloor) then begin ObjFromRaise := FConn.FObjectFromRaise; if FConn.ActualZOrder[1] = ObjFromRaise.ActualZOrder[1] then begin mess := cSCSObjectProp_Mes1; //if MessageBoxA(FSCS_Main.Handle, PAnsiChar(mess), cSCSObjectProp_Mes2, MB_YESNO) = IDYes then if MessageBox(FSCS_Main.Handle, PChar(mess), PChar(cSCSObjectProp_Mes2), MB_YESNO) = IDYes then begin if ObjFromRaise.ConnectorType = ct_Clear then DestroyRaiseOnConnector(ObjFromRaise) else DestroyRaiseOnPointObject(ObjFromRaise); end; end; end; end; end; // LINE if CheckFigureByClassName(FFigure, cTOrthoLine) then begin FLine := TOrthoLine(FFigure); if not FLine.FIsRaiseUpDown then begin // если высоты не совпадают - применить if (FLine.ActualZOrder[1] <> ACoordZ) or (FLine.ActualZOrder[2] <> ACoordZ) then begin if ACoordZ <> -1 then RaiseLineOnHeight(FLine, ACoordZ, nil) else RaiseLineOnHeight(FLine, vList.FLineHeight, nil) end; end; end; GCadForm := SavedCadForm; end; end; end; Function GetRaiseType(aObjFromRaise, aRaise: TConnectorObject): TLineRaiseType; var BaseHeight: Double; Height1: Double; Height2: Double; DeltaBaseDown, DeltaBaseUp: Double; begin Result := lrt_None; try DeltaBaseDown := 0; //#From Oleg# //14.09.2010 DeltaBaseUp := 0; //#From Oleg# //14.09.2010 BaseHeight := GCadForm.FLineHeight; Height1 := aObjFromRaise.ActualZOrder[1]; Height2 := aRaise.ActualZOrder[1]; if Height1 <> Height2 then begin // Один из объектов на базовой высотой if (Height1 = BaseHeight) or (Height2 = BaseHeight) then begin if Height1 = BaseHeight then begin if Height2 > BaseHeight then Result := lrt_Up; if Height2 < BaseHeight then Result := lrt_Down; end; if Height2 = BaseHeight then begin if Height1 > BaseHeight then Result := lrt_Up; if Height1 < BaseHeight then Result := lrt_Down; end; end else // вне базовой высоты begin // оба выше базы if (Height1 > BaseHeight) and (Height2 > BaseHeight) then begin Result := lrt_Up; end else // оба ниже базы if (Height1 < BaseHeight) and (Height2 < BaseHeight) then begin Result := lrt_Down; end else // по разные стороны базы if ((Height1 > BaseHeight) and (Height2 < BaseHeight)) or ((Height1 < BaseHeight) and (Height2 > BaseHeight)) then begin // delta над базовым уровнем if Height1 > BaseHeight then DeltaBaseUp := abs(BaseHeight - Height1); if Height2 > BaseHeight then DeltaBaseUp := abs(BaseHeight - Height2); // delta под базовым уровнем if Height1 < BaseHeight then DeltaBaseDown := abs(BaseHeight - Height1); if Height2 < BaseHeight then DeltaBaseDown := abs(BaseHeight - Height2); // if DeltaBaseUp >= DeltaBaseDown then Result := lrt_Up else Result := lrt_Down; end; end; end else Result := lrt_Up; except on E: Exception do addExceptionToLogEx('U_Common.GetRaiseType', E.Message); end; end; function GetLineCaptionFormat(aLine: TOrthoLine; aShowKind: TShowKind): string; var str: string; DblLen: Double; StrLen: String; DblHeight: Double; StrHeight: String; LineList: TSCSList; LineCad: TF_CAD; // Tolik --19/09/2016-- StrHeight1 : string; DblHeight1: Double; LineCatalog: TSCSCatalog; TopCatalog: TSCSCatalog; // begin try Result := ''; DblLen := aLine.LineLength; StrLen := FormatFloat(ffMask, MetreToUOM(DblLen)); if aShowKind = skSimple then begin if aLine.FIsRaiseUpDown then begin if aLine.FLineRaiseType = lrt_Down then Result := '-' + StrLen else Result := StrLen; end else Result := StrLen; end; if aShowKind = skdetail then begin if aLine.FIsRaiseUpDown then begin Result := StrLen; // Tolik -- здесь для райза будет по нулям -- нех выводить {DblHeight := aLine.FObjectFromRaisedLine.ActualZOrder[1]; StrHeight := FormatFloat(ffMask, MetreToUOM(DblHeight)); if aLine.FLineRaiseType = lrt_Down then Result := '-' + StrLen + '/' + StrHeight else Result := StrLen + '/' + StrHeight;} end else begin if aLine.ActualZOrder[1] = aLine.ActualZOrder[2] then begin DblHeight := aLine.ActualZOrder[1]; StrHeight := FormatFloat(ffMask, MetreToUOM(DblHeight)); Result := StrLen + '/' + StrHeight; end else Result := StrLen; end; end; if aShowKind = skExternalSCS then begin StrLen := FormatFloat(ffMask, MetreToUOM(DblLen)); Result := '-' + StrLen + '-'; end; // Tolik -*- 16/09/2016-- // если вдруг показывать разницу высот для райза if aLine.FIsRaiseUpDown then begin //LineCad := TF_Cad(TPowerCad(aLine.Owner).Owner); // if LineCaD <> nil then LineCatalog := F_ProjMan.GSCSBase.CurrProject.GetCatalogFromReferencesBySCSID(aLine.Id); if LineCatalog <> nil then begin LineList := LineCatalog.GetListOwner; if LineList <> nil then begin if LineList.Setting.ShowRaiseHeights then begin if (aLine.JoinConnector1 <> nil) and (aLine.JoinConnector2 <> nil ) then begin DblHeight := TConnectorObject(aLine.JoinConnector1).ActualZOrder[1]; StrHeight := FormatFloat(ffMask, MetreToUOM(DblHeight)); DblHeight1 := TConnectorObject(aLine.JoinConnector2).ActualZOrder[1]; StrHeight1 := FormatFloat(ffMask, MetreToUOM(DblHeight1)); if CompareValue(DblHeight, DblHeight1) = -1 then Result := strLen + ' /' + StrHeight + '-' + StrHeight1 else Result := strLen + ' /' + StrHeight1 + '-' + StrHeight; end; end; end; end; end; except on E: Exception do addExceptionToLogEx('U_Common.GetLineCaptionFormat', E.Message); end; end; Function GetFullFigureName(aFigure: TFigure; x: Double=-1; y: Double=-1): string; var strName: string; strIndex: string; ChildObject: TObject; begin try Result := ''; Result := aFigure.Name; if CheckFigureByClassName(aFigure, cTConnectorObject) then begin strName := TConnectorObject(aFigure).Name; strIndex := IntToStr(TConnectorObject(aFigure).FIndex); Result := strName + strIndex; end; if CheckFigureByClassName(aFigure, cTOrthoLine) then begin strName := TOrthoLine(aFigure).Name; {$IF Defined(SCS_PE) or Defined(SCS_PANDUIT)} Result := strName; {$ELSE} strIndex := IntToStr(TOrthoLine(aFigure).FIndex); Result := strName + strIndex; {$IFEND} end else if aFigure is TNet then begin ChildObject := nil; if (x<>-1) and (y<>-1) then ChildObject := TNet(aFigure).GetObjInPoint(x,y) else if aFigure.Selected then ChildObject := TNet(aFigure).GetSelectedObject; Result := GetArchCADObjCaption(aFigure, ChildObject, cMain_Mes107); //if ChildObject <> aFigure then //begin // ChildName := GetArchCADObjCaption(ChildObject, ''); // if ChildName <> '' then // begin // if Result <> '' then // Result := Result + ', '; // Result := Result + ChildName; // end; //end; end; except // on E: Exception do addExceptionToLogEx('U_Common.GetFullFigureName', E.Message); end; end; function GetFullFigureLenName(aFigure: TFigure; x: Double=-1; y: Double=-1): string; var ChildObject: TObject; begin Result := ''; if aFigure is TNet then begin ChildObject := nil; if (x<>-1) and (y<>-1) then ChildObject := TNet(aFigure).GetObjInPoint(x,y) else if aFigure.Selected then ChildObject := TNet(aFigure).GetSelectedObject; Result := GetArchCADObjLenCaption(aFigure, ChildObject); end; end; Procedure AutoDisconnectOverRaiseInCAD(AConnector, ARaiseConnector: TConnectorObject; ARaiseLine: TOrthoLine); var Connector: TConnectorObject; RaiseConnector: TConnectorObject; JoinedConn: TConnectorObject; ConnectedLines: TList; ConnectedBeforeRaise: TList; ConnectedAfterRaise: TList; procedure DefineConnectedObjectParams(ATargetConnectedObjectParams: TList; AConnectorObject: TConnectorObject); var i, j: Integer; JoinedLine: TOrthoLine; JoinedConn: TConnectorObject; ptrConnectObjParam: PConnectObjectParam; begin try New(ptrConnectObjParam); ptrConnectObjParam.IDObject := AConnectorObject.ID; ptrConnectObjParam.Side := 0; ATargetConnectedObjectParams.Add(ptrConnectObjParam); if AConnectorObject.ConnectorType = ct_Clear then for i := 0 to AConnectorObject.JoinedOrtholinesList.Count - 1 do begin JoinedLine := TOrthoLine(AConnectorObject.JoinedOrtholinesList[i]); if JoinedLine <> ARaiseLine then begin New(ptrConnectObjParam); ptrConnectObjParam.IDObject := JoinedLine.ID; if JoinedLine.JoinConnector1 = AConnectorObject then ptrConnectObjParam.Side := 1; if JoinedLine.JoinConnector2 = AConnectorObject then ptrConnectObjParam.Side := 2; ATargetConnectedObjectParams.Add(ptrConnectObjParam); end; end else begin for i := 0 to AConnectorObject.JoinedConnectorsList.Count - 1 do begin JoinedConn := TConnectorObject(AConnectorObject.JoinedConnectorsList[i]); for j := 0 to JoinedConn.JoinedOrtholinesList.Count - 1 do begin JoinedLine := TOrthoLine(JoinedConn.JoinedOrtholinesList[j]); if JoinedLine <> ARaiseLine then begin New(ptrConnectObjParam); ptrConnectObjParam.IDObject := JoinedLine.ID; if JoinedLine.JoinConnector1 = JoinedConn then ptrConnectObjParam.Side := 1; if JoinedLine.JoinConnector2 = JoinedConn then ptrConnectObjParam.Side := 2; ATargetConnectedObjectParams.Add(ptrConnectObjParam); end; end; end; end; except on E: Exception do addExceptionToLogEx('U_Common.DefineConnectedObjectParams', E.Message); end; end; begin try ConnectedBeforeRaise := TList.Create; ConnectedAfterRaise := TList.Create; Connector := AConnector; RaiseConnector := ARaiseConnector; if (ARaiseConnector.FConnRaiseType = crt_None) and (AConnector.FConnRaiseType <> crt_None) then begin Connector := ARaiseConnector; RaiseConnector := AConnector; end; // AConnector DefineConnectedObjectParams(ConnectedBeforeRaise, Connector); // ARaiseConnector DefineConnectedObjectParams(ConnectedAfterRaise, RaiseConnector); AutoDisconnectOverRaiseLine(ARaiseLine.ID, ConnectedBeforeRaise, ConnectedAfterRaise); // Tolik 21/12/2019 -- { if ConnectedBeforeRaise <> nil then FreeList(ConnectedBeforeRaise); if ConnectedAfterRaise <> nil then FreeList(ConnectedAfterRaise); } FreeAndDisposeList(ConnectedBeforeRaise); FreeAndDisposeList(ConnectedAfterRaise); // except on E: Exception do addExceptionToLogEx('U_Common.AutoDisconnectOverRaiseInCAD', E.Message); end; end; Procedure EditBlockOnCAD(aActiveBlockStream, aProjectBlockStream: TMemoryStream); var ActBlockFileName, ProjBlockFileName: string; BlockFig: TBlock; i: integer; Bnd: TDoubleRect; x, y: double; begin try {$if Defined(ES_GRAPH_SC)} ActBlockFileName := ExeDir + '\.blk\ActBlockTempStream.blk'; ProjBlockFileName := ExeDir + '\.blk\ProjBlockTempStream.blk'; {$else} ActBlockFileName := ExtractFileDir(Application.ExeName) + '\.blk\ActBlockTempStream.blk'; ProjBlockFileName := ExtractFileDir(Application.ExeName) + '\.blk\ProjBlockTempStream.blk'; {$ifend} if aActiveBlockStream <> nil then begin aActiveBlockStream.SaveToFile(ActBlockFileName); GCadForm.CurrentLayer := 1; BlockFig := TBlock(GCadForm.PCad.InsertBlockwithFileName(1, ActBlockFileName, 0, 0)); Bnd := BlockFig.GetBoundRect; x := abs(Bnd.Right - Bnd.Left); y := abs(Bnd.Bottom - Bnd.Top); BlockFig.move(x / 2, y / 2); end; if aProjectBlockStream <> nil then begin aProjectBlockStream.SaveToFile(ProjBlockFileName); GCadForm.CurrentLayer := 1; BlockFig := TBlock(GCadForm.PCad.InsertBlockwithFileName(1, ProjBlockFileName, 10, 0)); Bnd := BlockFig.GetBoundRect; x := abs(Bnd.Right - Bnd.Left); y := abs(Bnd.Bottom - Bnd.Top); BlockFig.move(x / 2, y / 2); end; RefreshCAD(GCadForm.PCad); if FileExists(ActBlockFileName) then DeleteFile(ActBlockFileName); if FileExists(ProjBlockFileName) then DeleteFile(ProjBlockFileName); except on E: Exception do addExceptionToLogEx('U_Common.EditBlockOnCAD', E.Message); end; end; (*procedure RemoveRMWithRM(aRM1, aRM2: TConnectorObject); var i, j: integer; JoinedConn: TConnectorObject; JoinedLine: TOrthoLine; ConnectedConn: TConnectorObject; ConnectedList: TList; // begin try ConnectedConn := nil; //#From Oleg# //14.09.2010 ConnectedList := TList.Create; // опр. связуюший с с-п for i := 0 to aRM1.JoinedConnectorsList.Count - 1 do begin JoinedConn := TConnectorObject(aRM1.JoinedConnectorsList[i]); for j := 0 to JoinedConn.JoinedOrtholinesList.Count - 1 do if TOrthoLine(JoinedConn.JoinedOrtholinesList[j]).FIsRaiseUpDown then ConnectedConn := JoinedConn; end; if ConnectedConn = nil then Exit; // сохранить коннекторы for i := 0 to aRM1.JoinedConnectorsList.Count - 1 do begin JoinedConn := TConnectorObject(aRM1.JoinedConnectorsList[i]); ConnectedList.Add(JoinedConn); end; { DublicateObjectComponents(aRM1.ID, aRM2.ID); } // отвязать все for i := 0 to ConnectedList.Count - 1 do begin // Tolik -- 11/06/2016 -- if ((not Joinedconn.Deleted) and (not aRM1.Deleted)) then begin // JoinedConn := TConnectorObject(ConnectedList[i]); UnsnapConnectorFromPointObject(JoinedConn, aRM1); end; end; // Tolik -- 11/06/2016 -- // здесь нужен не дубликат, а перенос компонетов из одного объекта в другой SrcCatalog := F_ProjMan.GSCSBase.CurrProject.CurrList.GetCatalogFromReferencesBySCSID(aRM1.ID); TargetCatalog := F_ProjMan.GSCSBase.CurrProject.CurrList.GetCatalogFromReferencesBySCSID(aRM2.ID); if ((SrcCatalog <> nil) and (TargetCatalog <> nil)) then begin TargetNode := F_ProjMan.GetNodeByObj(TargetCatalog); if TargetNode <> nil then begin for i := 0 to SrcCatalog.SCSComponents.Count - 1 do begin SCSComponent := TSCSComponent(SrcCatalog.SCSComponents[i]); SrcNode := F_ProjMan.GetNodeByObj(SCSComponent); if SrcNode <> nil then F_ProjMan.MoveDir(SrcNode, TargetNode); end; end; end; for i := 0 to ConnectedList.Count - 1 do begin JoinedConn := TConnectorObject(ConnectedList[i]); // Tolik 11/06/2016 -- if ((not JoinedConn.Deleted) and (not ConnectedConn.Deleted)) then begin if JoinedConn <> ConnectedConn then begin SnapConnectorToConnector(ConnectedConn, JoinedConn); // ConnectedConn := JoinedConn; end; end; end; // Tolik 11/06/2016 -- if not ConnectedConn.deleted then begin // if not aRM1.deleted then begin ConnectedConn.FConnRaiseType := aRM1.FConnRaiseType; ConnectedConn.FObjectFromRaise := aRM1.FObjectFromRaise; end else // ConnectedConn.FConnRaiseType := aRm2.FConnRaiseType; ConnectedConn.FConnRaiseType := crt_None; ConnectedConn.FObjectFromRaise := nil; end; // Tolik 11/06/2016 -- if (not aRm1.deleted) and (not aRM2.Deleted) and (not ConnectedConn.deleted) then // if aRM2.FObjectFromRaise = aRM1 then aRM2.FObjectFromRaise := ConnectedConn; if aRM1.deleted then aRm2.FObjectFromRaise := ConnectedConn; // Tolik 11/06/2016 -- if not aRM2.Deleted then // begin for i := 0 to aRM2.JoinedConnectorsList.Count - 1 do begin JoinedConn := TConnectorObject(aRM2.JoinedConnectorsList[i]); // Tolik 11/06/2016 -- if (not Joinedconn.deleted) then // begin for j := 0 to JoinedConn.JoinedOrtholinesList.Count - 1 do begin if TOrthoLine(JoinedConn.JoinedOrtholinesList[j]).FIsRaiseUpDown then begin if not aRm1.deleted then begin if TOrthoLine(JoinedConn.JoinedOrtholinesList[j]).FObjectFromRaisedLine = aRM1 then if not ConnectedConn.deleted then TOrthoLine(JoinedConn.JoinedOrtholinesList[j]).FObjectFromRaisedLine := ConnectedConn; end else if not ConnectedConn.deleted then TOrthoLine(JoinedConn.JoinedOrtholinesList[j]).FObjectFromRaisedLine := ConnectedConn; end; end; end; end; end; // Tolik 11/06/2016 -- if not aRM1.deleted then // begin aRM1.FConnRaiseType := crt_None; aRM1.FObjectFromRaise := nil; end; //Tolik -- 11/06/20106 -- //aRM1.Delete(False, False); // RefreshCAD(GCadForm.PCad); FreeAndNil(ConnectedList); // Tolik 11/06/2016 -- if not aRM2.Deleted then begin if aRM2.FConnRaiseType <> crt_None then begin ReverseRaise(aRM2); end; end; except on E: Exception do addExceptionToLogEx('U_Common.RemoveRMWithRM', E.Message); end; end; *) procedure RemoveRMWithRM(aRM1, aRM2: TConnectorObject); var i, j: integer; JoinedConn: TConnectorObject; JoinedLine: TOrthoLine; ConnectedConn: TConnectorObject; ConnectedList: TList; // Tolik -- 11/06/20106 -- SrcCatalog, TargetCatalog : TSCSCatalog; SrcNode, TargetNode: TTreeNode; SCSComponent: TSCSComponent; begin ConnectedList := TList.Create; try ConnectedConn := nil; //#From Oleg# //14.09.2010 // опр. связуюший с с-п for i := 0 to aRM1.JoinedConnectorsList.Count - 1 do begin JoinedConn := TConnectorObject(aRM1.JoinedConnectorsList[i]); for j := 0 to JoinedConn.JoinedOrtholinesList.Count - 1 do if TOrthoLine(JoinedConn.JoinedOrtholinesList[j]).FIsRaiseUpDown then ConnectedConn := JoinedConn; end; if ConnectedConn = nil then begin ConnectedList.Free; // Tolik 15/05/2018 -- утечка памяти Exit; end; // сохранить коннекторы for i := 0 to aRM1.JoinedConnectorsList.Count - 1 do begin JoinedConn := TConnectorObject(aRM1.JoinedConnectorsList[i]); ConnectedList.Add(JoinedConn); end; // DublicateObjectComponents(aRM1.ID, aRM2.ID); // отвязать все for i := 0 to ConnectedList.Count - 1 do begin JoinedConn := TConnectorObject(ConnectedList[i]); UnsnapConnectorFromPointObject(JoinedConn, aRM1); end; for i := 0 to ConnectedList.Count - 1 do begin JoinedConn := TConnectorObject(ConnectedList[i]); if JoinedConn <> ConnectedConn then begin // SnapConnectorToConnector(ConnectedConn, JoinedConn); // Tolik 29/03/2018 -- //ConnectedConn := SnapConnectorToConnector(ConnectedConn, JoinedConn); CheckingSnapConnectorToConnector(ConnectedConn, JoinedConn); // // ConnectedConn := JoinedConn; end; end; ConnectedConn.FConnRaiseType := aRM1.FConnRaiseType; ConnectedConn.FObjectFromRaise := aRM1.FObjectFromRaise; if aRM2.FObjectFromRaise = aRM1 then aRM2.FObjectFromRaise := ConnectedConn; for i := 0 to aRM2.JoinedConnectorsList.Count - 1 do begin JoinedConn := TConnectorObject(aRM2.JoinedConnectorsList[i]); for j := 0 to JoinedConn.JoinedOrtholinesList.Count - 1 do begin if TOrthoLine(JoinedConn.JoinedOrtholinesList[j]).FIsRaiseUpDown then if TOrthoLine(JoinedConn.JoinedOrtholinesList[j]).FObjectFromRaisedLine = aRM1 then TOrthoLine(JoinedConn.JoinedOrtholinesList[j]).FObjectFromRaisedLine := ConnectedConn; end; end; aRM1.FConnRaiseType := crt_None; aRM1.FObjectFromRaise := nil; // Tolik -- 11/06/2016 -- //aRM1.Delete(False, False); // здесь нужен не дубликат, а перенос компонетов из одного объекта в другой SrcCatalog := F_ProjMan.GSCSBase.CurrProject.CurrList.GetCatalogFromReferencesBySCSID(aRM1.ID); TargetCatalog := F_ProjMan.GSCSBase.CurrProject.CurrList.GetCatalogFromReferencesBySCSID(aRM2.ID); if ((SrcCatalog <> nil) and (TargetCatalog <> nil)) then begin TargetNode := F_ProjMan.GetNodeByObj(TargetCatalog); if TargetNode <> nil then begin for i := 0 to SrcCatalog.SCSComponents.Count - 1 do begin SCSComponent := TSCSComponent(SrcCatalog.SCSComponents[i]); SrcNode := F_ProjMan.GetNodeByObj(SCSComponent); if SrcNode <> nil then F_ProjMan.MoveDir(SrcNode, TargetNode); end; end; end; // RefreshCAD(GCadForm.PCad); if aRM2.FConnRaiseType <> crt_None then begin ReverseRaise(aRM2); end; except on E: Exception do addExceptionToLogEx('U_Common.RemoveRMWithRM', E.Message); end; FreeAndNil(ConnectedList); end; procedure RemoveRMWithClear(aRM, aClear: TConnectorObject); var i, j, k, l: integer; JoinedConn: TConnectorObject; ConnectedConn: TConnectorObject; ConnectedList: TList; TestLine: TOrthoLine; // Tolik ComponToDeleteList: TSCSComponents; RaiseCatalog: TSCSCatalog; PointCatalog: TSCSCatalog; RaiseLine : TOrthoLine; LineComponent, JoinedComponent: TSCSComponent; // begin ConnectedList := TList.Create; //Tolik -- 15/05/2018 -- try //Tolik -- 15/05/2018 -- //ConnectedConn := nil; //#From Oleg# //14.09.2010 //ConnectedList := TList.Create; // // опр. связуюший с с-п for i := 0 to aRM.JoinedConnectorsList.Count - 1 do begin JoinedConn := TConnectorObject(aRM.JoinedConnectorsList[i]); for j := 0 to JoinedConn.JoinedOrtholinesList.Count - 1 do if TOrthoLine(JoinedConn.JoinedOrtholinesList[j]).FIsRaiseUpDown then ConnectedConn := JoinedConn; end; if ConnectedConn = nil then begin ConnectedList.Free; ///Tolik -- 15/05/2018 -- Exit; end; // сохранить коннекторы for i := 0 to aRM.JoinedConnectorsList.Count - 1 do begin JoinedConn := TConnectorObject(aRM.JoinedConnectorsList[i]); ConnectedList.Add(JoinedConn); end; // Tolik -- 27/05/2016 -- // удалить кабель c райза { if ConnectedList.count > 0 then begin PointCatalog := F_ProjMan.GSCSBase.CurrProject.CurrList.GetCatalogFromReferencesBySCSID(aRM.ID); if PointCatalog <> nil then begin ComponToDeleteList := TSCSComponents.Create(False); RaiseLine := nil; for i := 0 to ConnectedList.count - 1 do begin for j := 0 to TConnectorObject(ConnectedList[i]).JoinedOrtholinesList.count - 1 do begin if TOrthoLine(TConnectorObject(ConnectedList[i]).JoinedOrtholinesList[j]).FIsRaiseUpDown then begin RaiseLine := TOrthoLine(TConnectorObject(ConnectedList[i]).JoinedOrtholinesList[j]); if not RaiseLine.Deleted then begin RaiseCatalog := F_ProjMan.GSCSBase.CurrProject.CurrList.GetCatalogFromReferencesBySCSID(RaiseLine.ID); if RaiseCatalog <> nil then begin for k := 0 to RaiseCatalog.ComponentReferences.Count - 1 do begin LineComponent := TSCSComponent(RaiseCatalog.ComponentReferences[k]); if IsCableComponent(LineComponent) then begin for l := 0 to LineComponent.JoinedComponents.Count - 1 do begin JoinedComponent := TSCSComponent(LineComponent.JoinedComponents[l]); if PointCatalog.ComponentReferences.IndexOf(JoinedComponent) <> -1 then begin ComponToDeleteList.Add(LineComponent); break; end; end; end; end; end; end; end; end; end; if ComponToDeleteList.Count > 0 then begin F_ProjMan.DelComponentsFromList(F_ProjMan.GSCSBase.CurrProject.CurrList, ComponToDeleteList, False); ComponToDeleteList.Clear; end; end; end; ComponToDeleteList.Clear; FreeAndNil(ComponToDeleteList); } // // отвязать все for i := 0 to ConnectedList.Count - 1 do begin JoinedConn := TConnectorObject(ConnectedList[i]); UnsnapConnectorFromPointObject(JoinedConn, aRM); end; for i := 0 to ConnectedList.Count - 1 do begin JoinedConn := TConnectorObject(ConnectedList[i]); if JoinedConn <> ConnectedConn then begin // SnapConnectorToConnector(ConnectedConn, JoinedConn); // Tolik 29/03/2018 -- //ConnectedConn := SnapConnectorToConnector(ConnectedConn, JoinedConn); CheckingSnapConnectorToConnector(ConnectedConn, JoinedConn); // // ConnectedConn := JoinedConn; end; end; ConnectedConn.FConnRaiseType := aRM.FConnRaiseType; if aClear.FObjectFromRaise = aRM then aClear.FObjectFromRaise := ConnectedConn; for i := 0 to aClear.JoinedOrtholinesList.Count - 1 do if TOrthoLine(aClear.JoinedOrtholinesList[i]).FIsRaiseUpDown then if TOrthoLine(aClear.JoinedOrtholinesList[i]).FObjectFromRaisedLine = aRM then TOrthoLine(aClear.JoinedOrtholinesList[i]).FObjectFromRaisedLine := ConnectedConn; aRM.FConnRaiseType := crt_None; aRM.FObjectFromRaise := nil; SnapPointObjectToConnector(aRM, aClear); aClear.LockMove := False; aClear.LockModify := False; aClear.Move(aRM.ActualPoints[1].x - aClear.ActualPoints[1].x, aRM.ActualPoints[1].y - aClear.ActualPoints[1].y); RefreshCAD(GCadForm.PCad); if aRM.FConnRaiseType <> crt_None then begin ReverseRaise(aRM); end; except on E: Exception do addExceptionToLogEx('U_Common.RemoveRMWithClear', E.Message); end; FreeAndNil(ConnectedList); end; procedure ReverseRaise(aPointObject: TConnectorObject); var i: integer; ObjFromRaise: TConnectorObject; RaiseLine: TOrthoLine; ObjParams: TObjectParams; begin try RaiseLine := nil; //#From Oleg# //14.09.2010 if aPointObject.FObjectFromRaise = nil then Exit; if aPointObject.FObjectFromRaise.ConnectorType <> ct_Clear then Exit; ObjFromRaise := aPointObject.FObjectFromRaise; ObjFromRaise.FConnRaiseType := aPointObject.FConnRaiseType; aPointObject.FConnRaiseType := crt_None; ObjFromRaise.FObjectFromRaise := aPointObject; aPointObject.FObjectFromRaise := nil; ObjFromRaise.LockModify := True; ObjFromRaise.LockMove := True; aPointObject.LockModify := False; aPointObject.LockMove := False; for i := 0 to ObjFromRaise.JoinedOrtholinesList.Count - 1 do if TOrthoLine(ObjFromRaise.JoinedOrtholinesList[i]).FIsRaiseUpDown then begin RaiseLine := TOrthoLine(ObjFromRaise.JoinedOrtholinesList[i]); if RaiseLine.FObjectFromRaisedLine = ObjFromRaise then RaiseLine.FObjectFromRaisedLine := aPointObject; end; if RaiseLine <> nil then begin RaiseLine.ReCreateCaptionsGroup(false, true); RaiseLine.ReCreateNotesGroup; end; ObjFromRaise.Name := cCadClasses_Mes24; SetNewObjectNameInPM(ObjFromRaise.ID, ObjFromRaise.Name); ObjParams := GetFigureParams(ObjFromRaise.ID); ObjFromRaise.Name := ObjParams.Name; ObjFromRaise.FIndex := ObjParams.MarkID; GMoveWithRaise := False; ObjFromRaise.Move(aPointObject.ActualPoints[1].x - ObjFromRaise.ActualPoints[1].x, aPointObject.ActualPoints[1].y - ObjFromRaise.ActualPoints[1].y); GMoveWithRaise := True; RefreshCAD(GCadForm.PCad); except on E: Exception do addExceptionToLogEx('U_Common.ReverseRaise', E.Message); end; end; function CheckListNormalType(aListID: Integer): Boolean; var List: TF_CAD; begin Result := False; try List := GetListByID(aListID); if List <> nil then begin if List.FListType = lt_Normal then Result := True else Result := False; end; except on E: Exception do addExceptionToLogEx('U_Common.CheckListNormalType', E.Message); end; end; procedure CallProjectPlanFromNB; begin try FSCS_Main.aCreateProjectPlan.Execute; except on E: Exception do addExceptionToLogEx('U_ProjectPlan.CallProjectPlanFromNB', E.Message); end; end; procedure CreateCabinetOnCAD(aSCSID, aIndex: Integer); var Cabinet: TCabinet; Bnd: TDoubleRect; P1: TPoint; P2: TPoint; CP: TPoint; LHandle: Integer; begin try // создание с МП if (GCadForm <> nil) and (GCadForm.PCad <> nil) then begin FSCS_Main.aToolCabinet.Execute; LHandle := GCadForm.PCad.GetLayerHandle(9); Bnd := GCadForm.PCad.GetVisibleRect; P1.X := Round(Bnd.Left); P1.Y := Round(bnd.Top); P2.X := Round(Bnd.Right); P2.Y := Round(bnd.Bottom); CP.X := Round((P1.x + P2.x) / 2); CP.Y := Round((P1.y + P2.y) / 2); Cabinet := TCabinet.Create(CP.X, CP.Y, CP.X + 80, CP.Y + 40, 2, ord(psSolid), clMaroon, ord(bsClear), clBlack, LHandle, mydsNormal, GCadForm.PCad); Cabinet.FSCSID := aSCSID; Cabinet.ID := aSCSID; //08.11.2011 Cabinet.FIndex := aIndex; Cabinet.Visible := True; Cabinet.FType := ct_Visual; Cabinet.FNumberObject := CreateNumberObjectOnCAD(Cabinet, GCadForm.FShowCabinetsNumbers); GCadForm.Pcad.AddCustomFigure(9, Cabinet, False); GCadForm.AddSCSFigure(Cabinet); CP.X := CP.X + 80; CP.Y := CP.Y + 40; ClientToScreen(GCadForm.PCad.Handle, CP); SetCursorPos(CP.X, CP.Y); end; except on E: Exception do addExceptionToLogEx('U_Common.CreateCabinetOnCAD', E.Message); end; end; procedure DeleteCabinetOnCAD(AID_List, aSCSID: Integer); var Cabinet: TFigure; vList: TF_CAD; CabinetNumberObject: TCabinetNumber; aFigure: TFigure; j: INteger; begin try vList := GetListByID(AID_List); if vList <> nil then begin Cabinet := FindCabinetBySCSID(vList, aSCSID); if Cabinet <> nil then begin //Tolik // так было { if CheckFigureByClassName(Cabinet, cTCabinet) then CabinetNumberObject := TCabinet(Cabinet).FNumberObject; if CheckFigureByClassName(Cabinet, cTCabinetExt) then CabinetNumberObject := TCabinetExt(Cabinet).FNumberObject; if CabinetNumberObject <> nil then begin vList.PCad.Figures.Remove(CabinetNumberObject); FreeAndNil(CabinetNumberObject); end; vList.PCad.Figures.Remove(Cabinet); FreeAndNil(Cabinet); RefreshCAD(vList.PCad);} // ИМХО может быть неправильное, но, по-моему, можно так: if CheckFigureByClassName(Cabinet, cTCabinet) then TCabinet(Cabinet).delete; if CheckFigureByClassName(Cabinet, cTCabinetExt) then TCabinetExt(Cabinet).Delete; // end; end; except on E: Exception do addExceptionToLogEx('U_Common.DeleteCabinetOnCAD', E.Message); end; end; procedure ActivateCabinetOnCAD(AID_List, aSCSID: Integer); var Cabinet: TFigure; vList: TF_CAD; begin try vList := GetListByID(AID_List); if vList <> nil then begin if not vList.FShowCabinetsBounds then begin Cabinet := FindCabinetBySCSID(vList, aSCSID); if Cabinet <> nil then begin if CheckFigureByClassName(Cabinet, cTCabinet) then begin TCabinet(Cabinet).Visible := True; TCabinet(Cabinet).Draw(vList.PCad.DEngine, False); end; if CheckFigureByClassName(Cabinet, cTCabinetExt) then begin TCabinetExt(Cabinet).Visible := True; TCabinetExt(Cabinet).Draw(vList.PCad.DEngine, False); end; RefreshCAD(vList.PCad); end; end; end; except on E: Exception do addExceptionToLogEx('U_Common.ActivateCabinetOnCAD', E.Message); end; end; procedure DeactivateCabinetOnCAD(AID_List, aSCSID: Integer); var Cabinet: TFigure; vList: TF_CAD; begin try vList := GetListByID(AID_List); if vList <> nil then begin if not vList.FShowCabinetsBounds then begin Cabinet := FindCabinetBySCSID(vList, aSCSID); if Cabinet <> nil then begin if Cabinet.Selected then Cabinet.Deselect; if CheckFigureByClassName(Cabinet, cTCabinet) then begin TCabinet(Cabinet).Visible := False; TCabinet(Cabinet).Draw(vList.PCad.DEngine, False); if TCabinet(Cabinet).FNumberObject <> nil then if TCabinet(Cabinet).FNumberObject.Visible then if TCabinet(Cabinet).FNumberObject.Selected then TCabinet(Cabinet).FNumberObject.Deselect; end; if CheckFigureByClassName(Cabinet, cTCabinetExt) then begin TCabinetExt(Cabinet).Visible := False; TCabinetExt(Cabinet).Draw(vList.PCad.DEngine, False); if TCabinetExt(Cabinet).FNumberObject <> nil then if TCabinetExt(Cabinet).FNumberObject.Visible then if TCabinetExt(Cabinet).FNumberObject.Selected then TCabinetExt(Cabinet).FNumberObject.Deselect; end; RefreshCAD(vList.PCad); end; end; end; except on E: Exception do addExceptionToLogEx('U_Common.DeactivateCabinetOnCAD', E.Message); end; end; function FindCabinetBySCSID(aList: TF_CAD; aSCSID: Integer): TFigure; var i: integer; Figure: TFigure; FigLayerHandle: Integer; begin Result := nil; try FigLayerHandle := aList.PCad.GetLayerHandle(lnRoom); for i := 0 to aList.PCad.FigureCount - 1 do begin Figure := TFigure(aList.PCad.Figures[i]); if (Figure.LayerHandle = FigLayerHandle) then begin if CheckFigureByClassName(Figure, cTCabinet) then begin if TCabinet(Figure).FSCSID = aSCSID then begin Result := Figure; Break; end; end else if CheckFigureByClassName(Figure, cTCabinetExt) then begin if TCabinetExt(Figure).FSCSID = aSCSID then begin Result := Figure; Break; end; end; end; end; except on E: Exception do addExceptionToLogEx('U_Common.FindCabinetBySCSID', E.Message); end; end; function CreateNumberObjectOnCAD(aCabinet: TFigure; aVisible: Boolean): TCabinetNumber; var i: integer; Number: TRichText; Bound: TCircle; Radius: Double; CabCP: TDoublePoint; NoteBnd: TDoubleRect; CaptionGroup: TRichText; TM: TTextMetric; xCanvas: TMetafileCanvas; h, w: double; TraceCP: TDoublePoint; MvAngle: Double; Bnd: TDoubleRect; MaxX, MaxY, MinX, MinY: Double; // Tolik 21/09/2020 -- RefreshFlag: Boolean; begin // Tolik 21/09/2020 -- не сбросить флаг - получим рефреш Када, когда номера нет -- хуйня редкая.... RefreshFlag := GCanRefreshCad; GCanRefreshCad := False; // try Result := nil; Result := TCabinetNumber.Create(aCabinet.LayerHandle, GCadForm.PCad); Radius := 5; Bound := TCircle.Create(-100, -100, Radius, 1, ord(psSolid), clMaroon, ord(bsClear), clBlack, aCabinet.LayerHandle, mydsNormal, GCadForm.PCad); {******************************************************************************} Number := TRichText.create(-100, -100, -100, -100, 1, ord(psSolid), clMaroon, ord(bsClear), clNone, aCabinet.LayerHandle, mydsNormal, GCadForm.PCad); Number.re.Font.Size := 12; Number.re.Font.Color := clMaroon; Number.re.Lines.Clear; if CheckFigureByClassName(aCabinet, cTCabinet) then Number.re.Lines.Add(IntToStr(TCabinet(aCabinet).FIndex)); if CheckFigureByClassName(aCabinet, cTCabinetExt) then Number.re.Lines.Add(IntToStr(TCabinetExt(aCabinet).FIndex)); GCadForm.PCad.AddCustomFigure(9, Number, False); RefreshCAD(GCadForm.PCad); // получить свойства // Tolik -- 13/01/2017 Number.ttMetaFile:= TMetaFile.Create; Number.ttMetafile.Enhanced := True; // xCanvas := TMetafileCanvas.Create(Number.ttMetaFile, 0); xCanvas.Font.Name := Number.re.Font.Name; xCanvas.Font.Size := Number.re.Font.Size; GetTextMetrics(xCanvas.Handle, TM); h := TM.tmHeight / 4 * Number.re.Lines.Count; w := xCanvas.TextWidth(Number.Re.Lines[0]); w := (w + 3) / 4 ; FreeAndNil(xCanvas); // пересоздать с новыми свойствами if Number <> nil then begin GCadForm.PCad.Figures.Remove(Number); FreeAndNil(Number); end; Number := TRichText.create(-100, -100, -100 + w, -100 + h, 1, ord(psSolid), clMaroon, ord(bsClear), clNone, aCabinet.LayerHandle, mydsNormal, GCadForm.PCad); Number.re.Font.Size := 12; Number.re.Font.Color := clMaroon; Number.re.Lines.Clear; if CheckFigureByClassName(aCabinet, cTCabinet) then Number.re.Lines.Add(IntToStr(TCabinet(aCabinet).FIndex)); if CheckFigureByClassName(aCabinet, cTCabinetExt) then Number.re.Lines.Add(IntToStr(TCabinetExt(aCabinet).FIndex)); Number.Move(Bound.CenterPoint.x - Number.CenterPoint.x, Bound.CenterPoint.y - Number.CenterPoint.y); Result.AddFigure(Bound); Result.AddFigure(Number); // найти центр кабинета // для обычного if CheckFigureByClassName(aCabinet, cTCabinet) then begin CabCP.x := (aCabinet.ActualPoints[1].x + aCabinet.ActualPoints[3].x) / 2; CabCP.y := (aCabinet.ActualPoints[1].y + aCabinet.ActualPoints[3].y) / 2; end; // сложной формы if CheckFigureByClassName(aCabinet, cTCabinetExt) then begin TCabinetExt(aCabinet).getbounds(MaxX, MaxY, MinX, MinY); CabCP.x := (MinX + MaxX) / 2; CabCP.y := (MinY + MaxY) / 2; end; Result.move(CabCP.x - Result.CenterPoint.x, CabCP.y - Result.CenterPoint.y); GCadForm.PCad.AddCustomFigure(9, Result, False); // Result.Visible := aVisible; for i := 0 to Result.InFigures.Count - 1 do TFigure(Result.InFigures[i]).Visible := aVisible; // Result.LockModify := True; Result.LockMove := True; Result.LockSelect := False; if CheckFigureByClassName(aCabinet, cTCabinet) then Result.FCabinetID := TCabinet(aCabinet).FSCSID; if CheckFigureByClassName(aCabinet, cTCabinetExt) then Result.FCabinetID := TCabinetExt(aCabinet).FSCSID; except on E: Exception do addExceptionToLogEx('U_Common.CreateNumberObject', E.Message); end; GCanRefreshCad := RefreshFlag; // Tolik 21/09/2020 -- end; procedure ChangeCabinetParams(AID_List: Integer; AObjectParams: TObjectParams); var Cabinet: TFigure; i: integer; NumberText: TRichText; vList: TF_CAD; SavedCadForm: TF_CAD; NumberObject: TCabinetNumber; j:Integer; aFigure: TFigure; begin try vList := GetListByID(AID_List); if vList <> nil then begin Cabinet := FindCabinetBySCSID(vList, AObjectParams.ID); if Cabinet <> nil then begin SavedCadForm := GCadForm; GCadForm := vList; //Проверка фигуры на вхождение в кабинет if GCadForm.FNeedUpdateCheckedFigures then GCadForm.UpdateCheckedFigures; for j := 0 to GCadForm.FCheckedFigures.Count - 1 do begin aFigure := TFigure(GCadForm.FCheckedFigures[j]); GCadForm.Pcad.CheckFigureInsideCabinet(GCadForm.FCheckedFigures, aFigure); end; if CheckFigureByClassName(Cabinet, cTCabinet) then begin NumberObject := TCabinet(Cabinet).FNumberObject; if NumberObject <> nil then begin RemoveInFigureGrp(NumberObject); vList.PCad.Figures.Remove(NumberObject); FreeAndNil(NumberObject); TCabinet(Cabinet).FIndex := AObjectParams.MarkID; TCabinet(Cabinet).FFalseFloorHeight := AObjectParams.HeightCeiling; TCabinet(Cabinet).CabinetConfig := AObjectParams.CabinetConfig; TCabinet(Cabinet).FNumberObject := CreateNumberObjectOnCAD(Cabinet, vList.FShowCabinetsNumbers); // Tolik 26/09/2016-- //TCabinet(Cabinet).FNumberObject.Visible := AObjectParams.CabinetConfig.aWorkRoom; TCabinet(Cabinet).FNumberObject.Visible := F_ProJMan.GSCSBase.CurrProject.CurrList.Setting.CADShowCabinetsNumbers; // TCabinet(Cabinet).FNumberObject.FPositionIndex := AObjectParams.CabinetConfig.CabinetNumPos; TCabinet(Cabinet).FNumberObject.IsCabinetExt := AObjectParams.CabinetConfig.IsCabinetExt; TCabinet(Cabinet).FNumberObject.CircleRadius := AObjectParams.CabinetConfig.NumRadius; end; end; if CheckFigureByClassName(Cabinet, cTCabinetExt) then begin NumberObject := TCabinetExt(Cabinet).FNumberObject; if NumberObject <> nil then begin RemoveInFigureGrp(NumberObject); vList.PCad.Figures.Remove(NumberObject); FreeAndNil(NumberObject); TCabinetExt(Cabinet).FIndex := AObjectParams.MarkID; TCabinetExt(Cabinet).FFalseFloorHeight := AObjectParams.HeightCeiling; TCabinetExt(Cabinet).CabinetConfig := AObjectParams.CabinetConfig; TCabinetExt(Cabinet).FNumberObject := CreateNumberObjectOnCAD(Cabinet, vList.FShowCabinetsNumbers); // Tolik -- 26/09/2016-- // TCabinetExt(Cabinet).FNumberObject.Visible := AObjectParams.CabinetConfig.aWorkRoom; TCabinetExt(Cabinet).FNumberObject.Visible := F_ProJMan.GSCSBase.CurrProject.CurrList.Setting.CADShowCabinetsNumbers; // TCabinetExt(Cabinet).FNumberObject.FPositionIndex := AObjectParams.CabinetConfig.CabinetNumPos; TCabinetExt(Cabinet).FNumberObject.IsCabinetExt := AObjectParams.CabinetConfig.IsCabinetExt; TCabinetExt(Cabinet).FNumberObject.CircleRadius := AObjectParams.CabinetConfig.NumRadius; end; end; MoveObjectsToCabinetOnMove(Cabinet); GCadForm := SavedCadForm; end; end; except on E: Exception do addExceptionToLogEx('U_Common.ChangeCabinetParams', E.Message); end; end; procedure SetVisibleCabinetsNumbers(aVisible: Boolean); var i, j: integer; Cabinet: TCabinet; CabinetExt: TCabinetExt; begin try for i := 0 to GCadForm.PCad.FigureCount - 1 do begin if CheckFigureByClassName(TFigure(GCadForm.PCad.Figures[i]), cTCabinet) then begin Cabinet := TCabinet(GCadForm.PCad.Figures[i]); if Cabinet.FNumberObject <> nil then begin if not aVisible then begin Cabinet.FNumberObject.Visible := aVisible; for j := 0 to Cabinet.FNumberObject.InFigures.Count - 1 do TFigure(Cabinet.FNumberObject.InFigures[j]).Visible := aVisible; end else begin Cabinet.FNumberObject.Visible := Cabinet.CabinetConfig.aWorkRoom; for j := 0 to Cabinet.FNumberObject.InFigures.Count - 1 do TFigure(Cabinet.FNumberObject.InFigures[j]).Visible := Cabinet.CabinetConfig.aWorkRoom; end; end; end; if CheckFigureByClassName(TFigure(GCadForm.PCad.Figures[i]), cTCabinetExt) then begin CabinetExt := TCabinetExt(GCadForm.PCad.Figures[i]); if CabinetExt.FNumberObject <> nil then begin if not aVisible then begin CabinetExt.FNumberObject.Visible := aVisible; for j := 0 to CabinetExt.FNumberObject.InFigures.Count - 1 do TFigure(CabinetExt.FNumberObject.InFigures[j]).Visible := aVisible; end else begin CabinetExt.FNumberObject.Visible := CabinetExt.Cabinetconfig.aWorkRoom; for j := 0 to CabinetExt.FNumberObject.InFigures.Count - 1 do TFigure(CabinetExt.FNumberObject.InFigures[j]).Visible := CabinetExt.Cabinetconfig.aWorkRoom; end; end; end; end; RefreshCAD(GCadForm.PCad); except on E: Exception do addExceptionToLogEx('U_Common.SetVisibleCabinetsNumbers', E.Message); end; end; // Tolik 11/12/2020 -- переписано под SCS - фигуры када -- будет быстрее работать -- // старая закомменчена -- см ниже procedure SetVisibleCabinetsBounds(aVisible: Boolean); var i, j: integer; Cabinet: TCabinet; CabinetExt: TCabinetExt; begin try for i := 0 to GCadForm.FSCSFigures.Count - 1 do begin if CheckFigureByClassName(TFigure(GCadForm.FSCSFigures[i]), cTCabinet) then begin Cabinet := TCabinet(GCadForm.FSCSFigures[i]); if Cabinet.Id > -1 then //Tolik 10/12/2020 -- нулевой кабинет на Каде не стоит дергать Cabinet.Visible := aVisible; end; if CheckFigureByClassName(TFigure(GCadForm.FSCSFigures[i]), cTCabinetExt) then begin CabinetExt := TCabinetExt(GCadForm.FSCSFigures[i]); CabinetExt.Visible := aVisible; end; end; RefreshCAD(GCadForm.PCad); except on E: Exception do addExceptionToLogEx('U_Common.SetVisibleCabinetsBounds', E.Message); end; end; { procedure SetVisibleCabinetsBounds(aVisible: Boolean); var i, j: integer; Cabinet: TCabinet; CabinetExt: TCabinetExt; begin try for i := 0 to GCadForm.PCad.FigureCount - 1 do begin if CheckFigureByClassName(TFigure(GCadForm.PCad.Figures[i]), cTCabinet) then begin Cabinet := TCabinet(GCadForm.PCad.Figures[i]); if Cabinet.Id > -1 then //Tolik 10/12/2020 -- нулевой кабинет на Каде не стоит дергать Cabinet.Visible := aVisible; end; if CheckFigureByClassName(TFigure(GCadForm.PCad.Figures[i]), cTCabinetExt) then begin CabinetExt := TCabinetExt(GCadForm.PCad.Figures[i]); CabinetExt.Visible := aVisible; end; end; RefreshCAD(GCadForm.PCad); except on E: Exception do addExceptionToLogEx('U_Common.SetVisibleCabinetsBounds', E.Message); end; end; } function GetCabinetWhereObject(aObject: TFigure): TFigure; var i: integer; X, Y: Double; Cabinet: TCabinet; CabinetExt: TCabinetExt; begin Result := nil; try X := aObject.ActualPoints[1].x; Y := aObject.ActualPoints[1].y; for i := 0 to GCadForm.PCad.FigureCount - 1 do begin if CheckFigureByClassName(TFigure(GCadForm.PCad.Figures[i]), cTCabinet) then begin Cabinet := TCabinet(GCadForm.PCad.Figures[i]); if Cabinet.FType = ct_Visual then begin if Cabinet.CabinetConfig.aWorkRoom then if Cabinet.isPointInMod(X, Y) then begin Result := Cabinet; Break; end; end; end; if CheckFigureByClassName(TFigure(GCadForm.PCad.Figures[i]), cTCabinetExt) then begin CabinetExt := TCabinetExt(GCadForm.PCad.Figures[i]); if CabinetExt.FType = ct_Visual then begin if CabinetExt.CabinetConfig.aWorkRoom then if CabinetExt.isPointInMod(X, Y) then begin Result := CabinetExt; Break; end; end; end; end; except on E: Exception do addExceptionToLogEx('U_Common.GetCabinetWhereObject', E.Message); end; end; function GetCabinetAtPos(aX, aY: double; aCheckAllFigInside: boolean = True; aMovedFigure: TFigure = nil): TFigure; var i, SquareCounter: integer; Cabinet: TCabinet; CabinetExt: TCabinetExt; aFigure:TFigure; // Tolik CabinetList : TList; currSquare: Double; Catalog: TSCSCatalog; currList: TSCSList; square: Double; SquareList: array of Double; SortAgain: Boolean; CatalogList: TSCSCatalogs; aCad: TF_CAD; begin Result := nil; //переписана совсем (by Tolik), старый код закоммечен см. ниже CabinetList := TList.Create; currList := F_ProjMan.GSCSBase.CurrProject.CurrList; SetLength(SquareList, 0); SquareCounter := 1; CatalogList := TSCSCatalogs.Create(False); aCad := GetListByID(F_ProjMan.GSCSBase.CurrProject.CurrList.SCSID); try for i := 0 to currList.ChildCatalogReferences.Count - 1 do begin Catalog := currList.ChildCatalogReferences[i]; if Catalog.ItemType = itRoom then begin CatalogList.Add(Catalog); end; end; if CatalogList.Count > 0 then begin for i := 0 to CatalogList.Count - 1 do begin Cabinet := Nil; CabinetExt := Nil; Catalog := CatalogList[i]; aFigure := GetFigureByID(aCad, Catalog.SCSID); if aFigure <> nil then begin // Tolik 07/03/2020 -- Здесь немножко поправлено,...было чуть коряво, не определялся кабинет // сложной формы... if aFigure.ClassName = 'TCabinet' then begin Cabinet := TCabinet(aFigure); if Cabinet.CabinetConfig.aWorkRoom then begin if Cabinet.isPointInMod(aX, aY) then begin CabinetList.Add(Cabinet); end; end; end else if aFigure.ClassName = 'TCabinetExt' then begin CabinetExt := TCabinetExt(aFigure); if CabinetExt.CabinetConfig.IsCabinetExt then begin if CabinetExt.CabinetConfig.aWorkRoom then begin if CabinetExt.isPointInMod(aX, aY) then begin CabinetList.Add(CabinetExt); end; end; end; end; { Cabinet := TCabinet(aFigure); if not Cabinet.CabinetConfig.IsCabinetExt then begin if Cabinet.CabinetConfig.aWorkRoom then begin if Cabinet.isPointInMod(aX, aY) then begin CabinetList.Add(Cabinet); end; end; end else // Tolik 27/10/2017 -- чтобы ускорить begin CabinetExt := TCabinetExt(aFigure); //if CabinetExt <> nil then begin if CabinetExt.CabinetConfig.IsCabinetExt then begin if CabinetExt.CabinetConfig.aWorkRoom then begin if CabinetExt.isPointInMod(aX, aY) then begin CabinetList.Add(CabinetExt); end; end; end; end; end } // end; end; // { for i := 0 to CatalogList.Count - 1 do begin Catalog := CatalogList[i]; aFigure := GetFigureByID(aCad, Catalog.SCSID); CabinetExt := TCabinetExt(aFigure); if CabinetExt <> nil then begin if CabinetExt.CabinetConfig.IsCabinetExt then begin if CabinetExt.CabinetConfig.aWorkRoom then begin if CabinetExt.isPointInMod(aX, aY) then begin CabinetList.Add(CabinetExt); end; end; end; end; end; } end; if CabinetList.Count = 0 then Result := GetVirtualCabinet else begin if CabinetList.Count > 1 then begin for i := 0 to CabinetList.Count - 1 do begin square := GetRoomSquare(currList.SCSID, TFigure(CabinetList[i]).ID); SetLength(SquareList, SquareCounter); SquareList[SquareCounter - 1] := Square; Inc(SquareCounter); end; SortAgain := True; while sortAgain do begin SortAgain := False; for i := 0 to Length(SquareList) - 2 do begin if SquareList[i] > SquareList[i + 1] then begin SortAgain := True; Square := SquareList[i]; SquareList[i] := SquareList[i + 1]; SquareList[i + 1] := Square; aFigure := TFigure(CabinetList[i]); CabinetList[i] := CabinetList[i + 1]; CabinetList[i + 1] := aFigure; end; end; end; end; Result := TFigure(CabinetList[0]); end; except on E: Exception do addExceptionToLogEx('U_Common.GetCabinetAtPos', E.Message); end; { try if GCadForm.FNeedUpdateCheckedFigures then GCadForm.UpdateCheckedFigures; if aMovedFigure <> nil then begin GCadForm.PCad.CheckFigureInsideCabinet(GCadForm.FCheckedFigures, aMovedFigure); end else begin if aCheckAllFigInside then begin for i := 0 to GCadForm.FCheckedFigures.Count - 1 do begin aFigure := TFigure(GCadForm.FCheckedFigures[i]); GCadForm.PCad.CheckFigureInsideCabinet(GCadForm.FCheckedFigures, aFigure); end; end; end; //for i := 0 to GCadForm.PCad.FigureCount - 1 do for i := 0 to GCadForm.FCheckedFigures.Count - 1 do begin //if CheckFigureByClassName(TFigure(GCadForm.PCad.Figures[i]), cTCabinet) then if CheckFigureByClassName(TFigure(GCadForm.FCheckedFigures[i]), cTCabinet) then begin //Cabinet := TCabinet(GCadForm.PCad.Figures[i]); Cabinet := TCabinet(GCadForm.FCheckedFigures[i]); if Cabinet.FType = ct_Virtual then begin Result := Cabinet; end; // if Cabinet.FType = ct_Visual then // if (Cabinet.FType = ct_Visual) or (Cabinet.FType = ct_Virtual) then begin if Cabinet.CabinetConfig.aWorkRoom then if Cabinet.isPointInMod(aX, aY) then begin Result := Cabinet; Break; //CabinetList.Add(Cabinet); end; end; end; //if CheckFigureByClassName(TFigure(GCadForm.PCad.Figures[i]), cTCabinetExt) then if CheckFigureByClassName(TFigure(GCadForm.FCheckedFigures[i]), cTCabinetExt) then begin //CabinetExt := TCabinetExt(GCadForm.PCad.Figures[i]); CabinetExt := TCabinetExt(GCadForm.FCheckedFigures[i]); if CabinetExt.FType = ct_Virtual then begin Result := CabinetExt; end; if CabinetExt.FType = ct_Visual then begin if CabinetExt.CabinetConfig.aWorkRoom then if CabinetExt.isPointInMod(aX, aY) then begin Result := CabinetExt; Break; //CabinetList.Add(CabinetExt); end; end; end; end; except on E: Exception do addExceptionToLogEx('U_Common.GetCabinetAtPos', E.Message); end; } SetLength(SquareList, 0); //if CabinetList.Count > 0 then FreeAndNil(CabinetList); //Tolik 11/03/2017 -- CatalogList.Clear; CatalogList.Free; // end; procedure MoveObjectsToCabinetOnCreate(aCabinet: TFigure); var i: Integer; Line: TOrthoLine; Conn: TConnectorObject; begin // Tolik 27/10/2017 -- F_ProjMan.LockTreeAndGrid(True); // try //for i := 0 to GCadForm.PCad.FigureCount - 1 do // Tolik 27/10/2017 -- чтобы немножко ускорить for i := 0 to GCadForm.FSCSFigures.Count - 1 do begin //if CheckFigureByClassName(TFigure(GCadForm.PCad.Figures[i]), cTOrthoLine) then if CheckFigureByClassName(TFigure(GCadForm.FSCSFigures[i]), cTOrthoLine) then begin //Line := TOrthoLine(GCadForm.PCad.Figures[i]); Line := TOrthoLine(GCadForm.FSCSFigures[i]); if CheckFigureByClassName(aCabinet, cTCabinet) then begin if TCabinet(aCabinet).isPointInMod(Line.ActualPoints[1].x, Line.ActualPoints[1].y) then begin if (Line.FCabinetID <> TCabinet(aCabinet).FSCSID) then begin Line.FCabinetID := TCabinet(aCabinet).FSCSID; MoveObjectToRoomInPM(GCadForm.FCADListID, Line.ID, Line.FCabinetID); end; end; end else begin if CheckFigureByClassName(aCabinet, cTCabinetExt) then begin if TCabinetExt(aCabinet).isPointInMod(Line.ActualPoints[1].x, Line.ActualPoints[1].y) then begin if (Line.FCabinetID <> TCabinetExt(aCabinet).FSCSID) then begin Line.FCabinetID := TCabinetExt(aCabinet).FSCSID; MoveObjectToRoomInPM(GCadForm.FCADListID, Line.ID, Line.FCabinetID); end; end; end; end; end else begin //if CheckFigureByClassName(TFigure(GCadForm.PCad.Figures[i]), cTConnectorObject) then if CheckFigureByClassName(TFigure(GCadForm.FSCSFigures[i]), cTConnectorObject) then begin //Conn := TConnectorObject(GCadForm.PCad.Figures[i]); Conn := TConnectorObject(GCadForm.FSCSFigures[i]); if CheckFigureByClassName(aCabinet, cTCabinet) then begin if TCabinet(aCabinet).isPointInMod(Conn.ActualPoints[1].x, Conn.ActualPoints[1].y) then begin if (Conn.FCabinetID <> TCabinet(aCabinet).FSCSID) then begin Conn.FCabinetID := TCabinet(aCabinet).FSCSID; MoveObjectToRoomInPM(GCadForm.FCADListID, Conn.ID, Conn.FCabinetID); end; end; end else begin if CheckFigureByClassName(aCabinet, cTCabinetExt) then begin if TCabinetExt(aCabinet).isPointInMod(Conn.ActualPoints[1].x, Conn.ActualPoints[1].y) then begin if (Conn.FCabinetID <> TCabinetExt(aCabinet).FSCSID) then begin Conn.FCabinetID := TCabinetExt(aCabinet).FSCSID; MoveObjectToRoomInPM(GCadForm.FCADListID, Conn.ID, Conn.FCabinetID); end; end; end; end; end; end; end; except on E: Exception do addExceptionToLogEx('U_Common.MoveObjectsToCabinet', E.Message); end; // Tolik 27/10/2017 -- F_ProjMan.LockTreeAndGrid(False); // end; procedure MoveObjectsToCabinetOnMove(aCabinet: TFigure); var i: Integer; Line: TOrthoLine; Conn: TConnectorObject; OtherCabinet: TFigure; aFigure: TFigure; begin F_ProjMan.LockTreeAndGrid(True);//Tolik 27/10/2017 -- try // Tolik 26/09/2016 -- тут немножко учкорим процесс // for i := 0 to GCadForm.PCad.FigureCount - 1 do for i := 0 to GCadForm.FSCSFigures.Count - 1 do // begin // Tolik 26/09/2016-- // aFigure := TFigure(GCadForm.PCad.Figures[i]); aFigure := TFigure(GCadForm.FSCSFigures[i]); GCadForm.PCad.CheckFigureInsideCabinet(GCadForm.FCheckedFigures, aFigure); // if CheckFigureByClassName(TFigure(GCadForm.PCad.Figures[i]), cTOrthoLine) then if CheckFigureByClassName(aFigure, cTOrthoLine) then begin // LINE Line := TOrthoLine(aFigure); // if CheckFigureByClassName(aCabinet, cTCabinet) then begin if (TCabinet(aCabinet).isPointInMod(Line.ActualPoints[1].x, Line.ActualPoints[1].y))and(TCabinet(aCabinet).CabinetConfig.aWorkRoom) then begin // в области данного кабинета if (Line.FCabinetID <> TCabinet(aCabinet).FSCSID) then begin Line.FCabinetID := TCabinet(aCabinet).FSCSID; MoveObjectToRoomInPM(GCadForm.FCADListID, Line.ID, Line.FCabinetID); end; end else begin // вне области данного кабинета if (Line.FCabinetID = TCabinet(aCabinet).FSCSID) then begin // найти в каком кабинете он теперь остался OtherCabinet := GetCabinetAtPos(Line.ActualPoints[1].x, Line.ActualPoints[1].y, False); if OtherCabinet <> nil then begin if CheckFigureByClassName(OtherCabinet, cTCabinet) then Line.FCabinetID := TCabinet(OtherCabinet).FSCSID; if CheckFigureByClassName(OtherCabinet, cTCabinetExt) then Line.FCabinetID := TCabinetExt(OtherCabinet).FSCSID; end else Line.FCabinetID := -1; MoveObjectToRoomInPM(GCadForm.FCADListID, Line.ID, Line.FCabinetID); end; end; end else begin if CheckFigureByClassName(aCabinet, cTCabinetExt) then begin if (TCabinetExt(aCabinet).isPointInMod(Line.ActualPoints[1].x, Line.ActualPoints[1].y))and(TCabinetExt(aCabinet).CabinetConfig.aWorkRoom) then begin // в области данного кабинета if (Line.FCabinetID <> TCabinetExt(aCabinet).FSCSID) then begin Line.FCabinetID := TCabinetExt(aCabinet).FSCSID; MoveObjectToRoomInPM(GCadForm.FCADListID, Line.ID, Line.FCabinetID); end; end else begin // вне области данного кабинета if (Line.FCabinetID = TCabinetExt(aCabinet).FSCSID) then begin // найти в каком кабинете он теперь остался OtherCabinet := GetCabinetAtPos(Line.ActualPoints[1].x, Line.ActualPoints[1].y, False); if OtherCabinet <> nil then begin if CheckFigureByClassName(OtherCabinet, cTCabinet) then Line.FCabinetID := TCabinet(OtherCabinet).FSCSID; if CheckFigureByClassName(OtherCabinet, cTCabinetExt) then Line.FCabinetID := TCabinetExt(OtherCabinet).FSCSID; end else Line.FCabinetID := -1; MoveObjectToRoomInPM(GCadForm.FCADListID, Line.ID, Line.FCabinetID); end; end; end; end; end else begin // Tolik 26/09/2016-- //if CheckFigureByClassName(TFigure(GCadForm.PCad.Figures[i]), cTConnectorObject) then if CheckFigureByClassName(aFigure, cTConnectorObject) then begin // CONN // Conn := TConnectorObject(GCadForm.PCad.Figures[i]); Conn := TConnectorObject(aFigure); // if CheckFigureByClassName(aCabinet, cTCabinet) then begin if (TCabinet(aCabinet).isPointInMod(Conn.ActualPoints[1].x, Conn.ActualPoints[1].y))and(TCabinet(aCabinet).CabinetConfig.aWorkRoom) then begin // в области данного кабинета if (Conn.FCabinetID <> TCabinet(aCabinet).FSCSID) then begin Conn.FCabinetID := TCabinet(aCabinet).FSCSID; MoveObjectToRoomInPM(GCadForm.FCADListID, Conn.ID, Conn.FCabinetID); end; end else begin // вне области данного кабинета if (Conn.FCabinetID = TCabinet(aCabinet).FSCSID) then begin // найти в каком кабинете он теперь остался OtherCabinet := GetCabinetAtPos(Conn.ActualPoints[1].x, Conn.ActualPoints[1].y, False); if OtherCabinet <> nil then begin if CheckFigureByClassName(OtherCabinet, cTCabinet) then Conn.FCabinetID := TCabinet(OtherCabinet).FSCSID; if CheckFigureByClassName(OtherCabinet, cTCabinetExt) then Conn.FCabinetID := TCabinetExt(OtherCabinet).FSCSID; end else Conn.FCabinetID := -1; MoveObjectToRoomInPM(GCadForm.FCADListID, Conn.ID, Conn.FCabinetID); end; end; end else begin if CheckFigureByClassName(aCabinet, cTCabinetExt) then begin if (TCabinetExt(aCabinet).isPointInMod(Conn.ActualPoints[1].x, Conn.ActualPoints[1].y))and(TCabinetExt(aCabinet).CabinetConfig.aWorkRoom) then begin // в области данного кабинета if (Conn.FCabinetID <> TCabinetExt(aCabinet).FSCSID) then begin Conn.FCabinetID := TCabinetExt(aCabinet).FSCSID; MoveObjectToRoomInPM(GCadForm.FCADListID, Conn.ID, Conn.FCabinetID); end; end else begin // вне области данного кабинета if (Conn.FCabinetID = TCabinetExt(aCabinet).FSCSID) then begin // найти в каком кабинете он теперь остался OtherCabinet := GetCabinetAtPos(Conn.ActualPoints[1].x, Conn.ActualPoints[1].y, False); if OtherCabinet <> nil then begin if CheckFigureByClassName(OtherCabinet, cTCabinet) then Conn.FCabinetID := TCabinet(OtherCabinet).FSCSID; if CheckFigureByClassName(OtherCabinet, cTCabinetExt) then Conn.FCabinetID := TCabinetExt(OtherCabinet).FSCSID; end else Conn.FCabinetID := -1; MoveObjectToRoomInPM(GCadForm.FCADListID, Conn.ID, Conn.FCabinetID); end; end; end; end; end; end; end; except on E: Exception do addExceptionToLogEx('U_Common.MoveObjectsToCabinetOnMove', E.Message); end; F_ProjMan.LockTreeAndGrid(False);//Tolik 27/10/2017 -- end; function GetVirtualCabinet: TFigure; var i: integer; begin Result := nil; try for i := 0 to GCadForm.PCad.FigureCount - 1 do begin if CheckFigureByClassName(TFigure(GCadForm.PCad.Figures[i]), cTCabinet) then begin if TCabinet(GCadForm.PCad.Figures[i]).FType = ct_Virtual then begin Result := TFigure(GCadForm.PCad.Figures[i]); Break; end; end; if CheckFigureByClassName(TFigure(GCadForm.PCad.Figures[i]), cTCabinetExt) then begin if TCabinetExt(GCadForm.PCad.Figures[i]).FType = ct_Virtual then begin Result := TFigure(GCadForm.PCad.Figures[i]); Break; end; end; end; except on E: Exception do AddExceptionToLogEx('U_Common.GetVirtualCabinet', E.Message); end; end; function IsNoteExist(aNoteObject: TFigureGrpNotMod): Boolean; var i: integer; Note: TRichTextMod; begin Result := True; //03.11.2011 //try // Note := nil; // for i := 0 to aNoteObject.InFigures.Count - 1 do // begin // if CheckFigureByClassName(TFigure(aNoteObject.InFigures[i]), cTRichTextMod) then // Note := TRichTextMod(aNoteObject.InFigures[i]); // end; // if Note <> nil then // begin // if Note.re.Lines.Count > 0 then // Result := True // else // Result := False; // end; // except // on E: Exception do addExceptionToLogEx('U_Common.IsNoteExist', E.Message); // end; Note := nil; for i := 0 to aNoteObject.InFigures.Count - 1 do begin if CheckFigureByClassName(TFigure(aNoteObject.InFigures[i]), cTRichTextMod) then begin Note := TRichTextMod(aNoteObject.InFigures[i]); if Note <> nil then begin if Note.re.Lines.Count > 0 then begin Result := True; Break; //// BREAK //// end else Result := False; end; end; end; end; function isRaiseEmptyAndNotNeed(aRaiseLine: TOrthoLine): boolean; var JoinObject1, JoinObject2: TConnectorObject; LinesCount1, LinesCount2, ConnsCount1, ConnsCount2: Integer; Function CheckSameConnHeight: boolean; begin Result := False; if Assigned(aRaiseLine.JoinConnector1) then if Assigned(aRaiseLine.JoinConnector2) then if CompareValue(TConnectorObject(aRaiseLine.JoinConnector1).ActualZOrder[1], TConnectorObject(aRaiseLine.JoinConnector2).ActualZOrder[1]) = 0 then Result := True; end; begin try result := False; // Tolik 29/09/2016-- чтобы не пиздануть нечаянно межетажный С/П // межэтажный if (((TConnectorObject(aRaiseLine.JoinConnector1) <> nil) and ((TConnectorObject(aRaiseLine.JoinConnector1).FConnRaiseType = crt_BetweenFloorUp) or (TConnectorObject(aRaiseLine.JoinConnector1).FConnRaiseType = crt_BetweenFloorDown))) or ((TConnectorObject(aRaiseLine.JoinConnector2) <> nil) and ((TConnectorObject(aRaiseLine.JoinConnector2).FConnRaiseType = crt_BetweenFloorUp) or (TConnectorObject(aRaiseLine.JoinConnector2).FConnRaiseType = crt_BetweenFloorDown)))) or // магистраль (((TConnectorObject(aRaiseLine.JoinConnector1) <> nil) and ((TConnectorObject(aRaiseLine.JoinConnector1).FConnRaiseType = crt_TrunkUp) or (TConnectorObject(aRaiseLine.JoinConnector1).FConnRaiseType = crt_TrunkDown))) or ((TConnectorObject(aRaiseLine.JoinConnector2) <> nil) and ((TConnectorObject(aRaiseLine.JoinConnector2).FConnRaiseType = crt_TrunkUp) or (TConnectorObject(aRaiseLine.JoinConnector2).FConnRaiseType = crt_TrunkDown))))then exit; // if aRaiseLine.FIsRaiseUpDown then begin if CheckEmptyFigure(aRaiseLine.ID) then begin JoinObject1 := TConnectorObject(aRaiseLine.JoinConnector1); JoinObject2 := TConnectorObject(aRaiseLine.JoinConnector2); ConnsCount1 := JoinObject1.JoinedConnectorsList.Count; ConnsCount2 := JoinObject2.JoinedConnectorsList.Count; LinesCount1 := JoinObject1.JoinedOrtholinesList.Count - 1; LinesCount2 := JoinObject2.JoinedOrtholinesList.Count - 1; // Tolik 04/02/2021 -- для внешних сетей длина трассы будет 0 и тогда даже нужные райзы поудаляются.... //if ((ConnsCount1 = 0) and (LinesCount1 = 0)) or ((ConnsCount2 = 0) and (LinesCount2 = 0)) or (aRaiseLine.LineLength = 0) then if ((ConnsCount1 = 0) and (LinesCount1 = 0)) or ((ConnsCount2 = 0) and (LinesCount2 = 0)) or CheckSameConnHeight then // begin result := True; end; end; end; except on E: Exception do addExceptionToLogEx('U_Common.isRaiseEmptyAndNotNeed', E.Message); end; end; procedure CheckDeleteRaise(aRaiseLine: TOrthoLine); var ObjFromRaise: TConnectorObject; RaiseConn: TConnectorObject; begin try if isRaiseEmptyAndNotNeed(aRaiseLine) then begin ObjFromRaise := aRaiseLine.FObjectFromRaisedLine; if ObjFromRaise <> nil then begin RaiseConn := GetRaiseConn(ObjFromRaise); if (RaiseConn <> nil) and (RaiseConn.FConnRaiseType = crt_OnFloor) then begin // ????? if not RaiseConn.Deleted then begin if ObjFromRaise.ConnectorType = ct_Clear then DestroyRaiseOnConnector(ObjFromRaise) else DestroyRaiseOnPointObject(ObjFromRaise); end; end; end; end; except on E: Exception do addExceptionToLogEx('U_Common.CheckDeleteRaise', E.Message); end; end; // Tolik -- 27/05/2016 -- // старая закомменчена (смотри ниже), здесь написано с целью немножко ускорить процесс procedure CheckDeleteAllRaises(aPCad: TPowerCad); var i: integer; RaiseLine: TOrthoLine; RaisesList: TList; begin RaisesList := TList.Create; try for i := 0 to GCadForm.FSCSFigures.Count - 1 do begin if CheckFigureByClassName(TFigure(GCadForm.FSCSFigures[i]), cTOrthoLine) then begin RaiseLine := TOrthoLine(GCadForm.FSCSFigures[i]); if RaiseLine.FIsRaiseUpDown then RaisesList.Add(RaiseLine); end; end; for i := 0 to RaisesList.Count - 1 do begin RaiseLine := TOrthoLine(RaisesList[i]); if (RaiseLine <> nil) and (not RaiseLine.Deleted) then begin CheckDeleteRaise(RaiseLine); end; end; RefreshCAD(aPCad); except on E: Exception do addExceptionToLogEx('U_Common.CheckDeleteAllRaises', E.Message); end; FreeAndNil(RaisesList); end; { procedure CheckDeleteAllRaises(aPCad: TPowerCad); var i: integer; RaiseLine: TOrthoLine; RaisesList: TList; begin try RaisesList := TList.Create; for i := 0 to aPCad.FigureCount - 1 do begin if CheckFigureByClassName(TFigure(aPCad.Figures[i]), cTOrthoLine) then begin RaiseLine := TOrthoLine(aPCad.Figures[i]); if RaiseLine.FIsRaiseUpDown then RaisesList.Add(RaiseLine); end; end; for i := 0 to RaisesList.Count - 1 do begin RaiseLine := TOrthoLine(RaisesList[i]); if (RaiseLine <> nil) and (not RaiseLine.Deleted) then begin CheckDeleteRaise(RaiseLine); end; end; FreeAndNil(RaisesList); RefreshCAD(aPCad); except on E: Exception do addExceptionToLogEx('U_Common.CheckDeleteAllRaises', E.Message); end; end; } function CheckCADObjectSelect(AID_List, AID_Object: Integer): Boolean; var FList: TF_CAD; FObject: TFigure; begin Result := False; try FList := GetListByID(AID_List); if FList <> nil then begin FObject := GetFigureByID(FList, AID_Object); if FObject <> nil then begin if FObject.Selected then Result := True else Result := False; end; end; except on E: Exception do addExceptionToLogEx('', E.Message); end; end; function GetPointObjectsRelations(AID_List: Integer): TObjectList; var i, j, k: Integer; CurObject: TConnectorObject; CurTrace: TOrthoLine; FList: TF_CAD; PointObjectsList: TList; UsedObjectsList: TList; GetTrace: TList; FirstObject: TConnectorObject; LastObject: TConnectorObject; PointFigureRelation: TPointFigureRelation; begin Result := TObjectList.Create(True); //Tolik 07/02/2017 GetTrace := nil; // PointObjectsList := TList.Create; UsedObjectsList := TList.Create; try FList := GetListByID(AID_List); FList := GCadForm; if FList <> nil then begin // заполнить список ТО for i := 0 to FList.PCad.FigureCount - 1 do begin if CheckFigureByClassName(TFigure(FList.PCad.Figures[i]), cTConnectorObject) then begin CurObject := TConnectorObject(FList.PCad.Figures[i]); if CurObject.ConnectorType <> ct_Clear then PointObjectsList.Add(CurObject); end; end; end; // перебрать соединения на КАДе for i := 0 to PointObjectsList.Count - 1 do begin FirstObject := TConnectorObject(PointObjectsList[i]); for j := i + 1 to PointObjectsList.Count - 1 do begin LastObject := TConnectorObject(PointObjectsList[j]); GetTrace := GetAllTraceInCAD(FirstObject, LastObject); // соединение есть if GetTrace <> nil then begin PointFigureRelation := TPointFigureRelation.Create; PointFigureRelation.FirstPointFigure := FirstObject.ID; PointFigureRelation.LastPointFigure := LastObject.ID; // отделить трассы от ТО и занести в список класса for k := 0 to GetTrace.Count - 1 do begin if CheckFigureByClassName(TFigure(GetTrace[k]), cTOrthoLine) then begin CurTrace := TOrthoLine(GetTrace[k]); PointFigureRelation.Traces.Add(CurTrace.ID); end; end; Result.Add(PointFigureRelation); // Tolik 07/02/2017 -- FreeAndNil(GetTrace); // end; end; end; except on E: Exception do addExceptionToLogEx('U_Common.GetPointObjectsRelations', E.Message); end; FreeAndNil(PointObjectsList); FreeAndNil(UsedObjectsList); end; // Tolik -- 29/06/2017 -- // старая закомменчена -- см ниже Procedure ReScaleAllDimLines; var i: integer; HDimLine: TSCSHDimLine; VDimLine: TSCSVDimLine; SCSCatalog: TSCSCatalog; currList: TSCSList; //Tolik -- 07/11/2017 -- FigList: TList; // begin //Tolik -- 07/11/2017 -- figList := TList.Create; // здесь организован список, потому что в процессе порядок фигур на каде может произвольно поменяться и FigList.Assign(GCadForm.PCad.Figures, laCopy); // циклический перебор вернет не все, а что попало... // try currList := F_ProjMan.GSCSBase.CurrProject.GetListBySCSID(GCadForm.FCADListID); //for i := 0 to GCadForm.PCad.FigureCount - 1 do for i := 0 to FigList.Count - 1 do //Tolik -- 07/11/2017 -- begin // if CheckFigureByClassName(TFigure(GCadForm.PCad.Figures[i]), cTSCSHDimLine) then if CheckFigureByClassName(TFigure(FigList[i]), cTSCSHDimLine) then //Tolik -- 07/11/2017 -- begin //HDimLine := TSCSHDimLine(GCadForm.PCad.Figures[i]); HDimLine := TSCSHDimLine(figList[i]); //Tolik -- 07/11/2017 -- HDimLine.FValue := HDimLine.GetValue; HDimLine.DLabel := FormatFloat(ffMask, HDimLine.FValue); HDimLine.AutoText := True; HDimLine.Modified := True; end else //if CheckFigureByClassName(TFigure(GCadForm.PCad.Figures[i]), cTSCSVDimLine) then if CheckFigureByClassName(TFigure(figList[i]), cTSCSVDimLine) then //Tolik -- 07/11/2017 -- begin //VDimLine := TSCSVDimLine(GCadForm.PCad.Figures[i]); VDimLine := TSCSVDimLine(figList[i]); //Tolik -- 07/11/2017 -- VDimLine.FValue := VDimLine.GetValue; VDimLine.DLabel := FormatFloat(ffMask, VDimLine.FValue); VDimLine.AutoText := True; VDimLine.Modified := True; end else {if ((not TFigure(GCadForm.PCad.Figures[i]).deleted) and CheckFigureByClassName(TFigure(GCadForm.PCad.Figures[i]), cTConnectorObject)) then} if ((not TFigure(figList[i]).deleted) and CheckFigureByClassName(TFigure(figList[i]), cTConnectorObject)) then //Tolik -- 07/11/2017 -- begin //if (TConnectorObject(GCadForm.PCad.Figures[i]).DrawFigure <> nil) then if (TConnectorObject(figList[i]).DrawFigure <> nil) then //Tolik -- 07/11/2017 -- //if (TConnectorObject(GCadForm.PCad.Figures[i]).ConnectorType <> ct_Clear) then if (TConnectorObject(figList[i]).ConnectorType <> ct_Clear) then //Tolik -- 07/11/2017 -- //if not TFigure(TConnectorObject(GCadForm.PCad.Figures[i]).DrawFigure).deleted then if not TFigure(TConnectorObject(figList[i]).DrawFigure).deleted then //Tolik -- 07/11/2017 -- begin if currList <> nil then begin //SCSCatalog := currList.GetCatalogFromReferencesBySCSID(TFigure(GCadForm.PCad.Figures[i]).ID); SCSCatalog := currList.GetCatalogFromReferencesBySCSID(TFigure(figList[i]).ID); //Tolik -- 07/11/2017 -- if SCSCatalog <> nil then TF_Main(SCSCatalog.ActiveForm).F_ChoiceConnectSide.DefineObjectIcon(SCSCatalog); end; end; end; end; except on E: Exception do addExceptionToLogEx('U_Common.ReScaleAllDimLines', E.Message); end; figList.Free; end; {Procedure ReScaleAllDimLines; var i: integer; HDimLine: TSCSHDimLine; VDimLine: TSCSVDimLine; begin try for i := 0 to GCadForm.PCad.FigureCount - 1 do begin if CheckFigureByClassName(TFigure(GCadForm.PCad.Figures[i]), cTSCSHDimLine) then begin HDimLine := TSCSHDimLine(GCadForm.PCad.Figures[i]); HDimLine.FValue := HDimLine.GetValue; HDimLine.DLabel := FormatFloat(ffMask, HDimLine.FValue); HDimLine.AutoText := True; HDimLine.Modified := True; end; if CheckFigureByClassName(TFigure(GCadForm.PCad.Figures[i]), cTSCSVDimLine) then begin VDimLine := TSCSVDimLine(GCadForm.PCad.Figures[i]); VDimLine.FValue := VDimLine.GetValue; VDimLine.DLabel := FormatFloat(ffMask, VDimLine.FValue); VDimLine.AutoText := True; VDimLine.Modified := True; end; end; except on E: Exception do addExceptionToLogEx('U_Common.ReScaleAllDimLines', E.Message); end; end; } Function CheckObjectDeleted(AID_List, AID_Object: Integer): Boolean; var FFigure: TFigure; vList: TF_CAD; begin Result := False; try vList := GetListByID(AID_List); if vList <> nil then begin FFigure := GetFigureByID(vList, AID_Object); if FFigure <> nil then begin if FFigure.Deleted then Result := True else Result := False; end; end; except on E: Exception do addExceptionToLogEx('U_Common.CheckObjectDeleted', E.Message); end; end; procedure ReverseCaptionAfterTypeChange(aLine: TOrthoLine; aOldType, aNewType: TShowKind); var PairStr: string; LengthStr: string; begin try // переключается с обычного на внешние СКС if (aOldType <> skExternalSCS) and (aNewType = skExternalSCS) then begin aLine.OutTextCaptions.Clear; PairStr := GetPairCountFromTrace(GCadForm.FCADListID, aLine.ID); aLine.OutTextCaptions.Add(PairStr); LengthStr := GetLineCaptionFormat(aLine, GCadForm.FShowLineCaptionsType); aLine.OutTextCaptions.Add(LengthStr); end else // переключается с внешних СКС на обычне if (aOldType = skExternalSCS) and (aNewType <> skExternalSCS) then begin aLine.OutTextCaptions.Clear; LengthStr := GetLineCaptionFormat(aLine, GCadForm.FShowLineCaptionsType); aLine.OutTextCaptions.Add(LengthStr); end; except on E: Exception do addExceptionToLogEx('TOrthoLine.ReverseCaptionAfterTypeChange', E.Message); end; end; procedure SetDimLinesType(aType: TDimLinesType); var i: Integer; FFigure: TFigure; EndType: TEndType; begin try EndType := etRow; //#From Oleg# //14.09.2010 if aType = dlt_None then EndType := etClear; if aType = dlt_Row then EndType := etRow; if aType = dlt_Stroke then EndType := etNick; for i := 0 to GCadForm.PCad.FigureCount - 1 do begin FFigure := TFigure(GCadForm.PCad.Figures[i]); if CheckFigureByClassName(FFigure, cTSCSHDimLine) then begin TSCSHDimLine(FFigure).EndType := EndType; end; if CheckFigureByClassName(FFigure, cTSCSVDimLine) then begin TSCSVDimLine(FFigure).EndType := EndType; end; if CheckFigureByClassName(FFigure, 'THDimLine') then begin THDimLine(FFigure).EndType := EndType; end; if CheckFigureByClassName(FFigure, 'TVDimLine') then begin TVDimLine(FFigure).EndType := EndType; end; end; except on E: Exception do addExceptionToLogEx('U_Common.SetDimLinesType', E.Message); end; end; function CheckTrunkObject(aObject: TConnectorObject): Boolean; begin Result := false; try if aObject = nil then exit; if CheckFigureByClassName(aObject, cTConnectorObject) then begin if (aObject.FTrunkName = ctsnCrossATS) or (aObject.FTrunkName = ctsnDistributionCabinet) then Result := True else Result := False; end; except on E: Exception do addExceptionToLogEx('U_Common.CheckTrunkObject', E.Message); end; end; function CreateSCSObjectDuplicates(ACad: TF_CAD; aObjects: TList): TList; var i, j, k: integer; vConn, ResConn: TConnectorObject; vLine, ResLine: TOrthoLine; ClearsList: TList; ObjectsList: TList; ClearConn, OtherClearConn: TConnectorObject; PointConn, GetParentDup: TConnectorObject; DrawDeltaX, DrawDeltaY: double; TotalList: TList; FFigure: TFigure; ResConnectingTraces: TList; vConnectingTraces: TList; ResConnectingLine: TOrthoLine; vConnectingLine: TOrthoLine; isSP: Boolean; Net: TNet; begin Result := Nil; try if not CheckAnyButFigureGrp(aObjects) then begin EndProgress; ShowMessage(cCommon_Mes22); Exit; end; ClearsList := TList.Create; ObjectsList := TList.Create; TotalList := TList.Create; Result := TList.create; for i := 0 to aObjects.Count - 1 do begin FFigure := TFigure(aObjects[i]); if CheckFigureByClassName(FFigure, cTConnectorObject) then begin vConn := TConnectorObject(FFigure); if vConn.ConnectorType <> ct_Clear then begin // КРОСС АТС if vConn.FTrunkName = ctsnCrossATS then begin ResConn := vConn.CreateCrossATSDuplicate(vConn.ActualPoints[1].x, vConn.ActualPoints[1].y); ResConn.tmpParentDupID := vConn.ID; if CheckNoFigureInList(ResConn, ObjectsList) then ObjectsList.Add(ResConn); TotalList.Add(ResConn); vConnectingTraces := GetAllConnectingTraces(vConn); ResConnectingTraces := GetAllConnectingTraces(ResConn); for j := 0 to ResConnectingTraces.Count - 1 do begin ResConnectingLine := TOrthoLine(ResConnectingTraces[j]); vConnectingLine := TOrthoLine(vConnectingTraces[j]); TConnectorObject(ResConnectingLine.JoinConnector1).tmpParentDupID := TConnectorObject(vConnectingLine.JoinConnector1).ID; TConnectorObject(ResConnectingLine.JoinConnector2).tmpParentDupID := TConnectorObject(vConnectingLine.JoinConnector2).ID; if CheckNoFigureInList(ResConnectingLine.JoinConnector1, ClearsList) then begin ClearsList.Add(ResConnectingLine.JoinConnector1); TotalList.Add(ResConnectingLine.JoinConnector1); end; TotalList.Add(ResConnectingLine); end; // Tolik -- 09/02/2017 -- FreeAndNil(vConnectingTraces); FreeAndNil(ResConnectingTraces); // end else // РАСПРЕДЕЛИТЕЛЬНЫЙ ШКАФ if vConn.FTrunkName = ctsnDistributionCabinet then begin ResConn := vConn.CreateDistribCabDuplicate(vConn.ActualPoints[1].x, vConn.ActualPoints[1].y); ResConn.tmpParentDupID := vConn.ID; if CheckNoFigureInList(ResConn, ObjectsList) then ObjectsList.Add(ResConn); TotalList.Add(ResConn); vConnectingTraces := GetAllConnectingTraces(vConn); ResConnectingTraces := GetAllConnectingTraces(ResConn); for j := 0 to ResConnectingTraces.Count - 1 do begin ResConnectingLine := TOrthoLine(ResConnectingTraces[j]); vConnectingLine := TOrthoLine(vConnectingTraces[j]); TConnectorObject(ResConnectingLine.JoinConnector1).tmpParentDupID := TConnectorObject(vConnectingLine.JoinConnector1).ID; TConnectorObject(ResConnectingLine.JoinConnector2).tmpParentDupID := TConnectorObject(vConnectingLine.JoinConnector2).ID; if CheckNoFigureInList(ResConnectingLine.JoinConnector1, ClearsList) then begin ClearsList.Add(ResConnectingLine.JoinConnector1); TotalList.Add(ResConnectingLine.JoinConnector1); end; TotalList.Add(ResConnectingLine); end; // Tolik -- 09/02/2017 -- FreeAndNil(vConnectingTraces); FreeAndNil(ResConnectingTraces); // end else // ОБЫЧНЫЙ begin ResConn := vConn.CreateDuplicate(vConn.ActualPoints[1].x, vConn.ActualPoints[1].y); ResConn.tmpParentDupID := vConn.ID; if CheckNoFigureInList(ResConn, ObjectsList) then ObjectsList.Add(ResConn); TotalList.Add(ResConn); end; end; end else if CheckFigureByClassName(FFigure, cTOrthoLine) then begin vLine := TOrthoLine(FFigure); //if (not vLine.FConnectingLine) and (not vLine.FIsVertical) then if (not vLine.FConnectingLine) then begin GLastTracedLinePoints1 := vLine.ActualPoints[1]; GLastTracedLinePoints2 := vLine.ActualPoints[2]; ResLine := vLine.CreateDuplicate; TConnectorObject(ResLine.JoinConnector1).tmpParentDupID := TConnectorObject(vLine.JoinConnector1).ID; TConnectorObject(ResLine.JoinConnector2).tmpParentDupID := TConnectorObject(vLine.JoinConnector2).ID; if CheckNoFigureInList(ResLine.JoinConnector1, ClearsList) then begin ClearsList.Add(ResLine.JoinConnector1); TotalList.Add(ResLine.JoinConnector1); end; if CheckNoFigureInList(ResLine.JoinConnector2, ClearsList) then begin ClearsList.Add(ResLine.JoinConnector2); TotalList.Add(ResLine.JoinConnector2); end; TotalList.Add(ResLine); GLastTracedLinePoints1 := DoublePoint(-10000, -10000); GLastTracedLinePoints2 := DoublePoint(-10000, -10000); end; // Tolik -- дубль для вертикальной трассы { if vLine.FIsVertical then begin end;} end else if FFigure is TNet then begin // Tolik -- 28/09/2016 -- фигуры архитектурного планирования пока будлировать не будем // там слишком все неоднозначно { Net := TNet(FFigure).CreateDuplicate; GArchEngine.SetHandlersToObj(Net); ACad.PCad.AddCustomFigure(lnArch, Net, False); //CAD.PCad.AddCustomFigure(lnArch, Net, False); RefreshNet(Net); TotalList.Add(Net);} end; end; // создать все связи // 1 - связь пустого с пустым for i := 0 to ClearsList.Count - 1 do begin ClearConn := TConnectorObject(ClearsList[i]); if (ClearConn <> nil) and (not ClearConn.Deleted) then begin for j := i + 1 to ClearsList.Count - 1 do begin OtherClearConn := TConnectorObject(ClearsList[j]); if (OtherClearConn <> nil) and (not OtherClearConn.Deleted) then begin if ClearConn.ID <> OtherClearConn.ID then if ClearConn.tmpParentDupID = OtherClearConn.tmpParentDupID then begin // SnapConnectorToConnector(ClearConn, OtherClearConn); //Tolik 29/03/2018-- CheckingSnapConnectorToConnector(ClearConn, OtherClearConn); //ClearConn := SnapConnectorToConnector(ClearConn, OtherClearConn); // end; end; end; end; end; // 2 - связь пустого с ТО for i := 0 to ObjectsList.Count - 1 do begin PointConn := TConnectorObject(ObjectsList[i]); GetParentDup := TConnectorObject(GetFigureByID(GCadForm, PointConn.tmpParentDupID)); for j := 0 to GetParentDup.JoinedConnectorsList.Count - 1 do begin ClearConn := TConnectorObject(GetParentDup.JoinedConnectorsList[j]); OtherClearConn := GetJoinedConnForDuplicate(ClearsList, ClearConn.ID); if (OtherClearConn <> nil) and (not OtherClearConn.Deleted) then begin // Tolik -- 03/04/2018 -- //SnapConnectorToPointObject(OtherClearConn, PointConn); CheckingSnapConnectorToPointObject(OtherClearConn, PointConn, False); // end; end; end; // почистить пустые коннекторы for i := 0 to ClearsList.Count - 1 do begin ClearConn := TConnectorObject(ClearsList[i]); if CheckFigureByClassName(ClearConn, cTConnectorObject) then begin if (ClearConn <> nil) and (not ClearConn.Deleted) then begin ClearConn.tmpParentDupID := -1; if (ClearConn.FConnRaiseType = crt_None) and (ClearConn.LockMove) then begin isSP := False; for j := 0 to ClearConn.JoinedOrtholinesList.Count - 1 do if TOrthoLine(ClearConn.JoinedOrtholinesList[j]).FIsRaiseUpDown then isSP := True; if (IsSP) and (ClearConn.JoinedConnectorsList.Count = 0) then begin ClearConn.LockMove := False; ClearConn.LockModify := False; end; end; end; end; end; // занести в Result for i := 0 to TotalList.Count - 1 do begin FFigure := TFigure(TotalList[i]); if (FFigure <> nil) and (not FFigure.Deleted) then if CheckFigureByClassName(FFigure, cTConnectorObject) or CheckFigureByClassName(FFigure, cTOrthoLine) or (FFigure is TNet) then Result.Add(FFigure); end; FreeAndNil(TotalList); FreeAndNil(ClearsList); FreeAndNil(ObjectsList); except on E: Exception do addExceptionToLogEx('U_Common.CreateSCSObjectDuplicates', E.Message); end; //Tolik 15/05/2018 -- if Result.Count = 0 then FreeAndNil(Result); end; function GetJoinedConnForDuplicate(aClearConns: TList; aParentDupID: Integer): TConnectorObject; var i: Integer; ClearConn: TConnectorObject; begin Result := nil; try for i := 0 to aClearConns.Count - 1 do begin ClearConn := TConnectorObject(aClearConns[i]); if (ClearConn <> nil) and (not ClearConn.Deleted) then begin if ClearConn.tmpParentDupID = aParentDupID then Result := ClearConn; end; end; except on E: Exception do addExceptionToLogEx('U_Common.GetJoinedConnForDuplicate', E.Message); end; end; // Tolik 26/09/2018 -- Procedure AutoConnectOverDivideLine(AConnDivider, AConnOther: TConnectorObject; ADividedLine, ANewLine: TOrthoLine; aNoCopyList: TList = nil); //Procedure AutoConnectOverDivideLine(AConnDivider, AConnOther: TConnectorObject; ADividedLine, ANewLine: TOrthoLine); // var i, j: integer; JoinedLine: TOrthoLine; JoinedConn: TConnectorObject; ptrConnectObjParam: PConnectObjectParam; ConnectedLines: TList; ConnectedBeforeRaise: TList; ConnectedAfterRaise: TList; PointObject: TConnectorObject; OtherPointObject: TConnectorObject; AfterConnector: TConnectorObject; BeforeConnector: TConnectorObject; DevidedLineSideJoinedToAfterConn: Integer; procedure DefineConnectedObjectParams(ATargetConnectedObjectParams: TList; AConnectorObject: TConnectorObject; ASkipLine1, ASkipLine2: TOrtholine; AAddConn: Boolean); var i, j: Integer; JoinedLine: TOrthoLine; JoinedConn: TConnectorObject; ptrConnectObjParam: PConnectObjectParam; begin if AAddConn then begin New(ptrConnectObjParam); ptrConnectObjParam.IDObject := AConnectorObject.ID; ptrConnectObjParam.Side := 0; ATargetConnectedObjectParams.Add(ptrConnectObjParam); end; if AConnectorObject.ConnectorType = ct_Clear then for i := 0 to AConnectorObject.JoinedOrtholinesList.Count - 1 do begin JoinedLine := TOrthoLine(AConnectorObject.JoinedOrtholinesList[i]); if (JoinedLine <> ASkipLine1) and (JoinedLine <> ASkipLine2) then begin New(ptrConnectObjParam); ptrConnectObjParam.IDObject := JoinedLine.ID; if JoinedLine.JoinConnector1 = AConnectorObject then ptrConnectObjParam.Side := 1; if JoinedLine.JoinConnector2 = AConnectorObject then ptrConnectObjParam.Side := 2; ATargetConnectedObjectParams.Add(ptrConnectObjParam); end; end else begin for i := 0 to AConnectorObject.JoinedConnectorsList.Count - 1 do begin JoinedConn := TConnectorObject(AConnectorObject.JoinedConnectorsList[i]); for j := 0 to JoinedConn.JoinedOrtholinesList.Count - 1 do begin JoinedLine := TOrthoLine(JoinedConn.JoinedOrtholinesList[j]); if (JoinedLine <> ASkipLine1) and (JoinedLine <> ASkipLine2) then begin New(ptrConnectObjParam); ptrConnectObjParam.IDObject := JoinedLine.ID; if JoinedLine.JoinConnector1 = JoinedConn then ptrConnectObjParam.Side := 1; if JoinedLine.JoinConnector2 = JoinedConn then ptrConnectObjParam.Side := 2; ATargetConnectedObjectParams.Add(ptrConnectObjParam); end; end; end; end; end; function CheckRelatedConns(AConn1, AConn2: TConnectorObject): Boolean; begin Result := false; //Tolik 06/08/2021 -- бывает, что этих коннекторов и нет... (попалось при прокладке трасс от объектов к магистрали, если трасса - наклонная if (AConn1 <> nil) and (aConn2 <> nil) then begin if AConn1 = AConn2 then Result := true else if (AConn1.ConnectorType = ct_Clear) and (AConn1.JoinedConnectorsList.IndexOf(AConn2) <> -1) then Result := true else if (AConn2.ConnectorType = ct_Clear) and (AConn2.JoinedConnectorsList.IndexOf(AConn1) <> -1) then Result := true; end; end; begin ConnectedBeforeRaise := TList.Create; ConnectedAfterRaise := TList.Create; try PointObject := AConnDivider; OtherPointObject := AConnOther; //if (AConn1.ConnectorType = ct_Clear) and (AConn2.ConnectorType <> ct_Clear) then //begin // PointObject := AConn2; // OtherPointObject := AConn1; //end; //13.11.2008 DefineConnectedObjectParams(ConnectedBeforeRaise, PointObject, ANewLine, nil, false); //13.11.2008 DefineConnectedObjectParams(ConnectedAfterRaise, OtherPointObject, ANewLine, nil, true); //13.11.2008 AfterConnector := nil; BeforeConnector := nil; DevidedLineSideJoinedToAfterConn := 0; // проверяем подключение разделенной линии стороной 1 if CheckRelatedConns(TConnectorObject(ADividedLine.JoinConnector1), PointObject) then AfterConnector := PointObject else if CheckRelatedConns(TConnectorObject(ADividedLine.JoinConnector1), OtherPointObject) then AfterConnector := OtherPointObject; if AfterConnector <> nil then DevidedLineSideJoinedToAfterConn := 1 else begin // проверяем подключение разделенной линии стороной 2 if CheckRelatedConns(TConnectorObject(ADividedLine.JoinConnector2), PointObject) then AfterConnector := PointObject else if CheckRelatedConns(TConnectorObject(ADividedLine.JoinConnector2), OtherPointObject) then AfterConnector := OtherPointObject; if AfterConnector <> nil then DevidedLineSideJoinedToAfterConn := 2; end; if DevidedLineSideJoinedToAfterConn > 0 then begin // добавляем разделенную линию в список ConnectedAfterRaise New(ptrConnectObjParam); ptrConnectObjParam.IDObject := ADividedLine.ID; ptrConnectObjParam.Side := DevidedLineSideJoinedToAfterConn; ConnectedAfterRaise.Add(ptrConnectObjParam); if AfterConnector = PointObject then BeforeConnector := OtherPointObject else BeforeConnector := PointObject; // В список ConnectedBeforeRaise добавляем объекты связанные с BeforeConnector if BeforeConnector <> nil then //10.02.2014 DefineConnectedObjectParams(ConnectedBeforeRaise, BeforeConnector, nil, ADividedLine, false); DefineConnectedObjectParams(ConnectedBeforeRaise, BeforeConnector, ANewLine, ADividedLine, true); end; AutoConnectOverRaiseLine(PointObject.ID, ANewLine.ID, ConnectedBeforeRaise, ConnectedAfterRaise, ltTrace, aNoCopyList); except on E: Exception do addExceptionToLogEx('U_Common.AutoConnectOverDivideLine', E.Message); end; if ConnectedBeforeRaise <> nil then FreeList(ConnectedBeforeRaise); if ConnectedAfterRaise <> nil then FreeList(ConnectedAfterRaise); end; Procedure AutoDisconnectOverDivideLine(AConn1, AConn2: TConnectorObject; ALine: TOrthoLine); var JoinedConn: TConnectorObject; ConnectedLines: TList; ConnectedBeforeRaise: TList; ConnectedAfterRaise: TList; PointObject: TConnectorObject; OtherPointObject: TConnectorObject; procedure DefineConnectedObjectParams(ATargetConnectedObjectParams: TList; AConnectorObject: TConnectorObject); var i, j: Integer; JoinedLine: TOrthoLine; JoinedConn: TConnectorObject; ptrConnectObjParam: PConnectObjectParam; begin New(ptrConnectObjParam); ptrConnectObjParam.IDObject := AConnectorObject.ID; ptrConnectObjParam.Side := 0; ATargetConnectedObjectParams.Add(ptrConnectObjParam); if AConnectorObject.ConnectorType = ct_Clear then for i := 0 to AConnectorObject.JoinedOrtholinesList.Count - 1 do begin JoinedLine := TOrthoLine(AConnectorObject.JoinedOrtholinesList[i]); if JoinedLine <> ALine then begin New(ptrConnectObjParam); ptrConnectObjParam.IDObject := JoinedLine.ID; if JoinedLine.JoinConnector1 = AConnectorObject then ptrConnectObjParam.Side := 1; if JoinedLine.JoinConnector2 = AConnectorObject then ptrConnectObjParam.Side := 2; ATargetConnectedObjectParams.Add(ptrConnectObjParam); end; end else begin for i := 0 to AConnectorObject.JoinedConnectorsList.Count - 1 do begin JoinedConn := TConnectorObject(AConnectorObject.JoinedConnectorsList[i]); for j := 0 to JoinedConn.JoinedOrtholinesList.Count - 1 do begin JoinedLine := TOrthoLine(JoinedConn.JoinedOrtholinesList[j]); if JoinedLine <> ALine then begin New(ptrConnectObjParam); ptrConnectObjParam.IDObject := JoinedLine.ID; if JoinedLine.JoinConnector1 = JoinedConn then ptrConnectObjParam.Side := 1; if JoinedLine.JoinConnector2 = JoinedConn then ptrConnectObjParam.Side := 2; ATargetConnectedObjectParams.Add(ptrConnectObjParam); end; end; end; end; end; begin ConnectedBeforeRaise := TList.Create; ConnectedAfterRaise := TList.Create; try PointObject := AConn1; OtherPointObject := AConn2; //if (AConn1.ConnectorType = ct_Clear) and (AConn2.ConnectorType <> ct_Clear) then //begin // PointObject := AConn2; // OtherPointObject := AConn1; //end; // AConnector DefineConnectedObjectParams(ConnectedBeforeRaise, PointObject); // ARaiseConnector DefineConnectedObjectParams(ConnectedAfterRaise, OtherPointObject); AutoDisconnectOverRaiseLine(ALine.ID, ConnectedBeforeRaise, ConnectedAfterRaise); except on E: Exception do addExceptionToLogEx('AutoDisconnectOverDivideLine', E.Message); end; //if ConnectedBeforeRaise <> nil then FreeList(ConnectedBeforeRaise); //if ConnectedAfterRaise <> nil then FreeList(ConnectedAfterRaise); end; function GetFigureObjectByID(aListID, aObjectID: Integer): TFigure; var vList: TF_CAD; vObject: TFigure; begin Result := nil; try vList := GetListByID(aListID); if vList <> nil then begin vObject := GetFigureByID(vList, aObjectID); // найден if vObject <> nil then Result := vObject else // не найден, искать в SCSFigureGroup begin vObject := GetFigureByIDInSCSFigureGroups(vList, aObjectID); if vObject <> nil then Result := vObject; end; end; except on E: Exception do addExceptionToLogEx('U_Common.GetFigureObjectByID', E.Message); end; end; procedure SetNewObjectsIDs(aObjects: TObjectList; aIDs: TIntList); var i, j: Integer; vFigure: TFigure; vID: Integer; Conn: TConnectorObject; begin try if aObjects.Count > 0 then TF_CAD(TPowerCad(TFigure(aObjects[0]).Owner).Owner).FSCSFigures.Clear; for i := 0 to aObjects.Count - 1 do begin vFigure := TFigure(aObjects[i]); vID := aIDs[i]; // коннектор или ортилиния if CheckFigureByClassName(vFigure, cTConnectorObject) or CheckFigureByClassName(vFigure, cTOrthoLine) then begin vFigure.ID := vID; if vFigure.Owner <> nil then TF_CAD(TPowerCad(vFigure.Owner).Owner).AddSCSFigure(vFigure); end else // кабинет if CheckFigureByClassName(vFigure, cTCabinet) then begin TCabinet(vFigure).FSCSID := vID; TCabinet(vFigure).FNumberObject.FCabinetID := TCabinet(vFigure).FSCSID; TCabinet(vFigure).ID := vID; //08.11.2011 if vFigure.Owner <> nil then TF_CAD(TPowerCad(vFigure.Owner).Owner).AddSCSFigure(vFigure); end else // кабинет if CheckFigureByClassName(vFigure, cTCabinetExt) then begin TCabinetExt(vFigure).FSCSID := vID; TCabinetExt(vFigure).FNumberObject.FCabinetID := TCabinetExt(vFigure).FSCSID; TCabinetExt(vFigure).ID := vID; //08.11.2011 if vFigure.Owner <> nil then TF_CAD(TPowerCad(vFigure.Owner).Owner).AddSCSFigure(vFigure); end else // кабинет if CheckFigureByClassName(vFigure, cTHouse) then begin THouse(vFigure).ID := vID; end else // не найден, искать внутри SCSFigureGroup begin end; end; for i := 0 to GCadForm.PCad.FigureCount - 1 do begin if CheckFigureByClassName(TFigure(GCadForm.PCad.Figures[i]), cTConnectorObject) then begin Conn := TConnectorObject(GCadForm.PCad.Figures[i]); if Conn.ConnectorType = ct_Clear then begin if Conn.JoinedConnectorsList.Count > 0 then begin Conn.ID := GenNewSCSID; end; end; end; end; except on E: Exception do addExceptionToLogEx('U_Common.SetNewObjectsIDs', E.Message); end; end; function CanDeleteObjectFromPM(aListID, aObjectID: Integer): Boolean; var i: Integer; vList: TF_CAD; vObject: TFigure; vLine: TOrthoLine; vConn: TConnectorObject; begin Result := True; try vList := GetListByID(aListID); if vList <> nil then begin vObject := GetFigureByID(vList, aObjectID); if vObject <> nil then begin if CheckFigureByClassName(vObject, cTConnectorObject) then begin vConn := TConnectorObject(vObject); for i := 0 to vConn.JoinedOrtholinesList.Count - 1 do if TOrthoLine(vConn.JoinedOrtholinesList[i]).FConnectingLine then Result := False; end else if CheckFigureByClassName(vObject, cTOrthoLine) then begin vLine := TOrthoLine(vObject); if vLine.FConnectingLine then Result := False; end; end; end; except on E: Exception do addExceptionToLogEx('U_Common.CanDeleteObjectFromPM', E.Message); end; end; procedure SetAllTracesAutoLength; var i: Integer; Trace: TOrthoLine; TracesList: TList; begin TracesList := TList.Create; try // Tolik -- 16/09/2016-- так быстрее будет {for i := 0 to GCadForm.PCad.FigureCount - 1 do begin if CheckFigureByClassName(TFigure(GCadForm.PCad.Figures[i]), cTOrthoLine) then TracesList.Add(TFigure(GCadForm.PCad.Figures[i])); end;} for i := 0 to GCadForm.FSCSFigures.Count - 1 do begin if CheckFigureByClassName(TFigure(GCadForm.FSCSFigures[i]), cTOrthoLine) then TracesList.Add(TFigure(GCadForm.FSCSFigures[i])); end; // for i := 0 to TracesList.Count - 1 do begin Trace := TOrthoLine(TracesList[i]); Trace.UserLength := -1; Trace.CalculLength := Trace.LengthCalc; Trace.LineLength := Trace.CalculLength; SetLineFigureLengthInPM(Trace.ID, Trace.LineLength); Trace.UpdateLengthTextBox(True, true); end; except on E: Exception do addExceptionToLogEx('U_Common.SetAllTracesAutoLength', E.Message); end; FreeAndNil(TracesList); end; procedure SetAllTracesUserLength; var i: Integer; Trace: TOrthoLine; TracesList: TList; begin TracesList := TList.Create; try for i := 0 to GCadForm.PCad.FigureCount - 1 do begin if CheckFigureByClassName(TFigure(GCadForm.PCad.Figures[i]), cTOrthoLine) then TracesList.Add(TFigure(GCadForm.PCad.Figures[i])); end; for i := 0 to TracesList.Count - 1 do begin Trace := TOrthoLine(TracesList[i]); if Trace.UserLength = -1 then Trace.UserLength := 0; Trace.CalculLength := Trace.LengthCalc; Trace.LineLength := Trace.CalculLength; SetLineFigureLengthInPM(Trace.ID, Trace.LineLength); Trace.UpdateLengthTextBox(True, true); end; except on E: Exception do addExceptionToLogEx('U_Common.SetAllTracesUserLength', E.Message); end; FreeAndNil(TracesList); end; function CheckFigureByClassName(aFigure: TFigure; const aClassName: string): Boolean; begin Result := False; try if aFigure <> nil then begin if aFigure.ClassName = aClassName then Result := True; end; except on E: Exception do Result := False; end; //GProcCnt := GProcCnt + 1; end; function CheckFigureByClassIdx(aFigure: TFigure; const aClassIdx: Integer): Boolean; begin Result := False; try if aFigure <> nil then begin if aFigure.FClassIndex = aClassIdx then Result := True; end; except on E: Exception do Result := False; end; end; procedure SetExistOtherObjectType(aListID, aObjectID: Integer; aExist: Boolean); var FList: TF_CAD; FLine: TOrthoLine; begin try FList := GetListByID(aListID); if FList <> nil then begin FLine := TOrthoLine(GetFigureByID(FList, aObjectID)); if FLine <> nil then begin Fline.FExistOtherObjectType := aExist; end; end; except on E: Exception do addExceptionToLogEx('U_Common.SetExistOtherObjectType', E.Message); end; end; function GetTrunkNumber(aLine: TOrthoLine): string; var i, j: Integer; StartConn, CurConn, JoinConn: TConnectorObject; CadCrossObject: TCADCrossObject; CadCrossObjectElement: TCADCrossObjectElement; CrossesList: TList; DistribsList: TList; CurCross, FindedCross: TConnectorObject; FindedPos: Integer; FindedTrace: TList; begin // Tolik 07/02/2017 -- FindedTrace := nil; // CrossesList := TList.Create; DistribsList := TList.Create; try Result := ''; FindedCross := nil; FindedPos := -1; StartConn := TConnectorObject(aLine.JoinConnector1); // Найти все Кросс АТС for i := 0 to GCadForm.PCad.FigureCount - 1 do begin If CheckFigureByClassName(TFigure(GCadForm.PCad.Figures[i]), cTConnectorObject) then begin CurConn := TConnectorObject(GCadForm.PCad.Figures[i]); if CurConn.FTrunkName = ctsnCrossATS then CrossesList.Add(CurConn); if CurConn.FTrunkName = ctsnDistributionCabinet then DistribsList.Add(CurConn); end; end; // перебрать список кроссов for i := 0 to CrossesList.Count - 1 do begin CurCross := TConnectorObject(CrossesList[i]); FindedTrace := GetAllTraceInCAD(CurCross, StartConn); // нашли нужный кросс if FindedTrace <> nil then begin FindedCross := CurCross; // Tolik -- 07/02/2017 -- FreeAndNil(FindedTrace); // Break; end; end; // найти номер магистрали от найденного кросса if FindedCross <> nil then begin // не трассировать через кроссы for i := 0 to CrossesList.Count - 1 do TConnectorObject(CrossesList[i]).FDisableTracing := True; for i := 0 to DistribsList.Count - 1 do TConnectorObject(DistribsList[i]).FDisableTracing := True; for i := 0 to FindedCross.JoinedConnectorsList.Count - 1 do begin JoinConn := TConnectorObject(FindedCross.JoinedConnectorsList[i]); FindedTrace := GetAllTraceInCAD(JoinConn, StartConn); if FindedTrace <> nil then begin FindedPos := i; // Tolik -- 07/02/2017 -- FreeAndNil(FindedTrace); // Break; end; end; // убрать флаг for i := 0 to CrossesList.Count - 1 do TConnectorObject(CrossesList[i]).FDisableTracing := False; for i := 0 to DistribsList.Count - 1 do TConnectorObject(DistribsList[i]).FDisableTracing := False; // обработать саму позицию if FindedPos <> -1 then begin CadCrossObject := GetPointObjectConnectedTrunk(GCadForm.FCADListID, FindedCross.ID); if CadCrossObject <> nil then begin // Tolik -- 31/08/2016 -- Object -- есть, а вот элементов может и не быть...тут выдавало ошибку именно поэтому if CadCrossObject.Elements.Count > 0 then begin // CadCrossObjectElement := TCADCrossObjectElement(CadCrossObject.Elements[FindedPos]); if CadCrossObjectElement <> nil then Result := CadCrossObjectElement.Npp; end; end; end; end; except on E: Exception do addExceptionToLogEx('U_Common.GetTrunkNumber', E.Message); end; FreeAndNil(CrossesList); FreeAndNil(DistribsList); end; function SCSGroupSelection: TSCSFigureGrp; var i: integer; FFigure: TFigure; grp: TSCSFigureGrp; sel: TList; SelMod: TList; cnt: integer; RaiseConn: TConnectorObject; RaiseLine: TOrthoLine; ObjFromRaise: TConnectorObject; Conn1, Conn2: TConnectorObject; CanRefreshCadFlag: Boolean;//Tolik 17/02/2022 -- begin Result := nil; sel := TList.Create; SelMod := Nil; try // Tolik -- 07/02/2017 -- // SelMod := TList.Create; CanRefreshCadFlag := GCanRefreshCad; GCanRefreshCad := False; GCadForm.PCad.collectselectedFigures(sel); //Tolik 07/04/2022 -- if GEndPoint <> nil then begin if sel.indexOf(GEndPoint) <> -1 then begin TConnectorObject(GEndPoint).AsEndPoint := False; GEndPoint := Nil; GListWithEndPoint := Nil; end; end; // cnt := sel.count; sel.Clear; // Tolik -- 07/02/2017 -- if cnt = 0 then // exit begin FreeAndNil(Sel); GCanRefreshCad := CanRefreshCadFlag; // Tolik 17/02/2022 -- exit; end; SelMod := TList.Create; // grp := TSCSFigureGrp.create(LongInt(GCadForm.PCad.Layers[2]), GCadForm.PCad); for i := GCadForm.PCad.figures.count - 1 downto 0 do begin FFigure := Tfigure(GCadForm.PCad.figures[i]); if FFigure.Selected then begin FFigure.Deselect; if CheckNoFigureInList(FFigure, sel) then begin if CheckFigureByClassName(FFigure, cTConnectorObject) then begin if not TConnectorObject(FFigure).FIsApproach then sel.Add(FFigure); end; if CheckFigureByClassName(FFigure, cTOrthoLine) then begin sel.Add(FFigure); end; end; end; end; // Correct for External if GCadForm.FSCSType = st_External then begin for i := 0 to sel.Count - 1 do begin FFigure := TFigure(sel[i]); if CheckFigureByClassName(FFigure, cTOrthoLine) then begin Conn1 := TConnectorObject(TOrthoLine(FFigure).JoinConnector1); Conn2 := TConnectorObject(TOrthoLine(FFigure).JoinConnector2); if CheckNoFigureInList(Conn1, sel) then sel.Add(Conn1); if CheckNoFigureInList(Conn2, sel) then sel.Add(Conn2); end; end; end; for i := sel.count - 1 downto 0 do begin FFigure := TFigure(sel[i]); if CheckNoFigureInList(FFigure, SelMod) then SelMod.Add(FFigure); if CheckFigureByClassName(FFigure, cTConnectorObject) then begin if TConnectorObject(FFigure).ConnectorType = ct_Clear then begin RaiseConn := nil; RaiseLine := nil; if TConnectorObject(FFigure).JoinedConnectorsList.Count > 0 then ObjFromRaise := TConnectorObject(TConnectorObject(FFigure).JoinedConnectorsList[0]) else ObjFromRaise := TConnectorObject(FFigure); RaiseConn := GetRaiseConn(ObjFromRaise); if RaiseConn <> nil then RaiseLine := GetRaiseLine(RaiseConn); if RaiseConn <> nil then if CheckNoFigureInList(RaiseConn, SelMod) then begin SelMod.Add(RaiseConn); end; if RaiseLine <> nil then if CheckNoFigureInList(RaiseLine, SelMod) then begin SelMod.Add(RaiseLine); end; end; end; end; GCanRefreshCad := True; GCadForm.PCad.DeselectAll(GCadForm.PCad.ActiveLayer); GCadform.PCad.RefreshSelection; GCanRefreshCad := False; for i := SelMod.count - 1 downto 0 do begin FFigure := TFigure(SelMod[i]); GCadForm.PCad.Figures.Remove(FFigure); grp.AddFigure(FFigure); if CheckFigureByClassName(FFigure, cTConnectorObject) then begin TConnectorObject(FFigure).FGroupObject := grp; end; if CheckFigureByClassName(FFigure, cTOrthoLine) then begin TOrthoLine(FFigure).FGroupObject := grp; end; end; grp.select; GCadForm.PCad.AddCustomFigure(2, grp, False); grp.CreateMetaFile; GCanRefreshCad := True; // Tolik 17/02/2022 -- RefreshCAD(GCadForm.PCad); Result := grp; except //Tolik 17/02/2022 -- //on E: Exception do addExceptionToLogEx('U_Common.SCSGroupSelections', E.Message); on E: Exception do begin GCanRefreshCad := CanRefreshCadFlag; addExceptionToLogEx('U_Common.SCSGroupSelections', E.Message); end; end; FreeAndNil(sel); if SelMod <> nil then FreeAndNil(SelMod); GCanRefreshCad := CanRefreshCadFlag; GCadForm.PCad.needrefresh := True; //Tolik 05/04/2022 -- RefreshCAD(GCadForm.PCad); //Tolik 05/04/2021 -- end; function SCSGroupObjects(aObjects: TList): TSCSFigureGrp; var i: integer; FFigure: TFigure; grp: TSCSFigureGrp; begin Result := nil; try grp := TSCSFigureGrp.create(LongInt(GCadForm.PCad.Layers[2]), GCadForm.PCad); for i := aObjects.count - 1 downto 0 do begin FFigure := TFigure(aObjects[i]); if (FFigure <> nil) and (not FFigure.Deleted) then begin GCadForm.PCad.Figures.Remove(FFigure); grp.AddFigure(FFigure); if CheckFigureByClassName(FFigure, cTConnectorObject) then if (not TConnectorObject(FFigure).FIsApproach) and (not TConnectorObject(FFigure).FIsHouseJoined) then begin TConnectorObject(FFigure).FGroupObject := grp; end; if CheckFigureByClassName(FFigure, cTOrthoLine) then begin TOrthoLine(FFigure).FGroupObject := grp; end; end; end; GCadForm.PCad.AddCustomFigure(2, grp, False); grp.CreateMetaFile; RefreshCAD(GCadForm.PCad); Result := grp; except on E: Exception do addExceptionToLogEx('U_Common.SCSGroupObjects', E.Message); end; end; Procedure SCSUngroupSelection; var i: Integer; FFigure: TFigure; begin try for i := GCadForm.PCad.Figures.count - 1 downto 0 do begin FFigure := TFigure(GCadForm.PCad.Figures[i]); if CheckFigureByClassName(FFigure, cTSCSFigureGrp) and (FFigure.selected) then begin if not TFigureGrp(FFigure).AlwaysTogether then begin TSCSFigureGrp(FFigure).UnGroup; // Tolik -- 14/03/2016 -- НЕ УДАЛИТЬ С КАДА, А УДАЛИТЬ ФИГУРУ, А ТО ЧТО-ТО НА ПОТЕНЦИАЛЬНУЮ УТЕЧКУ ПАМЯТИ ПОХОЖЕ // GCadForm.PCad.Figures.Delete(i); TSCSFigureGrp(FFigure).InFigures.Clear; // ТУТ INFIGURES УЖЕ НА КАД ВКИНУТЫ ПРИ РАЗГРУППИРОВКЕ TSCSFigureGrp(FFigure).Delete; // end; end; end; // Tolik -- 14/03/2016 -- если вот этого не сделать, разгруппированные объекты под мышкой не будут определяться // при наведении курсора на объект GCadForm.FNeedUpdateCheckedFigures := true; // RefreshCAD(GCadForm.PCad); if not GProjectChanged then // Tolik 28/08/2019 -- SetProjectChanged(true); // Tolik -- 14/03/2016 -- чтобы был доступен Save проекта/листа // except on E: Exception do addExceptionToLogEx('U_Common.SCSGroupSelections', E.Message); end; end; function IsLockedObject(aListID, aObjectID: Integer): Boolean; var vList: TF_CAD; vObject: TFigure; begin Result := False; try vList := GetListByID(aListID); if vList <> nil then begin vObject := GetFigureByID(vList, aObjectID); if vObject = nil then begin vObject := GetFigureByIDInSCSFigureGroups(vList, aObjectID); if vObject <> nil then Result := True; end; end; except on E: Exception do addExceptionToLogEx('U_Common.IsLockedObject', E.Message); end; end; procedure DisconnectConn(AConn: TConnectorObject); var NextConnector: TConnectorObject; JoinedLine1, JoinedLine2: TOrthoLine; i: integer; JoinedConn: TConnectorObject; CP_Line: TDoublePoint; OtherConn: TConnectorObject; OtherConnPoints: TDoublePoint; begin BeginProgress; try JoinedLine1 := TOrthoLine(AConn.JoinedOrtholinesList[0]); JoinedLine2 := TOrthoLine(AConn.JoinedOrtholinesList[1]); if JoinedLine2.JoinConnector1 = AConn then begin NextConnector := TConnectorObject(JoinedLine2.JoinConnector2); if NextConnector.JoinedConnectorsList.Count > 0 then OtherConn := TConnectorObject(NextConnector.JoinedConnectorsList[0]) else OtherConn := NextConnector; OtherConnPoints := OtherConn.ActualPoints[1]; AutoDisconnectOverDivideLine(AConn, OtherConn, JoinedLine2); TOrthoLine(JoinedLine2).Delete; RefreshCAD(GCadForm.PCad); AConn.Move(OtherConnPoints.x - AConn.ActualPoints[1].x, OtherConnPoints.y - AConn.ActualPoints[1].y); if OtherConn.ConnectorType = ct_Clear then begin if (OtherConn <> nil) and (not OtherConn.Deleted) then //SnapConnectorToConnector(AConn, OtherConn); //Tolik -- 29/03/2018 -- //AConn := SnapConnectorToConnector(AConn, OtherConn); CheckingSnapConnectorToConnector(AConn, OtherConn); // end else begin //Tolik -- 03/04/2018 -- //SnapConnectorToPointObject(AConn, OtherConn); CheckingSnapConnectorToPointObject(AConn, OtherConn, False); // end; end else if JoinedLine2.JoinConnector2 = AConn then begin NextConnector := TConnectorObject(JoinedLine2.JoinConnector1); if NextConnector.JoinedConnectorsList.Count > 0 then OtherConn := TConnectorObject(NextConnector.JoinedConnectorsList[0]) else OtherConn := NextConnector; OtherConnPoints := OtherConn.ActualPoints[1]; AutoDisconnectOverDivideLine(AConn, OtherConn, JoinedLine2); TOrthoLine(JoinedLine2).Delete; RefreshCAD(GCadForm.PCad); AConn.Move(OtherConnPoints.x - AConn.ActualPoints[1].x, OtherConnPoints.y - AConn.ActualPoints[1].y); if OtherConn.ConnectorType = ct_Clear then begin if (OtherConn <> nil) and (not OtherConn.Deleted) then // SnapConnectorToConnector(AConn, OtherConn); // Tolik 29/03/2018 -- //AConn := SnapConnectorToConnector(AConn, OtherConn); CheckingSnapConnectorToConnector(AConn, OtherConn); // end else begin // Tolik 03/04/2018 -- //SnapConnectorToPointObject(AConn, OtherConn); CheckingSnapConnectorToPointObject(AConn, OtherConn, False); // end; end; if JoinedLine1 <> nil then JoinedLine1.ReCreateDrawFigureBlock; except on E: Exception do addExceptionToLogEx('U_Common.DisconnectConn', E.Message); end; EndProgress; end; procedure DisconnectTraces(aConn: TConnectorObject); var i, j: Integer; x, y, z: double; JoinedLine: TOrthoLine; CreatedConn: TConnectorObject; isDisconnected: Boolean; ptrInterfRecord1, ptrInterfRecord2: PConnectObjectParam; ParamsList1, ParamsList2: TList; begin // Tolik 09/02/2017 -- ParamsList1 := nil; ParamsList2 := nil; // BeginProgress; try x := aConn.ActualPoints[1].x; y := aConn.ActualPoints[1].y; z := aConn.ActualZOrder[1]; if aConn.JoinedOrtholinesList.Count > 1 then begin ParamsList1 := TList.create; ParamsList2 := TList.create; for i := 0 to aConn.JoinedOrtholinesList.Count - 1 do begin JoinedLine := TOrthoLine(aConn.JoinedOrtholinesList[i]); CreatedConn := TConnectorObject.Create(x, y, z, aConn.LayerHandle, mydsNormal, GCadForm.PCad); CreatedConn.ConnectorType := ct_Clear; GCadForm.PCad.AddCustomFigure(2, CreatedConn, False); if JoinedLine.JoinConnector1 = aConn then JoinedLine.SetJConnector1(CreatedConn); if JoinedLine.JoinConnector2 = aConn then JoinedLine.SetJConnector2(CreatedConn); // ParamsList1 if i = 0 then begin New(ptrInterfRecord1); ptrInterfRecord1.IDObject := JoinedLine.ID; if aConn = JoinedLine.JoinConnector1 then ptrInterfRecord1.Side := 1; if aConn = JoinedLine.JoinConnector2 then ptrInterfRecord1.Side := 2; ParamsList1.Add(ptrInterfRecord1); end else // ParamsList2 begin New(ptrInterfRecord2); ptrInterfRecord2.IDObject := JoinedLine.ID; if aConn = JoinedLine.JoinConnector1 then ptrInterfRecord2.Side := 1; if aConn = JoinedLine.JoinConnector2 then ptrInterfRecord2.Side := 2; ParamsList2.Add(ptrInterfRecord2); end; end; // isDisconnected := DisconnectObjectsInPM(ParamsList1, ParamsList2); aConn.Delete(False, False); RefreshCAD(GCadForm.PCad); end; except on E: Exception do addExceptionToLogEx('U_Common.DisconnectTraces', E.Message); end; EndProgress; // // Tolik 09/02/2017 -- if ParamsList1 <> nil then begin for i := 0 to ParamsList1.Count - 1 do begin Dispose(PConnectObjectParam(ParamsList1[i])); end; FreeAndNil(ParamsList1); end; if ParamsList2 <> nil then begin for i := 0 to ParamsList2.Count - 1 do begin Dispose(PConnectObjectParam(ParamsList2[i])); end; FreeAndNil(ParamsList2); end; // end; // Tolik 21/11/2016 --- старая закомменчена -- смотри ниже // переписано, чтобы не удалять просто и бездумно райз на поинте, т.к. с другой стороны // на райзе тоже могут быть трассы procedure DisconnectPointObject(aObject: TConnectorObject); var i: integer; PointObject: TConnectorObject; RaiseConn: TConnectorObject; RaiseLine: TOrthoLine; ConnectedConn: TConnectorObject; PrevConnector: TConnectorObject; ConnectedList: TList; begin // Tolik -- 09/02/2017 -- ConnectedList := nil; // BeginProgress; try RaiseConn := nil; RaiseLine := nil; ConnectedConn := nil; //#From Oleg# //14.09.2010 // это с-п if aObject.FObjectFromRaise <> nil then begin RaiseConn := aObject.FObjectFromRaise; RaiseLine := GetRaiseLine(aObject); //RaiseLine.Delete; //RefreshCAD(GCadForm.PCad); end; // на объекте есть с-п if GetRaiseConn(aObject) <> nil then begin RaiseConn := GetRaiseConn(aObject); RaiseLine := GetRaiseLine(RaiseConn); //RaiseLine.Delete; //RefreshCAD(GCadForm.PCad); end; ConnectedList := TList.Create; for i := 0 to aObject.JoinedConnectorsList.Count - 1 do ConnectedList.Add(aObject.JoinedConnectorsList[i]); if ConnectedList.Count > 0 then begin // рассоединить с трассами на одном уровне for i := 0 to ConnectedList.Count - 1 do begin ConnectedConn := TConnectorObject(ConnectedList[i]); UnsnapConnectorFromPointObject(ConnectedConn, aObject); end; PrevConnector := TConnectorObject(ConnectedList[0]); for i := 1 to ConnectedList.Count - 1 do begin ConnectedConn := TConnectorObject(ConnectedList[i]); // SnapConnectorToConnector(ConnectedConn, PrevConnector); // Tolik --29/03/2018 -- //ConnectedConn := SnapConnectorToConnector(ConnectedConn, PrevConnector); CheckingSnapConnectorToConnector(ConnectedConn, PrevConnector); // PrevConnector := ConnectedConn; end; ConnectedConn.Move(aObject.ActualPoints[1].x - ConnectedConn.ActualPoints[1].x, aObject.ActualPoints[1].y - ConnectedConn.ActualPoints[1].y); end; // вот здесь на проверочке райз и удалится, если нужно if RaiseLine <> nil then begin if RaiseLine.FObjectFromRaisedLine = aObject then RaiseLine.FObjectFromRaisedLine := ConnectedConn; if TConnectorObject(RaiseLine.JoinConnector1).FObjectFromRaise = aObject then TConnectorObject(RaiseLine.JoinConnector1).FObjectFromRaise := ConnectedConn; if TConnectorObject(RaiseLine.JoinConnector2).FObjectFromRaise = aObject then TConnectorObject(RaiseLine.JoinConnector2).FObjectFromRaise := ConnectedConn; CheckDeleteRaise(RaiseLine); end; aObject.Move(GCadForm.PCad.GridStep, GCadForm.PCad.GridStep); except on E: Exception do addExceptionToLogEx('U_Common.DisconnectPointObject', E.Message); end; EndProgress; if ConnectedList <> nil then FreeAndNil(ConnectedList); end; (* procedure DisconnectPointObject(aObject: TConnectorObject); var i: integer; PointObject: TConnectorObject; RaiseConn: TConnectorObject; RaiseLine: TOrthoLine; ConnectedConn: TConnectorObject; PrevConnector: TConnectorObject; ConnectedList: TList; begin BeginProgress; try // CheckDeleteRaise(RaiseLine); ConnectedConn := nil; //#From Oleg# //14.09.2010 // это с-п if aObject.FObjectFromRaise <> nil then begin RaiseConn := aObject.FObjectFromRaise; RaiseLine := GetRaiseLine(aObject); RaiseLine.Delete; RefreshCAD(GCadForm.PCad); end; // на объекте есть с-п if GetRaiseConn(aObject) <> nil then begin RaiseConn := GetRaiseConn(aObject); RaiseLine := GetRaiseLine(RaiseConn); RaiseLine.Delete; RefreshCAD(GCadForm.PCad); end; ConnectedList := TList.Create; for i := 0 to aObject.JoinedConnectorsList.Count - 1 do ConnectedList.Add(aObject.JoinedConnectorsList[i]); if ConnectedList.Count > 0 then begin // рассоединить с трассами на одном уровне for i := 0 to ConnectedList.Count - 1 do begin ConnectedConn := TConnectorObject(ConnectedList[i]); UnsnapConnectorFromPointObject(ConnectedConn, aObject); end; PrevConnector := TConnectorObject(ConnectedList[0]); for i := 1 to ConnectedList.Count - 1 do begin ConnectedConn := TConnectorObject(ConnectedList[i]); SnapConnectorToConnector(ConnectedConn, PrevConnector); PrevConnector := ConnectedConn; end; ConnectedConn.Move(aObject.ActualPoints[1].x - ConnectedConn.ActualPoints[1].x, aObject.ActualPoints[1].y - ConnectedConn.ActualPoints[1].y); end; if ConnectedList <> nil then FreeAndNil(ConnectedList); aObject.Move(GCadForm.PCad.GridStep, GCadForm.PCad.GridStep); except on E: Exception do addExceptionToLogEx('U_Common.DisconnectPointObject', E.Message); end; EndProgress; end; *) procedure DeleteAllTraces; var i: Integer; Trace: TOrthoLine; TracesList: TList; //Tolik -- 21/04/2017 -- RefreshFlag: Boolean; // begin // Tolik 21/04/2017 -- RefreshFlag := GCanRefreshCad; GCanRefreshCad := False; TracesList := TList.Create; try // Tolik -- 28/06/2016 -- // for i := 0 to GCadForm.PCad.FigureCount - 1 do for i := 0 to GCadForm.FSCSFigures.Count - 1 do begin if CheckFigureByClassName(TFigure(GCadForm.FSCSFigures[i]), cTOrthoLine) then begin Trace := TOrthoLine(GCadForm.FSCSFigures[i]); TracesList.Add(Trace); end; end; BeginProgress; GisGroupUpdate := True; // for i := 0 to TracesList.Count - 1 do begin Trace := TOrthoLine(TracesList[i]); Trace.Delete; end; // Tolik -- 21/04/2017 -- GisGroupUpdate := False; EndProgress; GCanRefreshCad := RefreshFlag; RefreshCAD(GCadForm.PCad); // except on E: Exception do begin addExceptionToLogEx('DeleteAllTraces', E.Message); //Toik -- 21/04/2017 -- GisGroupUpdate := False; RefreshCAD(GCadForm.PCad); // end; end; GCanRefreshCad := RefreshFlag; FreeAndNil(TracesList); end; procedure DeleteSCSFigureGrps(aListID: Integer); var i: Integer; vList: TF_CAD; SavedCadForm: TF_CAD; SCSFigureGrp: TSCSFigureGrp; GrpList: TList; begin GrpList := Nil; try vList := GetListByID(aListID); if vList <> nil then begin SavedCadForm := GCadForm; GCadForm := vList; GrpList := TList.Create; for i := 0 to vList.PCad.FigureCount - 1 do begin if CheckFigureByClassName(TFigure(vList.PCad.Figures[i]), cTSCSFigureGrp) then begin SCSFigureGrp := TSCSFigureGrp(vList.PCad.Figures[i]); GrpList.Add(SCSFigureGrp); end; end; for i := 0 to GrpList.Count - 1 do begin SCSFigureGrp := TSCSFigureGrp(GrpList[i]); SCSFigureGrp.Delete; end; FreeAndNil(GrpList); GCadForm := SavedCadForm; end; except on E: Exception do addExceptionToLogEx('U_Common.DeleteSCSFigureGrps', E.Message); end; if GrpList <> nil then GrpList.free; // Tolik 15/05/2018 -- на всякий end; function CheckAnyButFigureGrp(aFiguresList: TList): Boolean; var i: Integer; Figure: TFigure; begin Result := False; try for i := 0 to aFiguresList.Count - 1 do begin Figure := TFigure(aFiguresList[i]); if not CheckFigureByClassName(Figure, cTSCSFigureGrp) then // Tolik -- 20/11/2015 - нашли, так нех дальше бегать, результат не изменится // Result := True; -- так было begin Result := True; break; end; end; except on E: Exception do addExceptionToLogEx('U_Common.CheckAnyButFigureGrp', E.Message); end; end; procedure ChangeDrawFigurePercentForObject(aObject: TConnectorObject; aPercent: Double); var MapScale: Double; CorrectX: Double; CorrectY: Double; Bnd: TDoubleRect; begin try MapScale := GCadForm.PCad.MapScale; // вернуть на 0 градус aObject.Rotate(0 - aObject.FDrawFigureAngle, aObject.ActualPoints[1]); if aObject.DrawFigure <> nil then aObject.DrawFigure.Rotate(0 - aObject.FDrawFigureAngle, aObject.ActualPoints[1]); // изменить размеры // BND Bnd := aObject.DrawFigure.GetBoundRect; aObject.GrpSizeX := abs(Bnd.Right - Bnd.Left); aObject.GrpSizeY := abs(Bnd.Bottom - Bnd.Top); CorrectX := aObject.FOriginalSizeX / aObject.GrpSizeX; CorrectY := aObject.FOriginalSizeY / aObject.GrpSizeY; // correct aObject.Scale(CorrectX, CorrectY, aObject.ActualPoints[1]); aObject.DrawFigure.Scale(CorrectX, CorrectY, aObject.ActualPoints[1]); // percent aObject.Scale(aPercent / 100, aPercent / 100, aObject.ActualPoints[1]); aObject.DrawFigure.Scale(aPercent / 100, aPercent / 100, aObject.ActualPoints[1]); aObject.FDrawFigurePercent := aPercent; // BND Bnd := aObject.DrawFigure.GetBoundRect; aObject.GrpSizeX := abs(Bnd.Right - Bnd.Left); aObject.GrpSizeY := abs(Bnd.Bottom - Bnd.Top); // повернуть назад aObject.Rotate(aObject.FDrawFigureAngle, aObject.ActualPoints[1]); if aObject.DrawFigure <> nil then aObject.DrawFigure.Rotate(aObject.FDrawFigureAngle, aObject.ActualPoints[1]); aObject.DefRaizeDrawFigurePos; // Recreate aObject.ReCreateCaptionsGroup(True, false); aObject.ReCreateNotesGroup(True); except on E: Exception do addExceptionToLogEx('U_Common.ChangeDrawFigurePercentForObject', E.Message); end; end; procedure ChangeDrawFigurePercentForLine(aLine: TOrthoLine; aPercent: Double); var i: Integer; MapScale: Double; CorrectX: Double; CorrectY: Double; Bnd: TDoubleRect; CP: TDoublePoint; GrpSizeX, GrpSizeY: Double; tmpDrawFigure: TFigureGrpMod; BlockBnd: TDoubleRect; DrawFigureBnd: TDoubleRect; BlockDelta: double; deltax, deltay: double; InFigGroup, InFigGroup1, InFigGroup2: TFigureGrpMod; delta: double; ScaleKoeff: Double; begin try if aLine.FIsRaiseUpDown then begin if aLine.FSingleBlock <> nil then begin {for i := 0 to aLine.DrawFigure.InFigures.Count - 1 do begin InFigGroup := TFigureGrpMod(aLine.FSingleBlock.InFigures[i]); //InFigGroup.Scale(CorrectX, CorrectY, InFigGroup.CenterPoint); InFigGroup.Scale(aPercent / 100, aPercent / 100, InFigGroup.CenterPoint); end; } CP.x := (aLine.ActualPoints[1].x + aLine.ActualPoints[2].x) / 2; CP.y := (aLine.ActualPoints[1].y + aLine.ActualPoints[2].y) / 2; InFigGroup := TFigureGrpMod(aLine.FSingleBlock.Duplicate); //InFigGroup.scale(1, 1, InFigGroup.CenterPoint); //InFigGroup.scale(0.5*1, 0.5*1, InFigGroup.CenterPoint); //InFigGroup.scale(1/aLine.FDrawFigurePercent, 1/aLine.FDrawFigurePercent, InFigGroup.CenterPoint); ScaleKoeff := 1/(aLine.FDrawFigurePercent/100 * 0.5); InFigGroup.scale(ScaleKoeff, ScaleKoeff, InFigGroup.CenterPoint); InFigGroup.Rotate(0 - aLine.FDrawFigureAngle, CP); //InFigGroup.scale(aPercent / 100, aPercent / 100, InFigGroup.CenterPoint); aLine.FDrawFigurePercent := aPercent; SetBlockForLineObject(aLine, nil, nil); aLine.DrawFigure := InFigGroup; //27.04.2013 - чтобы вызвать TOrthoLine.SetDrawFigure end; end else begin MapScale := GCadForm.PCad.MapScale; // вернуть на 0 градус CP.x := (aLine.ActualPoints[1].x + aLine.ActualPoints[2].x) / 2; CP.y := (aLine.ActualPoints[1].y + aLine.ActualPoints[2].y) / 2; if aLine.DrawFigure <> nil then aLine.DrawFigure.Rotate(0 - aLine.FDrawFigureAngle, CP); // Если есть блок if aLine.FSingleBlock <> nil then begin aLine.DrawFigure.RemoveFromGrp(aLine.FSingleBlock); //28.04.2011 aLine.DrawFigure.InFigures.Remove(aLine.FSingleBlock); RemoveInFigureGrp(aLine.DrawFigure); // изменить размеры // BND if aLine.FSingleBlock.InFigures.Count = 0 then begin Bnd := aLine.FSingleBlock.GetBoundRect; end else begin Bnd := TFigure(aLine.FSingleBlock.InFigures[0]).GetBoundRect; end; GrpSizeX := abs(Bnd.Right - Bnd.Left); GrpSizeY := abs(Bnd.Bottom - Bnd.Top); // Tolik 02/04/2020 -- //CorrectX := aLine.FOriginalSizeX / GrpSizeX; //CorrectY := aLine.FOriginalSizeY / GrpSizeY; if GrpSizeX = 0 then CorrectX := 0 else CorrectX := aLine.FOriginalSizeX / GrpSizeX; if GrpSizeY = 0 then CorrectY := 0 else CorrectY := aLine.FOriginalSizeY / GrpSizeY; // for i := 0 to aLine.FSingleBlock.InFigures.Count - 1 do begin InFigGroup := TFigureGrpMod(aLine.FSingleBlock.InFigures[i]); InFigGroup.Scale(CorrectX, CorrectY, InFigGroup.CenterPoint); InFigGroup.Scale(aPercent / 100, aPercent / 100, InFigGroup.CenterPoint); end; if aLine.FSingleBlock.InFigures.Count = 2 then begin InFigGroup1 := TFigureGrpMod(aLine.FSingleBlock.InFigures[0]); InFigGroup2 := TFigureGrpMod(aLine.FSingleBlock.InFigures[1]); Bnd := InFigGroup1.GetBoundRect; delta := abs(Bnd.Bottom - Bnd.Top); delta := delta / 2; if not aLine.FIsRotated then InFigGroup2.move(0, InFigGroup1.CenterPoint.y - InFigGroup2.CenterPoint.y + delta) else InFigGroup2.move(0, InFigGroup1.CenterPoint.y - InFigGroup2.CenterPoint.y - delta); aLine.FSingleBlockDelta := 0; end; aLine.FDrawFigurePercent := aPercent; // присвоить темповому DrawFigure tmpDrawFigure := aLine.GetAllBlocks(aLine.FSingleBlock); // перебросить в DrawFigure for i := 0 to tmpDrawFigure.InFigures.Count - 1 do begin aLine.DrawFigure.AddFigure(TFigure(tmpDrawFigure.InFigures[i])); end; if aLine.FSingleBlock.InFigures.Count = 0 then begin BlockBnd := aLine.FSingleBlock.GetBoundRect; end else begin BlockBnd := TFigure(aLine.FSingleBlock.InFigures[0]).GetBoundRect; end; DrawFigureBnd := aLine.DrawFigure.GetBoundRect; aLine.GrpSizeX := DrawFigureBnd.Right - DrawFigureBnd.Left; aLine.GrpSizeY := BlockBnd.Bottom - BlockBnd.Top; BlockDelta := 0.2 / 2 * (aLine.FSingleBlock.InFigures.Count - 1); aLine.DrawFigure.ActualPoints[1] := DoublePoint((DrawFigureBnd.Left + DrawFigureBnd.Right) / 2 - aLine.GrpSizeX / 2, (BlockBnd.Top + BlockBnd.Bottom) / 2 - aLine.GrpSizeY / 2); deltax := cp.x - aLine.GrpSizeX / 2 - aLine.DrawFigure.ActualPoints[1].x; deltay := cp.y - aLine.GrpSizeY / 2 - aLine.DrawFigure.ActualPoints[1].y; aLine.DrawFigure.move(deltax, deltay); aLine.DrawFigure.LockModify := True; aLine.MoveTextBox(aLine.DrawFigure, aLine.ActualPoints[1], aLine.ActualPoints[2], True); end; end; except on E: Exception do addExceptionToLogEx('U_Common.ChangeDrawFigurePercentForLine', E.Message); end; end; function GetTraceLength(aListID, aTraceID: Integer): Double; var FList: TF_CAD; i: Integer; Trace: TOrthoLine; begin Result := -1; try FList := GetListByID(aListID); if FList <> nil then begin Trace := TOrthoLine(GetFigureByID(FList, aTraceID)); if Trace <> nil then Result := Trace.LineLength; end; except on E: Exception do addExceptionToLogEx('U_Common.GetTraceLength', E.Message); end; end; procedure CloseCad(aListID: Integer); var FList: TF_CAD; begin try FList := GetListByID(aListID); if FList <> nil then TF_CAD(FList).Close; except on E: Exception do addExceptionToLogEx('U_Common.CloseCad', E.Message); end; end; procedure SetProjectChanged(aChanged: Boolean); begin if GIsProjectOpening then // Tolik 25/01/2022 -- exit; try GProjectChanged := aChanged; FSCS_Main.aSaveProject.Enabled := aChanged; except on E: Exception do addExceptionToLogEx('U_Common.SetProjectChanged', E.Message); end; end; function GetFigureIconParams(aListID, aObjectID: Integer): TFigureIconParams; var FList: TF_CAD; FFigure: TFigure; begin try FList := GetListByID(aListID); if FList <> nil then begin FFigure := GetFigureByID(FList, aObjectID); if FFigure <> nil then begin if CheckFigureByClassName(FFigure, cTOrthoLine) then begin Result.GUIDObjectIcon := TOrthoLine(FFigure).FBlockGUID; Result.IconType := TOrthoLine(FFigure).FObjectType; Result.IconCount := 1; end; if CheckFigureByClassName(FFigure, cTConnectorObject) then begin Result.GUIDObjectIcon := TConnectorObject(FFigure).FBlockGUID; Result.IconType := TConnectorObject(FFigure).FObjectType; Result.IconCount := TConnectorObject(FFigure).FBlockCount; end; end; end; except on E: Exception do addExceptionToLogEx('U_Common.GetFigureIconParams', E.Message); end; end; function GetSortedListForAutoTrace(aFiguresList: TList): TList; var i, j: Integer; ObjectsList: TList; BaseObject: TConnectorObject; BaseObjectFIndex: Integer; CurObject: TConnectorObject; CurObjectFIndex: Integer; MinIndex: Integer; CurMinFindex: Integer; begin Result := TList.Create; ObjectsList := TList.Create; try for i := 0 to aFiguresList.Count - 1 do if CheckFigureByClassName(TFigure(aFiguresList[i]), cTConnectorObject) then if TConnectorObject(aFiguresList[i]).ConnectorType <> ct_Clear then if not TConnectorObject(aFiguresList[i]).AsEndPoint then ObjectsList.Add(TConnectorObject(aFiguresList[i])); i := 0; while i < ObjectsList.Count do begin BaseObject := TConnectorObject(ObjectsList[0]); BaseObjectFIndex := BaseObject.FIndex; CurMinFindex := BaseObjectFIndex; MinIndex := 0; for j := 1 to ObjectsList.Count - 1 do begin CurObject := TConnectorObject(ObjectsList[j]); CurObjectFIndex := CurObject.FIndex; if CurObjectFIndex < CurMinFindex then begin CurMinFindex := CurObjectFIndex; MinIndex := j; end; end; Result.Add(ObjectsList[MinIndex]); ObjectsList.Delete(MinIndex); end; except on E: Exception do addExceptionToLogEx('U_Common.GetSortedListForAutoTrace', E.Message); end; FreeAndNil(ObjectsList); end; function GetObjectBlockbyID(aListID, aObjectID: Integer; aCanLoadIcons: Boolean): TObjectIconParams; var i: Integer; FList: TF_CAD; FFigure: TFigure; FObject: TConnectorObject; FTrace: TOrthoLine; Stream: TMemoryStream; Bitmap: TBitmap; MetaFile: TMetafile; FileName: string; DrawFigure: TFigureGrp; tmpDrawFigure: TFigureGrp; tmpInFigure: TFigure; tmpCad: TPowerCad; begin try Result.Executed := False; Result.GUIDIcon := ''; Result.IconBLK := nil; Result.IconBMP := nil; Result.IDIcon := -1; FList := GetListByID(aListID); if FList <> nil then begin FFigure := GetFigureByID(FList, aObjectID); DrawFigure := nil; if CheckFigureByClassName(FFigure, cTConnectorObject) then begin FObject := TConnectorObject(FFigure); DrawFigure := FObject.DrawFigure; Result.IDIcon := FObject.FBlockID; Result.GUIDIcon := FObject.FBlockGUID; Result.Executed := False; end else if CheckFigureByClassName(FFigure, cTOrthoLine) then begin FTrace := TOrthoLine(FFigure); DrawFigure := FTrace.FSingleBlock; Result.IDIcon := FTrace.FBlockID; Result.GUIDIcon := FTrace.FBlockGUID; Result.Executed := False; end; if DrawFigure <> nil then begin if aCanLoadIcons then begin TmpCad := TPowerCad.create(FSCS_Main); TmpCad.Parent := FSCS_Main; TmpCad.Top := -1000; TmpCad.Left := -1000; TmpCad.width := 100; TmpCad.height := 100; tmpDrawFigure := TFigureGrp.create(tmpCad.GetLayerHandle(0), tmpCad); for i := 0 to DrawFigure.InFigures.Count - 1 do begin tmpInFigure := TFigure(DrawFigure.InFigures[i]).Duplicate; tmpDrawFigure.AddFigure(tmpInFigure); end; tmpCad.AddCustomFigure(0, tmpDrawFigure, false); tmpCad.DeselectAll(0); tmpDrawFigure.Select; RefreshCAD(tmpCad); // получить Stream УГО Stream := TMemoryStream.Create; {$if Defined(ES_GRAPH_SC)} FileName := ExeDir + '\.blk\TempStream.blk'; {$else} FileName := ExtractFileDir(Application.ExeName) + '\.blk\TempStream.blk'; {$ifend} tmpCad.MakeSelectionBlock(FileName); Stream.LoadFromFile(FileName); Result.IconBLK := Stream; // получить Bitmap УГО MetaFile := TMetafile.Create; Bitmap := TBitmap.Create; MetaFile := tmpCad.SelectionAsWmf; Bitmap.Height := Metafile.Height; Bitmap.Width := Metafile.Width; Bitmap.Canvas.Draw(0, 0, MetaFile); FreeAndNil(MetaFile); Result.IconBMP := Bitmap; RemoveInFigureGrp(tmpDrawFigure); tmpCad.Figures.Remove(tmpDrawFigure); FreeAndNil(tmpCad); end; end; end; except on E: Exception do addExceptionToLogEx('U_Common.GetObjectBlockbyID', E.Message); end; end; function GetObjectBlockStream(aListID, aObjectID: Integer): TMemoryStream; var i: Integer; FList: TF_CAD; FFigure: TFigure; FObject: TConnectorObject; FTrace: TOrthoLine; Stream: TMemoryStream; Bitmap: TBitmap; MetaFile: TMetafile; FileName: string; tmpDrawFigure: TFigureGrp; tmpInFigure: TFigure; tmpCad: TPowerCad; GetDrawFigure: TFigureGrp; begin Result := nil; try Result := TMemoryStream.Create; FList := GetListByID(aListID); if FList <> nil then begin FFigure := GetFigureByID(FList, aObjectID); if FFigure <> nil then begin GetDrawFigure := nil; if CheckFigureByClassName(FFigure, cTConnectorObject) then begin FObject := TConnectorObject(FFigure); GetDrawFigure := FObject.DrawFigure; end; if CheckFigureByClassName(FFigure, cTOrthoLine) then begin FTrace := TOrthoLine(FFigure); GetDrawFigure := FTrace.FSingleBlock; end; if GetDrawFigure <> nil then begin TmpCad := TPowerCad.create(FSCS_Main); TmpCad.Parent := FSCS_Main; TmpCad.Top := -1000; TmpCad.Left := -1000; TmpCad.width := 100; TmpCad.height := 100; tmpDrawFigure := TFigureGrp.create(tmpCad.GetLayerHandle(0), tmpCad); for i := 0 to GetDrawFigure.InFigures.Count - 1 do begin tmpInFigure := TFigure(GetDrawFigure.InFigures[i]).Duplicate; tmpDrawFigure.AddFigure(tmpInFigure); end; tmpCad.AddCustomFigure(0, tmpDrawFigure, false); tmpCad.DeselectAll(0); tmpDrawFigure.Select; RefreshCAD(tmpCad); // получить Stream УГО {$if Defined(ES_GRAPH_SC)} FileName := ExeDir + '\.blk\TempStream.blk'; {$else} FileName := ExtractFileDir(Application.ExeName) + '\.blk\TempStream.blk'; {$ifend} tmpCad.MakeSelectionBlock(FileName); Result.LoadFromFile(FileName); RemoveInFigureGrp(tmpDrawFigure); tmpCad.Figures.Remove(tmpDrawFigure); FreeAndNil(tmpCad); end; end; end; except on E: Exception do AddExceptionToLogEx('U_Common.GetObjectBlockStream', E.Message); end; end; function GetObjectBlockToSubstrateLayer(aListID, aObjectID: Integer): Boolean; var i: Integer; FList: TF_CAD; FFigure: TFigure; FObject: TConnectorObject; FTrace: TOrthoLine; Stream: TMemoryStream; Bitmap: TBitmap; MetaFile: TMetafile; FileName: string; tmpDrawFigure: TFigureGrp; tmpInFigure: TFigure; tmpCad: TPowerCad; GetDrawFigure: TFigureGrp; begin Result := false; try FList := GetListByID(aListID); if FList <> nil then begin FFigure := GetFigureByID(FList, aObjectID); if FFigure <> nil then begin GetDrawFigure := nil; if CheckFigureByClassName(FFigure, cTConnectorObject) then begin FObject := TConnectorObject(FFigure); GetDrawFigure := FObject.DrawFigure; end; if CheckFigureByClassName(FFigure, cTOrthoLine) then begin FTrace := TOrthoLine(FFigure); GetDrawFigure := FTrace.FSingleBlock; end; if GetDrawFigure <> nil then begin tmpDrawFigure := TFigureGrp.create(GCadForm.PCad.GetLayerHandle(1), GCadForm.PCad); for i := 0 to GetDrawFigure.InFigures.Count - 1 do begin tmpInFigure := TFigure(GetDrawFigure.InFigures[i]).Duplicate; tmpDrawFigure.AddFigure(tmpInFigure); end; GCadForm.PCad.AddCustomFigure(1, tmpDrawFigure, false); GCadForm.PCad.DeselectAll(1); tmpDrawFigure.Select; RefreshCAD(GCadForm.PCad); Result := true; end; end; end; except on E: Exception do AddExceptionToLogEx('U_Common.GetObjectBlockToSubstrateLayer', E.Message); end; end; function ChoiceAutoTraceConnectOrder(AProjectSetting: PProjectSettingRecord=nil; AIsTracing: Boolean=true; ATraceCompon: TSCSComponent=nil; aFromDropConnObj: Boolean=false; aTracingFigInfo: Pointer=nil): Boolean; var ProjectSetting: PProjectSettingRecord; CurrProjectParams: TProjectParams; IsLookingCurrProjectParams: Boolean; begin Result := false; try IsLookingCurrProjectParams := false; ProjectSetting := AProjectSetting; //*** Если параметр не известный, то берем настройки текущего проекта if ProjectSetting = nil then begin CurrProjectParams := GetCurrProjectParams; IsLookingCurrProjectParams := true; ProjectSetting := @CurrProjectParams.Setting; end; if Not AIsTracing or Not ProjectSetting.TraceNoAskParams then begin if GIsProgress then PauseProgress(true); try if (Not GUseVisibleInterfaces) and (AProjectSetting = nil) then Result := true else if F_AutoTraceConnectOrder.Execute(ProjectSetting, ATraceCompon, aTracingFigInfo) then begin Result := true; if IsLookingCurrProjectParams then SaveCurrProjectParams(CurrProjectParams); // Tolik -- 05/11/2016-- Application.MainForm.Repaint; Application.MainForm.Refresh; // end; finally if GIsProgress then PauseProgress(false); end; end else Result := true; except on E: Exception do addExceptionToLogEx('U_Common.ChoiceAutoTraceConnectOrder', E.Message); end; end; procedure SkipAllLinesShadows(aForm: TF_CAD); var i, j: Integer; vFigure: TFigure; vLine: TOrthoLine; begin try for i := 0 to aForm.PCad.FigureCount - 1 do begin vFigure := TFigure(aForm.PCad.Figures[i]); if CheckFigureByClassName(vFigure, cTOrthoLine) then begin vLine := TOrthoLine(vFigure); if not vLine.FIsRaiseUpDown then begin if vLine.tmpDrawShadow then begin vLine.tmpDrawShadow := False; // vLine.Draw(aForm.PCad.DEngine, False); end; end; end; end; except on E: Exception do addExceptionToLogEx('U_Common.SkipAllLinesShadows', E.Message); end; end; procedure PrintCADLists(aAllLists, aCheckedLists: TIntList); var i: Integer; ListID: Integer; ListName: string; FList: TF_CAD; FCADAllLists: TList; FCADCheckedLists: TList; Item: TListItem; begin FCADAllLists := TList.Create; FCADCheckedLists := TList.Create; try for i := 0 to aAllLists.Count - 1 do begin ListID := aAllLists[i]; FList := GetListByID(ListID); if FList <> nil then FCADAllLists.Add(FList); end; for i := 0 to aCheckedLists.Count - 1 do begin ListID := aCheckedLists[i]; FList := GetListByID(ListID); if FList <> nil then FCADCheckedLists.Add(FList); end; if FCADAllLists.Count > 0 then begin F_PrintLists.lvCadLists.Items.Clear; for i := 0 to FCADAllLists.Count - 1 do begin FList := TF_CAD(FCADAllLists[i]); Item := F_PrintLists.lvCadLists.Items.Add; Item.Caption := FList.FCADListName + ' ' + IntToStr(FList.FCADListIndex); Item.Data := FList.PCad; if FCADCheckedLists.IndexOf(FList) <> - 1 then Item.Checked := True else Item.Checked := False; if i = 0 then begin F_PrintLists.lvCadLists.Selected := Item; F_PrintLists.CadControl := FList.PCad; end; end; F_PrintLists.Init; F_PrintLists.ShowModal; end; except on E: Exception do addExceptionToLogEx('U_Common.PrintCADLists', E.Message); end; FreeAndNil(FCADAllLists); FreeAndNil(FCADCheckedLists); end; procedure AutoPosTracesBetweenRM(aConns, aTraces, aSnaps: TList); var i: Integer; Trace: TOrthoLine; JoinedConn1, JoinedConn2: TConnectorObject; RM1, RM2: TConnectorObject; Snap1, Snap2: TFigure; begin try for i := 0 to aTraces.Count - 1 do begin Trace := TOrthoLine(aTraces[i]); JoinedConn1 := TConnectorObject(Trace.JoinConnector1); JoinedConn2 := TConnectorObject(Trace.JoinConnector2); Snap1 := TFigure(aSnaps[i]); Snap2 := TFigure(aSnaps[i + 1]); if (Snap1 <> nil) and (Snap2 <> nil) then begin if CheckFigureByClassName(Snap1, cTConnectorObject) and CheckFigureByClassName(Snap2, cTConnectorObject) then begin if (TConnectorObject(Snap1).ConnectorType <> ct_Clear) and (TConnectorObject(Snap2).ConnectorType <> ct_Clear) then begin Trace.ActualZOrder[1] := TConnectorObject(Snap1).ActualZOrder[1]; JoinedConn1.ActualZOrder[1] := TConnectorObject(Snap1).ActualZOrder[1]; Trace.ActualZOrder[2] := TConnectorObject(Snap2).ActualZOrder[1]; JoinedConn2.ActualZOrder[1] := TConnectorObject(Snap2).ActualZOrder[1]; // поставить высоту для линии SetLineFigureCoordZInPM(Trace.ID, 1, Trace.ActualZOrder[1]); SetLineFigureCoordZInPM(Trace.ID, 2, Trace.ActualZOrder[2]); SetLineFigureLengthInPM(Trace.ID, Trace.LineLength); end; end; end; end; except on E: Exception do addExceptionToLogEx('U_Common.AutoPosTracesbetweenRM', E.Message); end; end; procedure AutoPosTracesBetweenRMAfterSnap(aTraces: TList); var i: Integer; Trace: TOrthoLine; JoinedConn1, JoinedConn2: TConnectorObject; RM1, RM2: TConnectorObject; Snap1, Snap2: TFigure; begin try for i := 0 to aTraces.Count - 1 do begin Trace := TOrthoLine(aTraces[i]); JoinedConn1 := TConnectorObject(Trace.JoinConnector1); JoinedConn2 := TConnectorObject(Trace.JoinConnector2); if (JoinedConn1.JoinedConnectorsList.Count = 0) or (JoinedConn2.JoinedConnectorsList.Count = 0) then begin if (Trace.ActualZOrder[1] <> Trace.ActualZOrder[2]) then // Tolik -- 03/04/2018 -- if not GCadForm.FAutoPosTraceBetweenRM then // if (Trace.ActualZOrder[1] = GCadForm.FLineHeight) or (Trace.ActualZOrder[2] = GCadForm.FLineHeight) then begin RaiseLineOnHeight(Trace, GCadForm.FLineHeight, aTraces); end; end; end; except on E: Exception do addExceptionToLogEx('U_Common.AutoPosTracesBetweenRMAfterSnap', E.Message); end; end; procedure SetCabinetFalseFloor(aCabinet: TFigure); var Val: Double; oldtempstr, tempstr: string; Params: TObjectParams; begin try if CheckFigureByClassName(aCabinet, cTCabinet) then oldtempstr := FormatFloat(ffMask, MetreToUOM(TCabinet(aCabinet).FFalseFloorHeight)); if CheckFigureByClassName(aCabinet, cTCabinetExt) then oldtempstr := FormatFloat(ffMask, MetreToUOM(TCabinetExt(aCabinet).FFalseFloorHeight)); tempstr := oldtempstr; if InputQuery(cCommon_Mes23, cCommon_Mes24, tempstr) then begin try Val := StrToFloat_My(tempstr); if Val < 0 then tempstr := '0'; if Val > MetreToUOM(GCadForm.FRoomHeight) then begin Val := MetreToUOM(GCadForm.FRoomHeight); tempstr := FormatFloat(ffMask, Val); end; except ShowMessage(cSizePos_Mes1); SetCabinetFalseFloor(aCabinet); Exit; end; if (tempstr <> '') and (tempstr <> oldtempstr) then begin // *UNDO* if GCadForm.FCanSaveForUndo then begin GCadForm.SaveForUndo(uat_None, True, False); GCadForm.FCanSaveForUndo := False; end; if CheckFigureByClassName(aCabinet, cTCabinet) then begin TCabinet(aCabinet).FFalseFloorHeight := UOMToMetre(StrToFloat_My(Tempstr)); Params := GetFigureParams(TCabinet(aCabinet).FSCSID); Params.HeightCeiling := TCabinet(aCabinet).FFalseFloorHeight; SaveFigureParams(TCabinet(aCabinet).FSCSID, Params); end; if CheckFigureByClassName(aCabinet, cTCabinetExt) then begin TCabinetExt(aCabinet).FFalseFloorHeight := UOMToMetre(StrToFloat_My(Tempstr)); Params := GetFigureParams(TCabinetExt(aCabinet).FSCSID); Params.HeightCeiling := TCabinetExt(aCabinet).FFalseFloorHeight; SaveFigureParams(TCabinetExt(aCabinet).FSCSID, Params); end; RefreshCAD(GCadForm.PCad); // *UNDO* GCadForm.FCanSaveForUndo := True; end; if not GProjectChanged then // Tolik 28/08/2019 -- SetProjectChanged(True); end; except on E: Exception do addExceptionToLogEx('SetCabinetFalseFloor', E.Message); end; end; procedure CheckAllCabinetsFalseFloorHeights; var i: integer; Cabinet: TCabinet; CabinetExt: TCabinetExt; begin try for i := 0 to GCadForm.PCad.FigureCount - 1 do begin if CheckFigureByClassName(TFigure(GCadForm.PCad.Figures[i]), cTCabinet) then begin Cabinet := TCabinet(GCadForm.PCad.Figures[i]); if Cabinet.FType = ct_Visual then begin if Cabinet.FFalseFloorHeight > GCadForm.FRoomHeight then Cabinet.FFalseFloorHeight := GCadForm.FRoomHeight; end; end else if CheckFigureByClassName(TFigure(GCadForm.PCad.Figures[i]), cTCabinetExt) then begin CabinetExt := TCabinetExt(GCadForm.PCad.Figures[i]); if CabinetExt.FType = ct_Visual then begin if CabinetExt.FFalseFloorHeight > GCadForm.FRoomHeight then CabinetExt.FFalseFloorHeight := GCadForm.FRoomHeight; end; end; end; except on E: Exception do addExceptionToLogEx('U_Common.CheckAllCabinetsFalseFloorHeights', E.Message); end; end; procedure SetCadListFormat(aListFormat: TListFormatType); var i: integer; x1, x2, y1, y2: double; Cabinet: TFigure; StampTypeStr, StampLangStr, FullPathName, MainStampName, SideStampName: string; begin try GCadForm.PCad.PageLayout := aListFormat.PageLayout; GCadForm.PCad.PageOrient := aListFormat.PageOrient; // if (GCadForm.FListCountX <> 1) or (GCadForm.FListCountY <> 1) then begin GCadForm.PCad.WorkWidth := aListFormat.PageWidth; GCadForm.PCad.WorkHeight := aListFormat.PageHeight; // виртуальный кабинет Cabinet := GetVirtualCabinet; if Cabinet <> nil then begin x1 := GCadForm.PCad.Left; x2 := GCadForm.PCad.Left + GCadForm.PCad.WorkWidth; y1 := GCadForm.PCad.Top; y2 := GCadForm.PCad.Top + GCadForm.PCad.WorkHeight; Cabinet.ActualPoints[1] := DoublePoint(x1, y1); Cabinet.ActualPoints[2] := DoublePoint(x2, y1); Cabinet.ActualPoints[3] := DoublePoint(x2, y2); Cabinet.ActualPoints[4] := DoublePoint(x1, y2); end; end; // определить параметры в именах блоков {$if Defined(ES_GRAPH_SC)} FullPathName := ExeDir + '\Stamp\'; {$else} FullPathName := ExtractFileDir(Application.ExeName) + '\Stamp\'; {$ifend} StampTypeStr := ''; if GCadForm.FCadStampType = stt_simple then StampTypeStr := 'Small' else if GCadForm.FCadStampType = stt_extended then StampTypeStr := 'Big' else if GCadForm.FCadStampType = stt_detailed then StampTypeStr := 'ExtBig'; StampLangStr := ''; if GCadForm.FCadStampLang = stl_eng then StampLangStr := 'eng' else if GCadForm.FCadStampLang = stl_ukr then StampLangStr := 'ukr' else if GCadForm.FCadStampLang = stl_ukr_dstu then StampLangStr := 'ukr_dstu' else if GCadForm.FCadStampLang = stl_rus then StampLangStr := 'rus'; // MainStampName := StampTypeStr + '_Main_' + StampLangStr + '.sch'; SideStampName := StampTypeStr + '_Side_' + StampLangStr + '.sch'; LoadFrameToList(GCadForm, FullPathName + MainStampName, FullPathName + SideStampName, aListFormat); except on E: Exception do addExceptionToLogEx('U_Common.SetCadListFormat', E.Message); end; end; procedure SetCabinetFalseFloorHeightFromPM(aListID, aCabinetID: Integer; aSettings: TRoomSettingRecord); var vList: TF_CAD; vCabinet: TFigure; begin try vList := GetListByID(aListID); if vList <> nil then begin vCabinet := FindCabinetBySCSID(vList, aCabinetID); if vCabinet <> nil then begin if CheckFigureByClassName(vCabinet, cTCabinet) then TCabinet(vCabinet).FFalseFloorHeight := aSettings.HeightCeiling else if CheckFigureByClassName(vCabinet, cTCabinetExt) then TCabinetExt(vCabinet).FFalseFloorHeight := aSettings.HeightCeiling; end; end; except on E: Exception do addExceptionToLogEx('U_Common.SetCabinetFalseFloorHeightFromPM', E.Message); end; end; function CheckListFormatChanged(aCad: TF_CAD; aListFormat: TListFormatType): Boolean; begin Result := False; try // if aCad.PCad.PageLayout <> aListFormat.PageLayout then // Result := True; // if aCad.PCad.PageOrient <> aListFormat.PageOrient then // Result := True; if aCad.FCadStampLang <> aListFormat.StampLang then Result := True else if aCad.FCadStampType <> aListFormat.StampType then Result := True else if aCad.FListCountX <> aListFormat.ListCountX then Result := True else if aCad.FListCountY <> aListFormat.ListCountY then Result := True else if aCad.FShowMainStamp <> aListFormat.ShowMainStamp then Result := True else if aCad.FShowUpperStamp <> aListFormat.ShowUpperStamp then Result := True else if aCad.FShowSideStamp <> aListFormat.ShowSideStamp then Result := True else if aCad.PCad.WorkWidth <> aListFormat.PageWidth then Result := True else if aCad.PCad.WorkHeight <> aListFormat.PageHeight then Result := True //14.11.2011 else if aCad.FStampFields.Margins.Left <> aListFormat.StampFields.Margins.Left then Result := True else if aCad.FStampFields.Margins.Right <> aListFormat.StampFields.Margins.Right then Result := True else if aCad.FStampFields.Margins.Top <> aListFormat.StampFields.Margins.Top then Result := True else if aCad.FStampFields.Margins.Bottom <> aListFormat.StampFields.Margins.Bottom then Result := True else if aCad.FStampFields.Developer <> aListFormat.StampFields.Developer then Result := True else if aCad.FStampFields.Checker <> aListFormat.StampFields.Checker then Result := True //03.10.2012 else if aCad.FStampFields.ListSign <> aListFormat.StampFields.ListSign then Result := True else if aCad.FStampFields.MainEngineer <> aListFormat.StampFields.MainEngineer then Result := True else if aCad.FStampFields.Approved <> aListFormat.StampFields.Approved then Result := True else if aCad.FStampFields.DesignStage <> aListFormat.StampFields.DesignStage then Result := True; except on E: Exception do addExceptionToLogEx('U_Common.CheckListFormatChanged', E.Message); end; end; procedure CorrectStampView; var StampHandle: Integer; i, j: integer; Stamp: TFigureGrp; FFigure: TFigure; InFigure: TFigure; FrameFigure: TFigure; FrameFigureCode: Integer; MainStampObj, SideStampObj: TFigureGrp; UpperStampObj: TRectangle; RectangleObj: TRectangle; begin try StampHandle := GCadForm.PCad.GetLayerHandle(7); for i := 0 to GCadForm.PCad.FigureCount - 1 do begin FFigure := TFigure(GCadForm.PCad.Figures[i]); if FFigure.LayerHandle = StampHandle then begin if CheckFigureByClassName(FFigure, 'TFigureGrp') then begin Stamp := TFigureGrp(FFigure); MainStampObj := nil; SideStampObj := nil; UpperStampObj := nil; RectangleObj := nil; for j := 0 to Stamp.InFigures.Count - 1 do begin if TFigure(Stamp.InFigures[j]).DataID = 100 then MainStampObj := TFigureGrp(Stamp.InFigures[j]); if TFigure(Stamp.InFigures[j]).DataID = 200 then SideStampObj := TFigureGrp(Stamp.InFigures[j]); if TFigure(Stamp.InFigures[j]).DataID = 300 then UpperStampObj := TRectangle(Stamp.InFigures[j]); if TFigure(Stamp.InFigures[j]).DataID = 99 then RectangleObj := TRectangle(Stamp.InFigures[j]); end; // основной штамп if MainStampObj <> nil then begin SetAllInFiguresVisible(MainStampObj, GCadForm.FShowMainStamp); {//17.11.2011 if GCadForm.FFrameProjectName <> nil then GCadForm.FFrameProjectName.Visible := GCadForm.FShowMainStamp; if GCadForm.FFrameListName <> nil then GCadForm.FFrameListName.Visible := GCadForm.FShowMainStamp; if GCadForm.FFrameIndexName <> nil then GCadForm.FFrameIndexName.Visible := GCadForm.FShowMainStamp;} for j := 0 to GCadForm.FFrameObjects.Count - 1 do begin FrameFigure := TFigure(GCadForm.FFrameObjects.Objects[j]); FrameFigureCode := StrToint(GCadForm.FFrameObjects[j]); if (FrameFigure <> nil) and (FrameFigureCode <> ftCodeName) then FrameFigure.Visible := GCadForm.FShowMainStamp; end; end; // боковой штамп if SideStampObj <> nil then begin SetAllInFiguresVisible(SideStampObj, GCadForm.FShowSideStamp); end; // верхний штамп if UpperStampObj <> nil then begin UpperStampObj.Visible := GCadForm.FShowUpperStamp; if GCadForm.FFrameCodeName <> nil then GCadForm.FFrameCodeName.Visible := GCadForm.FShowUpperStamp; end; {$if Defined(SCS_PE) or Defined(SCS_PANDUIT)} if RectangleObj <> nil then begin RectangleObj.Visible := GCadForm.FShowUpperStamp or GCadForm.FShowSideStamp or GCadForm.FShowMainStamp; end; {$ifend} end; end; end; except on E: Exception do addExceptionToLogEx('U_Common.CorrectStampView', E.Message); end; end; function IfTraceHorizontal(aTrace: TOrthoLine): Boolean; begin Result := False; try if DoubleCMP(aTrace.ActualPoints[1].y, aTrace.ActualPoints[2].y) then Result := True; except on E: Exception do addExceptionToLogEx('U_Common.IfTraceHorizontal', E.Message); end; end; function IfTraceVertical(aTrace: TOrthoLine): Boolean; begin Result := False; try if DoubleCMP(aTrace.ActualPoints[1].x, aTrace.ActualPoints[2].x) then Result := True; except on E: Exception do addExceptionToLogEx('U_Common.IfTraceVertical', E.Message); end; end; function GetRaiseCountConnectedToFigure(AIDList, AIDFigure: Integer; aWithTrunk: Boolean = False): Integer; var vList: TF_CAD; vLine: TOrthoLine; JoinConn: TConnectorObject; begin Result := 0; try vList := GetListByID(AIDList); if vList <> nil then begin vLine := TOrthoLine(GetFigureByID(vList, AIDFigure)); if vLine <> nil then begin JoinConn := TConnectorObject(vLine.JoinConnector1); //Tolik 13/03/2018 - { if (JoinConn.FConnRaiseType = crt_BetweenFloorUp) or (JoinConn.FConnRaiseType = crt_BetweenFloorDown) or (JoinConn.FConnRaiseType = crt_TrunkUp) or (JoinConn.FConnRaiseType = crt_TrunkDown) then Result := Result + 1; JoinConn := TConnectorObject(vLine.JoinConnector2); if (JoinConn.FConnRaiseType = crt_BetweenFloorUp) or (JoinConn.FConnRaiseType = crt_BetweenFloorDown) or (JoinConn.FConnRaiseType = crt_TrunkUp) or (JoinConn.FConnRaiseType = crt_TrunkDown) then Result := Result + 1; } if aWithTrunk then // c магистралями begin if (JoinConn.FConnRaiseType = crt_BetweenFloorUp) or (JoinConn.FConnRaiseType = crt_BetweenFloorDown) or (JoinConn.FConnRaiseType = crt_TrunkUp) or (JoinConn.FConnRaiseType = crt_TrunkDown) then Result := Result + 1; JoinConn := TConnectorObject(vLine.JoinConnector2); if (JoinConn.FConnRaiseType = crt_BetweenFloorUp) or (JoinConn.FConnRaiseType = crt_BetweenFloorDown) or (JoinConn.FConnRaiseType = crt_TrunkUp) or (JoinConn.FConnRaiseType = crt_TrunkDown) then Result := Result + 1; end else // без магистралей begin if (JoinConn.FConnRaiseType = crt_BetweenFloorUp) or (JoinConn.FConnRaiseType = crt_BetweenFloorDown) then Result := Result + 1; JoinConn := TConnectorObject(vLine.JoinConnector2); if (JoinConn.FConnRaiseType = crt_BetweenFloorUp) or (JoinConn.FConnRaiseType = crt_BetweenFloorDown) then Result := Result + 1; end; // end; end; except on E: Exception do addExceptionToLogEx('U_Common.GetRaiseCountConnectedToFigure', E.Message); end; end; procedure SetAllBetweenFloorRaises; var i: Integer; vFigure: TFigure; vConn: TConnectorObject; begin try for i := 0 to GCadForm.PCad.FigureCount - 1 do begin vFigure := TFigure(GCadForm.PCad.Figures[i]); if CheckFigureByClassName(vFigure, cTConnectorObject) then begin vConn := TConnectorObject(vFigure); if vConn.FConnRaiseType = crt_BetweenFloorUp then vConn.ActualZOrder[1] := GCadForm.FRoomHeight; end; end; except on E: Exception do addExceptionToLogEx('U_Common.SetAllBetweenFloorRaises', E.Message); end; end; function IsNowTracingByUser: Boolean; begin Result := False; // Tolik -- 28/04/2017 -- if GCadForm = nil then exit; // try if GCadForm.PCad.ToolIdx = toFigure then Result := True; except on E: Exception do addExceptionToLogEx('U_Common.IsNowTracingByUser', E.Message); end; end; //14.09.2010 //function IsMousedPressed: Boolean; //var // Button: TMouseButton; //begin // Result := False; // try // if Button = mbLeft then // Result := True; // except // on E: Exception do addExceptionToLogEx('U_Common.IsMousedPressed', E.Message); // end; //end; procedure ObjectsShiftUp(aObjList: TList); var i: integer; CurObject: TConnectorObject; AddDelta: Double; CanMove: Boolean; Shift: TShiftState; temp: double; begin try // сдвинуть объекты for i := 0 to aObjList.Count - 1 do begin CurObject := TConnectorObject(aObjList[i]); Shift := KeyboardStateToShiftState; if CurObject.DrawFigure.InFigures.Count > 0 then begin // Обьект из VISIO if (CurObject.DrawFigure.InFigures.Count = 1) and CheckFigureByClassName(TFigure(CurObject.DrawFigure.InFigures[0]), 'TWMFObject') then begin if not(ssCtrl in Shift) then begin if IfDrawFigureMoveCan(CurObject, 0, - 0.1) then begin CurObject.DrawFigure.move(0, - 0.1); CurObject.CaptionsGroup.Move(0, - 0.1); end; end else begin if IfDrawFigureMoveCan(CurObject, 0, - CurObject.GrpSizeY / 2 + 0.6) then begin CurObject.DrawFigure.move(0, - CurObject.GrpSizeY / 2 + 0.6); CurObject.CaptionsGroup.Move(0, - CurObject.GrpSizeY / 2 + 0.6); end else begin GCadForm.PCad.AutoRefresh := False; CurObject.DrawFigure.move(0, CurObject.ActualPoints[1].y - CurObject.DrawFigure.CenterPoint.y); CurObject.ReCreateCaptionsGroup(false, false); CurObject.DrawFigure.move(0, - CurObject.GrpSizeY / 2 + 0.6); CurObject.CaptionsGroup.Move(0, - CurObject.GrpSizeY / 2 + 0.6); GCadForm.PCad.AutoRefresh := True; end; end; end // Объект из POWERCAD else begin if not(ssCtrl in Shift) then begin if IfDrawFigureMoveCan(CurObject, 0, - 0.1) then begin CurObject.DrawFigure.move(0, - 0.1); CurObject.CaptionsGroup.Move(0, - 0.1); end; end else begin if IfDrawFigureMoveCan(CurObject, 0, - CurObject.GrpSizeY / 2) then begin CurObject.DrawFigure.move(0, - CurObject.GrpSizeY / 2); CurObject.CaptionsGroup.Move(0, - CurObject.GrpSizeY / 2); end else begin GCadForm.PCad.AutoRefresh := False; CurObject.DrawFigure.move(0, CurObject.ActualPoints[1].y - CurObject.DrawFigure.CenterPoint.y); CurObject.ReCreateCaptionsGroup(false, false); CurObject.DrawFigure.move(0, - CurObject.GrpSizeY / 2); CurObject.CaptionsGroup.Move(0, - CurObject.GrpSizeY / 2); GCadForm.PCad.AutoRefresh := True; end; end; end; end else begin if IfDrawFigureMoveCan(CurObject, 0, - CurObject.GrpSizeY / 2) then begin CurObject.DrawFigure.move(0, - CurObject.GrpSizeY / 2); CurObject.CaptionsGroup.Move(0, - CurObject.GrpSizeY / 2); end else begin GCadForm.PCad.AutoRefresh := False; CurObject.DrawFigure.move(0, CurObject.ActualPoints[1].y - CurObject.DrawFigure.CenterPoint.y); CurObject.ReCreateCaptionsGroup(false, false); CurObject.DrawFigure.move(0, - CurObject.GrpSizeY / 2); CurObject.CaptionsGroup.Move(0, - CurObject.GrpSizeY / 2); GCadForm.PCad.AutoRefresh := True; end; end; CurObject.DefRaizeDrawFigurePos; CurObject.FDrawFigureMoved := True; end; except on E: Exception do addExceptionToLogEx('U_Common.ObjectsShiftUp', E.Message); end; end; procedure ObjectsShiftDown(aObjList: TList); var i: integer; CurObject: TConnectorObject; AddDelta: Double; CanMove: Boolean; Shift: TShiftState; begin try // сдвинуть объекты for i := 0 to aObjList.Count - 1 do begin CurObject := TConnectorObject(aObjList[i]); Shift := KeyboardStateToShiftState; if CurObject.DrawFigure.InFigures.Count > 0 then begin // Обьект из VISIO if (CurObject.DrawFigure.InFigures.Count = 1) and CheckFigureByClassName(TFigure(CurObject.DrawFigure.InFigures[0]), 'TWMFObject') then begin if not (ssCtrl in Shift) then begin if IfDrawFigureMoveCan(CurObject, 0, 0.1) then begin CurObject.DrawFigure.move(0, 0.1); CurObject.CaptionsGroup.Move(0, 0.1); end; end else begin if IfDrawFigureMoveCan(CurObject, 0, CurObject.GrpSizeY / 2 - 0.6) then begin CurObject.DrawFigure.move(0, CurObject.GrpSizeY / 2 - 0.6); CurObject.CaptionsGroup.Move(0, CurObject.GrpSizeY / 2 - 0.6); end else begin GCadForm.PCad.AutoRefresh := False; CurObject.DrawFigure.move(0, CurObject.ActualPoints[1].y - CurObject.DrawFigure.CenterPoint.y); CurObject.ReCreateCaptionsGroup(false, false); CurObject.DrawFigure.move(0, CurObject.GrpSizeY / 2 - 0.6); CurObject.CaptionsGroup.Move(0, CurObject.GrpSizeY / 2 - 0.6); GCadForm.PCad.AutoRefresh := True; end; end; end // Объект из POWERCAD else begin if not (ssCtrl in Shift) then begin if IfDrawFigureMoveCan(CurObject, 0, 0.1) then begin CurObject.DrawFigure.move(0, 0.1); CurObject.CaptionsGroup.Move(0, 0.1); end; end else begin if IfDrawFigureMoveCan(CurObject, 0, CurObject.GrpSizeY / 2) then begin CurObject.DrawFigure.move(0, CurObject.GrpSizeY / 2); CurObject.CaptionsGroup.Move(0, CurObject.GrpSizeY / 2); end else begin GCadForm.PCad.AutoRefresh := False; CurObject.DrawFigure.move(0, CurObject.ActualPoints[1].y - CurObject.DrawFigure.CenterPoint.y); CurObject.ReCreateCaptionsGroup(false, false); CurObject.DrawFigure.move(0, CurObject.GrpSizeY / 2); CurObject.CaptionsGroup.Move(0, CurObject.GrpSizeY / 2); GCadForm.PCad.AutoRefresh := True; end; end; end; end else begin if IfDrawFigureMoveCan(CurObject, 0, CurObject.GrpSizeY / 2) then begin CurObject.DrawFigure.move(0, CurObject.GrpSizeY / 2); CurObject.CaptionsGroup.Move(0, CurObject.GrpSizeY / 2); end else begin GCadForm.PCad.AutoRefresh := False; CurObject.DrawFigure.move(0, CurObject.ActualPoints[1].y - CurObject.DrawFigure.CenterPoint.y); CurObject.ReCreateCaptionsGroup(false, false); CurObject.DrawFigure.move(0, CurObject.GrpSizeY / 2); CurObject.CaptionsGroup.Move(0, CurObject.GrpSizeY / 2); GCadForm.PCad.AutoRefresh := True; end; end; CurObject.DefRaizeDrawFigurePos; CurObject.FDrawFigureMoved := True; end; except on E: Exception do addExceptionToLogEx('U_Common.ObjectsShiftDown', E.Message); end; end; procedure ObjectsShiftLeft(aObjList: TList); var i: integer; CurObject: TConnectorObject; AddDelta: Double; CanMove: Boolean; Shift: TShiftState; begin try // сдвинуть объекты for i := 0 to aObjList.Count - 1 do begin CurObject := TConnectorObject(aObjList[i]); Shift := KeyboardStateToShiftState; if CurObject.DrawFigure.InFigures.Count > 0 then begin // Обьект из VISIO if (CurObject.DrawFigure.InFigures.Count = 1) and CheckFigureByClassName(TFigure(CurObject.DrawFigure.InFigures[0]), 'TWMFObject') then begin if not (ssCtrl in Shift) then begin if IfDrawFigureMoveCan(CurObject, - 0.1, 0) then begin CurObject.DrawFigure.move( - 0.1, 0); CurObject.CaptionsGroup.Move( - 0.1, 0); end; end else begin if IfDrawFigureMoveCan(CurObject, - CurObject.GrpSizeX / 2 + 0.6, 0) then begin CurObject.DrawFigure.move( - CurObject.GrpSizeX / 2 + 0.6, 0); CurObject.CaptionsGroup.Move( - CurObject.GrpSizeX / 2 + 0.6, 0); end else begin GCadForm.PCad.AutoRefresh := False; CurObject.DrawFigure.move(CurObject.ActualPoints[1].x - CurObject.DrawFigure.CenterPoint.x, 0); CurObject.ReCreateCaptionsGroup(false, false); CurObject.DrawFigure.move( - CurObject.GrpSizeX / 2 + 0.6, 0); CurObject.CaptionsGroup.Move( - CurObject.GrpSizeX / 2 + 0.6, 0); GCadForm.PCad.AutoRefresh := True; end; end; end // Объект из POWERCAD else begin if not (ssCtrl in Shift) then begin if IfDrawFigureMoveCan(CurObject, - 0.1, 0) then begin CurObject.DrawFigure.move( - 0.1, 0); CurObject.CaptionsGroup.Move( - 0.1, 0); end; end else begin if IfDrawFigureMoveCan(CurObject, - CurObject.GrpSizeX / 2, 0) then begin CurObject.DrawFigure.move( - CurObject.GrpSizeX / 2, 0); CurObject.CaptionsGroup.Move( - CurObject.GrpSizeX / 2, 0); end else begin GCadForm.PCad.AutoRefresh := False; CurObject.DrawFigure.move(CurObject.ActualPoints[1].x - CurObject.DrawFigure.CenterPoint.x, 0); CurObject.ReCreateCaptionsGroup(false, false); CurObject.DrawFigure.move( - CurObject.GrpSizeX / 2, 0); CurObject.CaptionsGroup.Move( - CurObject.GrpSizeX / 2, 0); GCadForm.PCad.AutoRefresh := True; end; end; end; end else begin if IfDrawFigureMoveCan(CurObject, - CurObject.GrpSizeX / 2, 0) then begin CurObject.DrawFigure.move( - CurObject.GrpSizeX / 2, 0); CurObject.CaptionsGroup.Move( - CurObject.GrpSizeX / 2, 0); end else begin GCadForm.PCad.AutoRefresh := False; CurObject.DrawFigure.move(CurObject.ActualPoints[1].x - CurObject.DrawFigure.CenterPoint.x, 0); CurObject.ReCreateCaptionsGroup(false, false); CurObject.DrawFigure.move( - CurObject.GrpSizeX / 2, 0); CurObject.CaptionsGroup.Move( - CurObject.GrpSizeX / 2, 0); GCadForm.PCad.AutoRefresh := True; end; end; CurObject.DefRaizeDrawFigurePos; CurObject.FDrawFigureMoved := True; end; except on E: Exception do addExceptionToLogEx('U_Common.ObjectsShiftLeft', E.Message); end; end; procedure ObjectsShiftRight(aObjList: TList); var i: integer; CurObject: TConnectorObject; AddDelta: Double; CanMove: Boolean; tmpfig: TFigureGrp; Shift: TShiftState; begin try // сдвинуть объекты for i := 0 to aObjList.Count - 1 do begin CurObject := TConnectorObject(aObjList[i]); Shift := KeyboardStateToShiftState; if CurObject.DrawFigure.InFigures.Count > 0 then begin // Обьект из VISIO if (CurObject.DrawFigure.InFigures.Count = 1) and CheckFigureByClassName(TFigure(CurObject.DrawFigure.InFigures[0]), 'TWMFObject') then begin if not (ssCtrl in Shift) then begin if IfDrawFigureMoveCan(CurObject, 0.1, 0) then begin CurObject.DrawFigure.move(0.1, 0); CurObject.CaptionsGroup.Move(0.1, 0); end; end else begin if IfDrawFigureMoveCan(CurObject, CurObject.GrpSizeX / 2 - 0.6, 0) then begin CurObject.DrawFigure.move(CurObject.GrpSizeX / 2 - 0.6, 0); CurObject.CaptionsGroup.Move(CurObject.GrpSizeX / 2 - 0.6, 0); end else begin GCadForm.PCad.AutoRefresh := False; CurObject.DrawFigure.move(CurObject.ActualPoints[1].x - CurObject.DrawFigure.CenterPoint.x, 0); CurObject.ReCreateCaptionsGroup(false, false); CurObject.DrawFigure.move(CurObject.GrpSizeX / 2 - 0.6, 0); CurObject.CaptionsGroup.Move(CurObject.GrpSizeX / 2 - 0.6, 0); GCadForm.PCad.AutoRefresh := True; end; end end // Объект из POWERCAD else begin if not (ssCtrl in Shift) then begin if IfDrawFigureMoveCan(CurObject, 0.1, 0) then begin CurObject.DrawFigure.move(0.1, 0); CurObject.CaptionsGroup.Move(0.1, 0); end; end else begin if IfDrawFigureMoveCan(CurObject, CurObject.GrpSizeX / 2, 0) then begin CurObject.DrawFigure.move(CurObject.GrpSizeX / 2, 0); CurObject.CaptionsGroup.Move(CurObject.GrpSizeX / 2, 0); end else begin GCadForm.PCad.AutoRefresh := False; CurObject.DrawFigure.move(CurObject.ActualPoints[1].x - CurObject.DrawFigure.CenterPoint.x, 0); CurObject.ReCreateCaptionsGroup(false, false); CurObject.DrawFigure.move(CurObject.GrpSizeX / 2, 0); CurObject.CaptionsGroup.Move(CurObject.GrpSizeX / 2, 0); GCadForm.PCad.AutoRefresh := True; end; end end end else begin if IfDrawFigureMoveCan(CurObject, CurObject.GrpSizeX / 2, 0) then begin CurObject.DrawFigure.move(CurObject.GrpSizeX / 2, 0); CurObject.CaptionsGroup.Move(CurObject.GrpSizeX / 2, 0); end else begin GCadForm.PCad.AutoRefresh := False; CurObject.DrawFigure.move(CurObject.ActualPoints[1].x - CurObject.DrawFigure.CenterPoint.x, 0); CurObject.ReCreateCaptionsGroup(false, false); CurObject.DrawFigure.move(CurObject.GrpSizeX / 2, 0); CurObject.CaptionsGroup.Move(CurObject.GrpSizeX / 2, 0); GCadForm.PCad.AutoRefresh := True; end; end; CurObject.DefRaizeDrawFigurePos; CurObject.FDrawFigureMoved := True; end; except on E: Exception do addExceptionToLogEx('U_Common.ObjectsShiftRight', E.Message); end; end; procedure LinesShiftUp(aLinesList: TList); var i: Integer; CurrLine: TOrthoLine; Bnd: TDoubleRect; AngleDegrees, AngleRad: Double; dx, dy: double; oldCP, newCP: TDoublePoint; delta: double; begin try delta := 0.1; for i := 0 to aLinesList.Count - 1 do begin CurrLine := TOrthoLine(aLinesList[i]); if (CurrLine.DrawFigure <> nil) and (CurrLine.DrawFigure.InFigures.Count > 0) then begin // получить старую центр точку DrawFigure Bnd := CurrLine.DrawFigure.GetBoundRect; oldCP.x := (Bnd.Left + Bnd.Right) / 2; oldCP.y := (Bnd.Top + Bnd.Bottom) / 2; // получить точку пересечения AngleDegrees := CurrLine.GetAngle(CurrLine.ActualPoints[1].x, CurrLine.ActualPoints[1].y, CurrLine.ActualPoints[2].x, CurrLine.ActualPoints[2].y); AngleRad := AngleDegrees * pi / 180; // получить точку для перемещения AngleDegrees := AngleDegrees + 90; AngleDegrees := round(AngleDegrees) mod 360; AngleRad := AngleDegrees * pi / 180; dx := - (delta * Cos(AngleRad)); dy := - (delta * Sin(AngleRad)); if (AngleDegrees >= 180) and (AngleDegrees < 360) then begin dx := -dx; dy := -dy; end; // если поворот на 180 то перебросить линию на другую сторону if CurrLine.FIsRotated then begin dx := -dx; dy := -dy; end; newCP.x := oldCP.x + dx; newCP.y := oldCP.y + dy; CurrLine.DrawFigure.move(newCP.x - oldCP.x, newCP.y - oldCP.y); CurrLine.DrawFigureH := CurrLine.CalcHDrawFigure; end; end; except on E: Exception do addExceptionToLogEx('U_Common.LinesShiftUp', E.Message); end; end; procedure LinesShiftDown(aLinesList: TList); var i: Integer; CurrLine: TOrthoLine; Bnd: TDoubleRect; AngleDegrees, AngleRad: Double; dx, dy: double; oldCP, newCP: TDoublePoint; delta: double; begin try delta := 0.1; for i := 0 to aLinesList.Count - 1 do begin CurrLine := TOrthoLine(aLinesList[i]); if (CurrLine.DrawFigure <> nil) and (CurrLine.DrawFigure.InFigures.Count > 0) then begin // получить старую центр точку DrawFigure Bnd := CurrLine.DrawFigure.GetBoundRect; oldCP.x := (Bnd.Left + Bnd.Right) / 2; oldCP.y := (Bnd.Top + Bnd.Bottom) / 2; // получить точку пересечения AngleDegrees := CurrLine.GetAngle(CurrLine.ActualPoints[1].x, CurrLine.ActualPoints[1].y, CurrLine.ActualPoints[2].x, CurrLine.ActualPoints[2].y); AngleRad := AngleDegrees * pi / 180; // получить точку для перемещения AngleDegrees := AngleDegrees + 90; AngleDegrees := round(AngleDegrees) mod 360; AngleRad := AngleDegrees * pi / 180; dx := delta * Cos(AngleRad); dy := delta * Sin(AngleRad); if (AngleDegrees >= 180) and (AngleDegrees < 360) then begin dx := -dx; dy := -dy; end; // если поворот на 180 то перебросить линию на другую сторону if CurrLine.FIsRotated then begin dx := -dx; dy := -dy; end; newCP.x := oldCP.x + dx; newCP.y := oldCP.y + dy; CurrLine.DrawFigure.move(newCP.x - oldCP.x, newCP.y - oldCP.y); CurrLine.DrawFigureH := CurrLine.CalcHDrawFigure; end; end; except on E: Exception do addExceptionToLogEx('U_Common.LinesShiftDown', E.Message); end; end; procedure LinesShiftLeft(aLinesList: TList); var i: Integer; CurrLine: TOrthoLine; Bnd: TDoubleRect; AngleDegrees, AngleRad: Double; dx, dy: double; oldCP, newCP: TDoublePoint; delta: double; begin try delta := 0.1; for i := 0 to aLinesList.Count - 1 do begin CurrLine := TOrthoLine(aLinesList[i]); if (CurrLine.DrawFigure <> nil) and (CurrLine.DrawFigure.InFigures.Count > 0) then begin // получить старую центр точку DrawFigure Bnd := CurrLine.DrawFigure.GetBoundRect; oldCP.x := (Bnd.Left + Bnd.Right) / 2; oldCP.y := (Bnd.Top + Bnd.Bottom) / 2; // получить точку пересечения AngleDegrees := CurrLine.GetAngle(CurrLine.ActualPoints[1].x, CurrLine.ActualPoints[1].y, CurrLine.ActualPoints[2].x, CurrLine.ActualPoints[2].y); AngleRad := AngleDegrees * pi / 180; // получить точку для перемещения AngleDegrees := AngleDegrees + 90; AngleDegrees := round(AngleDegrees) mod 360; AngleRad := AngleDegrees * pi / 180; if ((AngleDegrees >= 0) and (AngleDegrees < 90)) then begin dx := - (delta * Cos(AngleRad)); dy := - (delta * Sin(AngleRad)); end; if ((AngleDegrees >= 90) and (AngleDegrees < 180)) then begin dx := (delta * Cos(AngleRad)); dy := (delta * Sin(AngleRad)); end; if ((AngleDegrees >= 180) and (AngleDegrees < 270)) then begin dx := - (delta * Cos(AngleRad)); dy := - (delta * Sin(AngleRad)); end; if ((AngleDegrees >= 270) and (AngleDegrees < 360)) then begin dx := (delta * Cos(AngleRad)); dy := (delta * Sin(AngleRad)); end; if (AngleDegrees >= 180) and (AngleDegrees < 360) then begin dx := -dx; dy := -dy; end; // если поворот на 180 то перебросить линию на другую сторону if CurrLine.FIsRotated then begin dx := -dx; dy := -dy; end; newCP.x := oldCP.x + dx; newCP.y := oldCP.y + dy; CurrLine.DrawFigure.move(newCP.x - oldCP.x, newCP.y - oldCP.y); CurrLine.DrawFigureH := CurrLine.CalcHDrawFigure; end; end; except on E: Exception do addExceptionToLogEx('U_Common.LinesShiftLeft', E.Message); end; end; procedure LinesShiftRight(aLinesList: TList); var i: Integer; CurrLine: TOrthoLine; Bnd: TDoubleRect; AngleDegrees, AngleRad: Double; dx, dy: double; oldCP, newCP: TDoublePoint; delta: double; begin try delta := 0.1; for i := 0 to aLinesList.Count - 1 do begin CurrLine := TOrthoLine(aLinesList[i]); if (CurrLine.DrawFigure <> nil) and (CurrLine.DrawFigure.InFigures.Count > 0) then begin // получить старую центр точку DrawFigure Bnd := CurrLine.DrawFigure.GetBoundRect; oldCP.x := (Bnd.Left + Bnd.Right) / 2; oldCP.y := (Bnd.Top + Bnd.Bottom) / 2; // получить точку пересечения AngleDegrees := CurrLine.GetAngle(CurrLine.ActualPoints[1].x, CurrLine.ActualPoints[1].y, CurrLine.ActualPoints[2].x, CurrLine.ActualPoints[2].y); AngleRad := AngleDegrees * pi / 180; // получить точку для перемещения AngleDegrees := AngleDegrees + 90; AngleDegrees := round(AngleDegrees) mod 360; AngleRad := AngleDegrees * pi / 180; if ((AngleDegrees >= 0) and (AngleDegrees < 90)) then begin dx := (delta * Cos(AngleRad)); dy := (delta * Sin(AngleRad)); end; if ((AngleDegrees >= 90) and (AngleDegrees < 180)) then begin dx := - (delta * Cos(AngleRad)); dy := - (delta * Sin(AngleRad)); end; if ((AngleDegrees >= 180) and (AngleDegrees < 270)) then begin dx := (delta * Cos(AngleRad)); dy := (delta * Sin(AngleRad)); end; if ((AngleDegrees >= 270) and (AngleDegrees < 360)) then begin dx := - (delta * Cos(AngleRad)); dy := - (delta * Sin(AngleRad)); end; if (AngleDegrees >= 180) and (AngleDegrees < 360) then begin dx := -dx; dy := -dy; end; // если поворот на 180 то перебросить линию на другую сторону if CurrLine.FIsRotated then begin dx := -dx; dy := -dy; end; newCP.x := oldCP.x + dx; newCP.y := oldCP.y + dy; CurrLine.DrawFigure.move(newCP.x - oldCP.x, newCP.y - oldCP.y); CurrLine.DrawFigureH := CurrLine.CalcHDrawFigure; end; end; except on E: Exception do addExceptionToLogEx('U_Common.LinesShiftRight', E.Message); end; end; procedure SetIsCableChannel(aListID, aLineID: Integer; aFlag: Boolean); var vList: TF_CAD; vLine: TOrthoLine; begin try vList := GetListByID(aListID); if vList <> nil then begin vLine := TOrthoLine(GetFigureByID(vList, aLineID)); if vLine <> nil then vLine.FIsCableChannel := aFlag; end; except on E: Exception do addExceptionToLogEx('U_Common.SetIsCableChannel', E.Message); end; end; //Tolik 17/07/2025 -- procedure SaveForProjectUndo(aLists: TList; aSavePM: Boolean; aIsProject: Boolean; a3d: boolean = false); //procedure SaveForProjectUndo(aLists: TList; aSavePM: Boolean; aIsProject: Boolean); var i, j: integer; vList: TF_CAD; ProjectUndoAction: TProjectUndoAction; ListUndoAction: TListUndoAction; LinkUndoObject: TLinkUndoObject; SavedGCadForm: TF_CAD; SaveGCadRefreshFlag: boolean; begin try SaveGCadRefreshFlag := GCanRefreshCad; GCanRefreshCad := false; if GUndoList = nil then GUndoList := TList.Create; ProjectUndoAction := TProjectUndoAction.create; SavedGCadForm := GCadForm; for i := 0 to aLists.Count - 1 do begin vList := TF_CAD(aLists[i]); GCadForm := vList; ListUndoAction := nil; //#From Oleg# //14.09.2010 // if vList.FListType = lt_Normal then ListUndoAction := vList.SaveForUndoNormalList(uat_Floor, aSavePM, aIsProject, i, a3D) else if vList.FListType = lt_ProjectPlan then ListUndoAction := vList.SaveForUndoProjectPlan(uat_Floor, aSavePM, aIsProject, i, a3D) else if vList.FListType = lt_DesignBox then ListUndoAction := vList.SaveForUndoDesignList(uat_Floor, aSavePM, aIsProject, i, a3d) // Tolik 12/02/2021 -- else if vList.FListType = lt_ElScheme then ListUndoAction := vList.SaveForUndoELScheme(uat_Floor, aSavePM, aIsProject, i, a3d); // ListUndoAction := vList.SaveForUndo(uat_Floor, aSavePM, aIsProject, i); // if ListUndoAction <> nil then begin ListUndoAction.FProjectUndoAction := ProjectUndoAction; LinkUndoObject := TLinkUndoObject.create; LinkUndoObject.FCad := vList; LinkUndoObject.FListUndoAction := ListUndoAction; ProjectUndoAction.FLinkUndoObject.Add(LinkUndoObject); end; end; GCadForm := SavedGCadForm; GUndoList.Add(ProjectUndoAction); except on E: Exception do addExceptionToLogEx('U_Common.SaveForProjectUndo', E.Message); end; GCanRefreshCad := SaveGCadRefreshFlag; end; procedure DeleteProjectUndoActions(aCad: TF_CAD; aListUndoAction: TListUndoAction); var i, j: integer; vList: TF_CAD; ProjectUndoAction: TProjectUndoAction; ListUndoAction: TListUndoAction; LinkUndoObject: TLinkUndoObject; Index: Integer; Count: Integer; OldFName, FName: string; SetUndoName: string; begin try if GUndoList <> nil then begin ProjectUndoAction := aListUndoAction.FProjectUndoAction; // удалить из глобал листа GUndoList.Remove(ProjectUndoAction); // удалить со всех листов for i := 0 to ProjectUndoAction.FLinkUndoObject.Count - 1 do begin LinkUndoObject := TLinkUndoObject(ProjectUndoAction.FLinkUndoObject[i]); vList := LinkUndoObject.FCad; ListUndoAction := LinkUndoObject.FListUndoAction; //Index := -1; //if vList.FSCSUndoList <> nil then // Index := vList.FSCSUndoList.IndexOf(ListUndoAction); Index := vList.FSCSUndoList.IndexOf(ListUndoAction); // этот Undo не с текущего листа (он уже обработат) if ListUndoAction <> aListUndoAction then begin // удалить с указанного листа нужный Undo и все что перед ним while Index >= 0 do begin ListUndoAction := TListUndoAction(vList.FSCSUndoList[Index]); FName := ListUndoAction.FCadFileName; // удалить файл if FileExists(FName) then DeleteFile(FName); // удалить элемент из списка файлов vList.FSCSUndoList.Delete(Index); // *UNDO ProjectManager* DeleteUndoFromPM(vList.FCADListID, ListUndoAction.FBasePath, ListUndoAction.FIsProject); FreeAndNil(ListUndoAction); Index := Index - 1; end; // переприсвоить имена файлов с учетом смещения for j := 0 to vList.FSCSUndoList.Count - 1 do begin ListUndoAction := TListUndoAction(vList.FSCSUndoList[j]); // FName := vList.FUndoDir + vList.FCADListName + IntTostr(vList.FCADListIndex) + '_' + IntToStr(j); FName := vList.FUndoDir + vList.FCADListFileName + '_' + IntToStr(j); OldFName := ListUndoAction.FCadFileName; RenameFile(OldFName, FName); ListUndoAction.FCadFileName := FName; end; end; end; end; except on E: Exception do addExceptionToLogEx('U_Common.DeleteProjectUndoActions', E.Message); end; end; procedure LoadProjectUndoActions(aCad: TF_CAD; aListUndoAction: TListUndoAction); var i, j, k, l: integer; vList: TF_CAD; ProjectUndoAction: TProjectUndoAction; ListUndoAction, DelListUndoAction: TListUndoAction; LinkUndoObject: TLinkUndoObject; Index: Integer; Count: Integer; FName: string; SetUndoName: string; Stream: TMemoryStream; size: integer; SavedGCadForm: TF_CAD; CountInPrj: Integer; ListIndex: Integer; CurListParams: TListParams; ListOfLists: TList; Figure: TFigure; //Tolik CadFigList: TList; // begin try if GUndoList <> nil then begin ProjectUndoAction := aListUndoAction.FProjectUndoAction; // удалить из глобал листа GUndoList.Remove(ProjectUndoAction); // удалить со всех листов SavedGCadForm := GCadForm; ListIndex := 1; for i := 0 to ProjectUndoAction.FLinkUndoObject.Count - 1 do begin LinkUndoObject := TLinkUndoObject(ProjectUndoAction.FLinkUndoObject[i]); vList := LinkUndoObject.FCad; ListUndoAction := LinkUndoObject.FListUndoAction; Index := vList.FSCSUndoList.IndexOf(ListUndoAction); // этот Undo не с текущего листа (он уже обработан) if ListUndoAction <> aListUndoAction then begin // удалить с указанного листа все что после этого Undo j := vList.FSCSUndoList.Count - 1; while j > Index do begin DelListUndoAction := TListUndoAction(vList.FSCSUndoList[j]); FName := DelListUndoAction.FCadFileName; // удалить файл if FileExists(FName) then DeleteFile(FName); // удалить элемент из списка файлов vList.FSCSUndoList.Delete(j); FreeAndNil(DelListUndoAction); j := j - 1; end; GCadForm := vList; FName := ListUndoAction.FCadFileName; if FileExists(FName) then begin GCadForm.PCad.OnObjectInserted := nil; // поднять темповый файл if GCadForm.FListType = lt_Normal then GCadForm.ClearSCSFigures else GCadForm.ClearPlanFigures; //GCadForm.PCad.OnObjectInserted := nil; GCadForm.FUndoFiguresList.Clear; GCadForm.PCad.LoadSCSFiguresFromFile(FName); GCadForm.PCad.OnObjectInserted := GCadForm.PCadObjectInserted; GCadForm.FUndoStatus := True; try if GListWithEndPoint = GCadForm then begin GEndPoint := nil; GListWithEndPoint := nil; end; GNeedReRaiseProperties := False; //Tolik CadFigList := TList.Create; for k := 0 to GCadForm.PCad.FigureCount - 1 do CadFigList.Add(TFigure(GCadForm.PCad.Figures.Items[k])); for k := 0 to CadFigList.Count - 1 do begin Figure := TFigure(CadFigList[k]); 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 k := 0 to GCadForm.PCad.FigureCount - 1 do begin Figure := TFigure(GCadForm.PCad.Figures.Items[k]); 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 k := 0; while k < GCadForm.PCad.FigureCount do begin Figure := TFigure(GCadForm.PCad.Figures.Items[k]); if CheckFigureByClassName(Figure, cTConnectorObject) then begin TConnectorObject(Figure).ReRaiseProperties; end; if CheckFigureByClassName(Figure, cTOrthoLine) then begin TOrthoLine(Figure).ReRaiseProperties; end; k := k + 1; end; end; } finally GCadForm.FUndoStatus := False; end; FindObjectsForConvertClasses; // удалить файл if FileExists(FName) then DeleteFile(FName); // удалить последний который поднимается из спика GCadForm.FSCSUndoList.Delete(vList.FSCSUndoList.Count - 1); if ListUndoAction.ActionType = uat_Floor then begin CountInPrj := 0; // Tolik -- 09/02/2017 -- //ListOfLists := TList.Create; //* -- что-то не совсем понятно, нафиг оно тут нужно // for l := 0 to ListUndoAction.FProjectUndoAction.FLinkUndoObject.Count - 1 do begin LinkUndoObject := TLinkUndoObject(ListUndoAction.FProjectUndoAction.FLinkUndoObject[l]); if LinkUndoObject.FCad.FListType = lt_Normal then begin CountInPrj := CountInPrj + 1; end; end; end else CountInPrj := 1; // *UNDO ProjectManager* UndoListInPM(GCadForm.FCADListID, ListUndoAction.FBasePath, ListUndoAction.FIsProject, ListIndex, CountInPrj); CurListParams := GetListParams(GCadForm.FCADListID); LoadSettingsForListByParams(CurListParams, False); end; // удалить объект UndoAction FreeAndNil(ListUndoAction); ListIndex := ListIndex + 1; end; end; GcadForm := SavedGCadForm; end; except on E: Exception do addExceptionToLogEx('U_Common.LoadProjectUndoActions', E.Message); end; end; procedure SaveForUndoFromPM(aListsIDs: TIntList; aIsProject: Boolean = False); var i, j: integer; vList: TF_CAD; ID: Integer; vLists: TList; SaveGCadRefreshFlag: boolean; begin try SaveGCadRefreshFlag := GCanRefreshCad; GCanRefreshCad := false; if (aListsIDs <> nil) and (aListsIDs.Count > 0) then begin // сохранение одного листа if aListsIDs.Count = 1 then begin ID := aListsIDs[0]; ReOpenListInCADIfClosed(ID, ''); //17.08.2012 vList := GetListByID(ID); if vList <> nil then vList.SaveForUndo(uat_None, True, aIsProject); end else // сохранние нескольких листов begin vLists := TList.Create; for i := 0 to aListsIDs.Count - 1 do begin ID := aListsIDs[i]; ReOpenListInCADIfClosed(ID, ''); //17.08.2012 vList := GetListByID(ID); if vList <> nil then vLists.Add(vList); end; SaveForProjectUndo(vLists, True, aIsProject); FreeAndNil(vLists); end; end; except on E: Exception do addExceptionToLogEx('U_Common.SaveForUndoFromPM', E.Message); end; GCanRefreshCad := SaveGCadRefreshFlag; end; procedure SaveForProjectRedo(aLists: TList; aSavePM: Boolean; aIsProject: Boolean); var i, j: integer; vList: TF_CAD; ProjectUndoAction: TProjectUndoAction; ListUndoAction: TListUndoAction; LinkUndoObject: TLinkUndoObject; SavedGCadForm: TF_CAD; SaveGCadRefreshFlag: boolean; begin try SaveGCadRefreshFlag := GCanRefreshCad; GCanRefreshCad := false; if GRedoList = nil then GRedoList := TList.Create; ProjectUndoAction := TProjectUndoAction.create; SavedGCadForm := GCadForm; for i := 0 to aLists.Count - 1 do begin vList := TF_CAD(aLists[i]); GCadForm := vList; ListUndoAction := vList.SaveForRedo(uat_Floor, aSavePM, aIsProject, i); if ListUndoAction <> nil then begin ListUndoAction.FProjectUndoAction := ProjectUndoAction; LinkUndoObject := TLinkUndoObject.create; LinkUndoObject.FCad := vList; LinkUndoObject.FListUndoAction := ListUndoAction; ProjectUndoAction.FLinkUndoObject.Add(LinkUndoObject); end; end; GCadForm := SavedGCadForm; GRedoList.Add(ProjectUndoAction); except on E: Exception do AddExceptionToLogEx('U_Common.SaveForProjectRedo', E.Message); end; GCanRefreshCad := SaveGCadRefreshFlag; end; procedure DeleteProjectRedoActions(aCad: TF_CAD; aListUndoAction: TListUndoAction); var i, j: integer; vList: TF_CAD; ProjectUndoAction: TProjectUndoAction; ListUndoAction: TListUndoAction; LinkUndoObject: TLinkUndoObject; Index: Integer; Count: Integer; OldFName, FName: string; SetUndoName: string; begin try if GRedoList <> nil then begin ProjectUndoAction := aListUndoAction.FProjectUndoAction; // удалить из глобал листа GRedoList.Remove(ProjectUndoAction); // удалить со всех листов for i := 0 to ProjectUndoAction.FLinkUndoObject.Count - 1 do begin LinkUndoObject := TLinkUndoObject(ProjectUndoAction.FLinkUndoObject[i]); vList := LinkUndoObject.FCad; ListUndoAction := LinkUndoObject.FListUndoAction; Index := vList.FSCSRedoList.IndexOf(ListUndoAction); // этот Undo не с текущего листа (он уже обработат) if ListUndoAction <> aListUndoAction then begin // удалить с указанного листа нужный Redo и все что перед ним while Index >= 0 do begin ListUndoAction := TListUndoAction(vList.FSCSRedoList[Index]); FName := ListUndoAction.FCadFileName; // удалить файл if FileExists(FName) then DeleteFile(FName); // удалить элемент из списка файлов vList.FSCSRedoList.Delete(Index); // *UNDO ProjectManager* DeleteUndoFromPM(vList.FCADListID, ListUndoAction.FBasePath, ListUndoAction.FIsProject); FreeAndNil(ListUndoAction); Index := Index - 1; end; // переприсвоить имена файлов с учетом смещения for j := 0 to vList.FSCSRedoList.Count - 1 do begin ListUndoAction := TListUndoAction(vList.FSCSRedoList[j]); // FName := vList.FRedoDir + vList.FCADListName + IntTostr(vList.FCADListIndex) + '_' + IntToStr(j); FName := vList.FRedoDir + vList.FCADListFileName + '_' + IntToStr(j); OldFName := ListUndoAction.FCadFileName; RenameFile(OldFName, FName); ListUndoAction.FCadFileName := FName; end; end; end; end; except on E: Exception do AddExceptionToLogEx('U_Common.DeleteProjectRedoActions', E.Message); end; end; procedure LoadProjectRedoActions(aCad: TF_CAD; aListUndoAction: TListUndoAction); var i, j, k: integer; vList: TF_CAD; ProjectUndoAction: TProjectUndoAction; ListUndoAction, DelListUndoAction: TListUndoAction; LinkUndoObject: TLinkUndoObject; Index: Integer; Count: Integer; FName: string; SetUndoName: string; Stream: TMemoryStream; size: integer; SavedGCadForm: TF_CAD; CountInPrj: Integer; ListIndex: Integer; CurListParams: TListParams; Figure: TFigure; //Tolik CadFigList: TList; // begin try if GRedoList <> nil then begin ProjectUndoAction := aListUndoAction.FProjectUndoAction; // удалить из глобал листа GRedoList.Remove(ProjectUndoAction); // удалить со всех листов SavedGCadForm := GCadForm; ListIndex := 1; for i := 0 to ProjectUndoAction.FLinkUndoObject.Count - 1 do begin LinkUndoObject := TLinkUndoObject(ProjectUndoAction.FLinkUndoObject[i]); vList := LinkUndoObject.FCad; ListUndoAction := LinkUndoObject.FListUndoAction; Index := vList.FSCSRedoList.IndexOf(ListUndoAction); // этот Undo не с текущего листа (он уже обработан) if ListUndoAction <> aListUndoAction then begin // удалить с указанного листа все что после этого Undo j := vList.FSCSRedoList.Count - 1; while j > Index do begin DelListUndoAction := TListUndoAction(vList.FSCSRedoList[j]); FName := DelListUndoAction.FCadFileName; // удалить файл if FileExists(FName) then DeleteFile(FName); // удалить элемент из списка файлов vList.FSCSRedoList.Delete(j); FreeAndNil(DelListUndoAction); j := j - 1; end; GCadForm := vList; FName := ListUndoAction.FCadFileName; if FileExists(FName) then begin GCadForm.PCad.OnObjectInserted := nil; // поднять темповый файл if GCadForm.FListType = lt_Normal then GCadForm.ClearSCSFigures else GCadForm.ClearPlanFigures; //GCadForm.PCad.OnObjectInserted := nil; GCadForm.FUndoFiguresList.Clear; GCadForm.PCad.LoadSCSFiguresFromFile(FName); GCadForm.PCad.OnObjectInserted := GCadForm.PCadObjectInserted; GCadForm.FUndoStatus := True; try if GListWithEndPoint = GCadForm then begin GEndPoint := nil; GListWithEndPoint := nil; end; GNeedReRaiseProperties := False; //Tolik CadFigList := TList.create; for k := 0 to GCadForm.PCad.FigureCount - 1 do CadFigList.Add(TFigure(GCadForm.PCad.Figures.Items[k])); for k := 0 to CadFigList.Count - 1 do begin Figure := TFigure(CadFigList[k]); 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 k := 0 to GCadForm.PCad.FigureCount - 1 do begin Figure := TFigure(GCadForm.PCad.Figures.Items[k]); 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 k := 0; while k < GCadForm.PCad.FigureCount do begin Figure := TFigure(GCadForm.PCad.Figures.Items[k]); if CheckFigureByClassName(Figure, cTConnectorObject) then begin TConnectorObject(Figure).ReRaiseProperties; end; if CheckFigureByClassName(Figure, cTOrthoLine) then begin TOrthoLine(Figure).ReRaiseProperties; end; k := k + 1; end; end; } finally GCadForm.FUndoStatus := False; end; FindObjectsForConvertClasses; // удалить файл if FileExists(FName) then DeleteFile(FName); // удалить последний который поднимается из спика GCadForm.FSCSRedoList.Delete(vList.FSCSRedoList.Count - 1); if ListUndoAction.ActionType = uat_Floor then CountInPrj := ListUndoAction.FProjectUndoAction.FLinkUndoObject.Count else CountInPrj := 1; // *UNDO ProjectManager* UndoListInPM(GCadForm.FCADListID, ListUndoAction.FBasePath, ListUndoAction.FIsProject, ListIndex, CountInPrj); CurListParams := GetListParams(GCadForm.FCADListID); LoadSettingsForListByParams(CurListParams, False); end; // удалить объект UndoAction FreeAndNil(ListUndoAction); ListIndex := ListIndex + 1; end; end; GcadForm := SavedGCadForm; end; except on E: Exception do AddExceptionToLogEx('U_Common.LoadProjectRedoActions', E.Message); end; end; procedure SaveForRedoFromPM(aListsIDs: TIntList; aIsProject: Boolean = False); var i, j: integer; vList: TF_CAD; ID: Integer; vLists: TList; SaveGCadRefreshFlag: boolean; begin try SaveGCadRefreshFlag := GCanRefreshCad; GCanRefreshCad := false; if (aListsIDs <> nil) and (aListsIDs.Count > 0) then begin // сохранение одного листа if aListsIDs.Count = 1 then begin ID := aListsIDs[0]; vList := GetListByID(ID); if vList <> nil then vList.SaveForRedo(uat_None, True, aIsProject); end else // сохранние нескольких листов begin vLists := TList.Create; for i := 0 to aListsIDs.Count - 1 do begin ID := aListsIDs[i]; vList := GetListByID(ID); if vList <> nil then vLists.Add(vList); end; SaveForProjectRedo(vLists, True, aIsProject); FreeAndNil(vLists); end; end; except on E: Exception do AddExceptionToLogEx('U_Common.SaveForRedoFromPM', E.Message); end; GCanRefreshCad := SaveGCadRefreshFlag; end; function GetOtherListRelatedToFigure(AListID, AFigureID: Integer): Integer; var vList: TF_CAD; vFigure: TFigure; vConn: TConnectorObject; vLine: TOrthoLine; RaiseConn, Join1, Join2: TConnectorObject; begin Result := -1; try vList := GetListByID(AListID); if vList <> nil then begin vFigure := GetFigureByID(vList, AFigureID); if vFigure <> nil then begin // КОННЕКТОР if CheckFigureByClassName(vFigure, cTConnectorObject) then begin vConn := TConnectorObject(vFigure); // это вершина межэтиажного перехода if (vConn.FConnRaiseType = crt_BetweenFloorUp) or (vConn.FConnRaiseType = crt_BetweenFloorDown) or (vConn.FConnRaiseType = crt_TrunkUp) or (vConn.FConnRaiseType = crt_TrunkDown) then begin Result := vConn.FID_ListToPassage; end else // на этом коннекторе есть вершина межэтажного begin RaiseConn := GetRaiseConn(vConn); if RaiseConn <> nil then if (RaiseConn.FConnRaiseType = crt_BetweenFloorUp) or (RaiseConn.FConnRaiseType = crt_BetweenFloorDown) or (RaiseConn.FConnRaiseType = crt_TrunkUp) or (RaiseConn.FConnRaiseType = crt_TrunkDown) then Result := RaiseConn.FID_ListToPassage; end; end // ОРТОЛИНИЯ else if CheckFigureByClassName(vFigure, cTOrthoLine) then begin vLine := TOrthoLine(vFigure); if vLine.FIsRaiseUpDown then begin Join1 := TConnectorObject(vLine.JoinConnector1); Join2 := TConnectorObject(vLine.JoinConnector2); if (Join1.FConnRaiseType = crt_BetweenFloorUp) or (Join1.FConnRaiseType = crt_BetweenFloorDown) or (Join1.FConnRaiseType = crt_TrunkUp) or (Join1.FConnRaiseType = crt_TrunkDown) then Result := Join1.FID_ListToPassage; if (Join2.FConnRaiseType = crt_BetweenFloorUp) or (Join2.FConnRaiseType = crt_BetweenFloorDown) or (Join2.FConnRaiseType = crt_TrunkUp) or (Join2.FConnRaiseType = crt_TrunkDown) then Result := Join2.FID_ListToPassage; end; end; end; end; except on E: Exception do addExceptionToLogEx('U_Common.GetOtherListRelatedToFigure', E.Message); end; end; function GetRelatedListsBySelected(aObjects: TList; aCheckBySelectedType: TCheckBySelectedType): TList; var i, j: Integer; vFigure: TFigure; vConn: TConnectorObject; vLine: TOrthoLine; vList: TF_CAD; RaiseConn, Join1, Join2: TConnectorObject; begin Result := TList.Create; try Result.Add(GCadForm); for i := 0 to aObjects.Count - 1 do begin vFigure := TFigure(aOBjects[i]); if CheckFigureByClassName(vFigure, cTConnectorObject) then begin vConn := TConnectorObject(vFigure); // это шкаф, который удаляется, нужно удалить ссылки на лист дизайна шкафа if aCheckBySelectedType = cst_Delete then if vConn.FJoinedListIDForBox <> - 1 then vConn.FJoinedListIDForBox := - 1; // это вершина межэтиажного перехода if (vConn.FConnRaiseType = crt_BetweenFloorUp) or (vConn.FConnRaiseType = crt_BetweenFloorDown) or (vConn.FConnRaiseType = crt_TrunkUp) or (vConn.FConnRaiseType = crt_TrunkDown) then begin vList := GetListByID(vConn.FID_ListToPassage); if vList <> nil then if CheckNoCadInList(vList, Result) then Result.Add(vList); end else // на этом коннекторе есть вершина межэтажного begin RaiseConn := GetRaiseConn(vConn); if RaiseConn <> nil then if (RaiseConn.FConnRaiseType = crt_BetweenFloorUp) or (RaiseConn.FConnRaiseType = crt_BetweenFloorDown) or (RaiseConn.FConnRaiseType = crt_TrunkUp) or (RaiseConn.FConnRaiseType = crt_TrunkDown) then begin vList := GetListByID(RaiseConn.FID_ListToPassage); if vList <> nil then if CheckNoCadInList(vList, Result) then Result.Add(vList); end; end; end else if CheckFigureByClassName(vFigure, cTOrthoLine) then begin vLine := TOrthoLine(vFigure); Join1 := TConnectorObject(vLine.JoinConnector1); Join2 := TConnectorObject(vLine.JoinConnector2); // это вершина межэтиажного перехода if (Join1.FConnRaiseType = crt_BetweenFloorUp) or (Join1.FConnRaiseType = crt_BetweenFloorDown) or (Join1.FConnRaiseType = crt_TrunkUp) or (Join1.FConnRaiseType = crt_TrunkDown) then begin vList := GetListByID(Join1.FID_ListToPassage); if vList <> nil then if CheckNoCadInList(vList, Result) then Result.Add(vList); end else // на этом коннекторе есть вершина межэтажного if aCheckBySelectedType = cst_Move then begin RaiseConn := GetRaiseConn(Join1); if RaiseConn <> nil then if (RaiseConn.FConnRaiseType = crt_BetweenFloorUp) or (RaiseConn.FConnRaiseType = crt_BetweenFloorDown) or (RaiseConn.FConnRaiseType = crt_TrunkUp) or (RaiseConn.FConnRaiseType = crt_TrunkDown) then begin vList := GetListByID(RaiseConn.FID_ListToPassage); if vList <> nil then if CheckNoCadInList(vList, Result) then Result.Add(vList); end; end; // это вершина межэтиажного перехода if (Join2.FConnRaiseType = crt_BetweenFloorUp) or (Join2.FConnRaiseType = crt_BetweenFloorDown) or (Join2.FConnRaiseType = crt_TrunkUp) or (Join2.FConnRaiseType = crt_TrunkDown) then begin vList := GetListByID(Join2.FID_ListToPassage); if vList <> nil then if CheckNoCadInList(vList, Result) then Result.Add(vList); end else // на этом коннекторе есть вершина межэтажного if aCheckBySelectedType = cst_Move then begin RaiseConn := GetRaiseConn(Join2); if RaiseConn <> nil then if (RaiseConn.FConnRaiseType = crt_BetweenFloorUp) or (RaiseConn.FConnRaiseType = crt_BetweenFloorDown) or (RaiseConn.FConnRaiseType = crt_TrunkUp) or (RaiseConn.FConnRaiseType = crt_TrunkDown) then begin vList := GetListByID(RaiseConn.FID_ListToPassage); if vList <> nil then if CheckNoCadInList(vList, Result) then Result.Add(vList); end; end; end; end; except on E: Exception do addExceptionToLogEx('U_Common.GetRelatedListsBySelected', E.Message); end; end; function CheckOneOfSCSlayers(aLNbr: Integer): Boolean; begin Result := False; try if aLNbr = 2 then Result := True; if aLNbr = 3 then Result := True; if aLNbr = 4 then Result := True; if aLNbr = 5 then Result := True; if aLNbr = 6 then Result := True; if aLNbr = 9 then Result := True; except on E: Exception do addExceptionToLogEx('U_Common.CheckOneOfSCSlayers', E.Message); end; end; procedure DeselectAllSCSObjectsInCAD(AListID: Integer); var vList: TF_CAD; begin try vList := GetListByID(AListID); if vList <> nil then begin vList.PCad.DeselectAll(2); RefreshCAD(vList.PCad); end; except on E: Exception do AddExceptionToLogEx('U_Common.DeselectAllSCSObjectsInCAD', E.Message); end; end; procedure DeselectAllSCSObjectsInProject; var i: integer; CAD: TF_CAD; begin for i := 0 to FSCS_Main.MDIChildCount - 1 do begin CAD := TF_CAD(FSCS_Main.MDIChildren[i]); if CAD.FListType = lt_Normal then begin CAD.PCad.DeselectAll(2); RefreshCAD(CAD.PCad); end; end; end; procedure DeselectNoDrawed(aPCAD: TPowerCad); var i: Integer; Figure: TFigure; begin // Tolik -- 14/03/2016 -- СКС фигур меньше, быстрее сработает if aPCad.Owner <> nil then begin for i := 0 to TF_CAD(aPCAD.Owner).FSCSFigures.Count - 1 do begin Figure := TFigure(TF_CAD(aPCAD.Owner).FSCSFigures[i]); if Figure is TConnectorObject then if Not TConnectorObject(Figure).FIsDraw and TConnectorObject(Figure).Selected then TConnectorObject(Figure).DeSelect; end; end else // на всякий...оставим begin for i := 0 to aPCAD.Figures.Count - 1 do begin Figure := TFigure(aPCAD.Figures[i]); if Figure is TConnectorObject then if Not TConnectorObject(Figure).FIsDraw and TConnectorObject(Figure).Selected then TConnectorObject(Figure).DeSelect; end; end; end; procedure SelectObjectsInCADByIDs(aListID: Integer; aObjectsID: TIntList); var i: Integer; ID: Integer; vList: TF_CAD; vFigure: TFigure; begin try vList := GetListByID(aListID); if vList <> nil then begin for i := 0 to aObjectsID.Count - 1 do begin ID := aObjectsID[i]; vFigure := GetFigureByID(vList, ID); if vFigure <> nil then begin if Not GCanRefreshProperties then if (not vFigure.LockSelect) and (vList.PCad.ActiveLayer = 2) then GCanRefreshProperties := True; vFigure.Select; end; end; RefreshCAD(vList.PCad); end; except on E: Exception do AddExceptionToLogEx('U_Common.SelectObjectsInCADByIDs', E.Message); end; end; function GetObjectsListWithSelectedInCAD(aListID: Integer): TIntList; var i: Integer; vFigure: TFigure; vList: TF_CAD; begin Result := TIntList.create; try vList := GetListByID(aListID); if vList <> nil then begin for i := 0 to vList.PCad.SelectedCount - 1 do begin vFigure := TFigure(vList.PCad.Selection[i]); Result.Add(vFigure.ID); end; end; except on E: Exception do AddExceptionToLogEx('U_Common.GetObjectsListWithSelectedInCAD', E.Message); end; end; function Get_News(ParentWin : THandle; gpid, gURL_p, gURL_a, gfil : string; func : byte; var timr :word): byte; var ActHandle : THandle;//хэндл активного приложения GetNews : procedure(hndl : THandle; pid, URL_p, URL_a, fil : string; alarm, draw, autosave : boolean); stdcall; OpenNews : procedure(hndl : THandle; pid, URL_p, URL_a, fil : string); stdcall; GetInt : function(hndl : THandle; pid, URL_p, URL_a, fil : string):word; stdcall; begin Result:=0; (* if Newshandle = 0 then Newshandle := LoadLibrary(PChar('exnews.dll')); try if Newshandle<>0 then begin case func of 0:begin//проверка наличия новостей @GetNews:=GetProcAddress(Newshandle,'GetNews'); if @GetNews<>nil then begin try ActHandle:=GetForegroundWindow; GetNews(ParentWin, gpid, gURL_p, gURL_a, gfil,false, false, true); SetForegroundWindow(ActHandle);//чтобы не забирать фокус у активного окна! except Result:=4;// 4 - Ошибка выполнения процедуры Exit; end; end else begin Result:=2;// 2 - Ошибка вызова процедуры Exit; end; end;{1} 1:begin{2} //открытие формы для работы с новостями @OpenNews:=GetProcAddress(Newshandle,'Execute'); if @OpenNews<>nil then begin{a} try OpenNews(ParentWin, gpid, gURL_p, gURL_a, gfil) except Result:=4;// 4 - Ошибка выполнения процедуры Exit; end;{except} end{a} else begin Result:=2;// 2 - Ошибка вызова процедуры Exit; end; end;{2} 2:begin{3} //открытие формы для работы с новостями @GetInt:=GetProcAddress(Newshandle,'GetInterval'); if @GetInt<>nil then begin{a} try timr:=GetInt(ParentWin, gpid, gURL_p, gURL_a, gfil) except Result:=4;// 4 - Ошибка выполнения процедуры Exit; end;{except} end{a} else begin Result:=2;// 2 - Ошибка вызова процедуры Exit; end; end;{3} else begin Result:=3;// 3 - ошибочный параметр func Exit; end; end; end else begin Result:=1;// 1 - ошибка загрузки DLL, Exit; end; finally // if FreeLibrary(Newshandle) then // Newshandle:=0; end; *) end; //Tolik function GetRoomSquare(AListID, ARoomID: Integer; RecalcSquare:Boolean = False): Double; var vList: TF_CAD; Cabinet: TFigure; x1, x2, y1, y2: double; a, b, S: double; MaxX, MaxY, MinX, MinY: Double; i, j: Integer; sum1, sum2, resultsum: double; Segment: TPlSegment; begin Result := -1; sum1 := 0; sum2 := 0; try vList := GetListByID(AListID); Cabinet := nil; //#From Oleg# //14.09.2010 if vList <> nil then Cabinet := FindCabinetBySCSID(vList, ARoomID); if Cabinet <> nil then begin // Для простых кабинетов if CheckFigureByClassName(Cabinet, cTCabinet) then begin if (RecalcSquare or (TCabinet(Cabinet).FCabinetSquare = -1)) then begin (* ХРЕНОВО ОНО КАК ТО СЧИТАЕТ!!! ДА ЕЩЕ И БЕЗ УЧЕТА МАПСКЕЙЛ for i := 1 to Cabinet.PointCount - 1 do begin x1 := Cabinet.FigurePoints[i].x; y1 := Cabinet.FigurePoints[i].y; x2 := Cabinet.FigurePoints[i+1].x; y2 := Cabinet.FigurePoints[i+1].y; //S := S + ((y2+y1)/2) * ((x2-x1)/2); sum1 := sum1 + x1*y2; sum2 := sum2 + y1*x2; end; x1 := Cabinet.FigurePoints[TCabinetExt(Cabinet).PointCount].x; y1 := Cabinet.FigurePoints[TCabinetExt(Cabinet).PointCount].y; x2 := Cabinet.FigurePoints[1].x; y2 := Cabinet.FigurePoints[1].y; //S := S + ((y2+y1)/2) * ((x2-x1)/2); sum1 := sum1 + x1*y2; sum2 := sum2 + y1*x2; Result := RoundX(ABS(sum2 - sum1)/2, 2); *) x1 := Cabinet.ap1.x; y1 := Cabinet.ap1.y; x2 := Cabinet.ap3.x; y2 := Cabinet.ap3.y; a := abs(x2 - x1); a := a * vList.PCad.MapScale / 1000; b := abs(y2 - y1); b := b * vList.PCad.MapScale / 1000; S := a * b; Result := RoundX(S,2); if RecalcSquare then TCabinet(Cabinet).FCabinetSquare := -1; end else Result := TCabinet(Cabinet).FCabinetSquare; end else if CheckFigureByClassName(Cabinet, cTCabinetExt) then begin // !!! if (RecalcSquare or (TCabinetExt(Cabinet).FCabinetSquare = -1)) then begin S := 0; TCabinetExt(Cabinet).getbounds(MaxX, MaxY, MinX, MinY); for i := round(MinX) to round(MaxX) do begin for j := round(MinY) to round(MaxY) do begin if TCabinetExt(Cabinet).IsPointInMod(i, j) then S := S + 1; end; end; S := SQR(vList.PCad.MapScale / 1000) * S; Result := S; if RecalcSquare then TCabinetExt(Cabinet).FCabinetSquare := -1; { for i := 0 to TCabinetExt(Cabinet).Segments.Count - 1 do begin Segment:= TPlSegment(TCabinetExt(Cabinet).Segments); x1 := Segment.CPoint1.x; y1 := Segment.CPoint1.y; end;} // Tolik { TCabinetExt(Cabinet).getbounds(MaxX, MaxY, MinX, MinY); s := 0; sum1 := 0; sum2 := 0; ResultSum := 0; for i := 0 to TCabinetExt(Cabinet).Segments.Count - 1 do begin Segment:= TPlSegment(TCabinetExt(Cabinet).Segments); x1 := Segment.CPoint1.x; end; for i := 1 to TCabinetExt(Cabinet).PointCount - 1 do begin x1 := TCabinetExt(Cabinet).FigurePoints[i].x/10; y1 := TCabinetExt(Cabinet).FigurePoints[i].y/10; x2 := TCabinetExt(Cabinet).FigurePoints[i+1].x/10; y2 := TCabinetExt(Cabinet).FigurePoints[i+1].y/10; S := S + ((y2+y1)/2) * ((x2-x1)/2); sum1 := sum1 + x1*y2; sum2 := sum2 + y1*x2; end; x1 := TCabinetExt(Cabinet).FigurePoints[TCabinetExt(Cabinet).PointCount].x/10; y1 := TCabinetExt(Cabinet).FigurePoints[TCabinetExt(Cabinet).PointCount].y/10; x2 := TCabinetExt(Cabinet).FigurePoints[1].x/10; y2 := TCabinetExt(Cabinet).FigurePoints[1].y/10; S := S + ((y2+y1)/2) * ((x2-x1)/2); sum1 := sum1 + x1*y2; sum2 := sum2 + y1*x2; Result := RoundX(ABS(sum2 - sum1)/2, 2); } end else Result := TCabinetExt(Cabinet).FCabinetSquare; end; end; except on E: Exception do AddExceptionToLogEx('U_Common.GetRoomSquare', E.Message); end; end; { function GetRoomSquare(AListID, ARoomID: Integer): Double; var vList: TF_CAD; Cabinet: TFigure; x1, x2, y1, y2: double; a, b, S: double; MaxX, MaxY, MinX, MinY: Double; i, j: Integer; begin Result := -1; try vList := GetListByID(AListID); Cabinet := nil; //#From Oleg# //14.09.2010 if vList <> nil then Cabinet := FindCabinetBySCSID(vList, ARoomID); if Cabinet <> nil then begin if CheckFigureByClassName(Cabinet, cTCabinet) then begin x1 := Cabinet.ap1.x; y1 := Cabinet.ap1.y; x2 := Cabinet.ap3.x; y2 := Cabinet.ap3.y; a := abs(x2 - x1); a := a * vList.PCad.MapScale / 1000; b := abs(y2 - y1); b := b * vList.PCad.MapScale / 1000; S := a * b; Result := S; end else if CheckFigureByClassName(Cabinet, cTCabinetExt) then begin // !!! S := 0; TCabinetExt(Cabinet).getbounds(MaxX, MaxY, MinX, MinY); for i := round(MinX) to round(MaxX) do begin for j := round(MinY) to round(MaxY) do begin if TCabinetExt(Cabinet).IsPointInMod(i, j) then S := S + 1; end; end; S := SQR(vList.PCad.MapScale / 1000) * S; Result := S; end; end; except on E: Exception do AddExceptionToLogEx('U_Common.GetRoomSquare', E.Message); end; end; } //Tolik // function GetRoomVolume(AListID, ARoomID: Integer ): Double; function GetRoomVolume(AListID, ARoomID: Integer; ARoomSquare: Double): Double; var x1, x2, y1, y2: double; S, V: double; begin Result := 0; try //S := GetRoomSquare(AListID, ARoomID); //V := S * GCadForm.FRoomHeight; V := ARoomSquare * GCadForm.FRoomHeight; Result := V; except on E: Exception do AddExceptionToLogEx('U_Common.GetRoomVolume', E.Message); end; end; // Tolik 17/06/2018 -- Function GetDoorHeightfor3DModel: Double; begin Result := MetreToUom(2); if (GCadForm.FListSettings.HeightRoom - MetreToUom(2)) > MetreToUom(0.5) then Result := GCadForm.FListSettings.HeightRoom - MetreToUom(0.5); end; Function GetWndHeightFor3DModel: Double; begin Result := MetreToUom(1.5); if (GCadForm.FListSettings.HeightRoom - MetreToUom(1)) > MetretoUom(0.7) then Result := GCadForm.FListSettings.HeightRoom - MetreToUom(1); end; function Get3DWallHeight: Double; begin Result := GCadForm.FListSettings.HeightRoom; end; // procedure CreateVirtualCabinetInCAD(vList: TF_CAD); var Cabinet: TCabinet; Lhandle: Integer; x1, y1, x2, y2: double; begin try if vList <> nil then begin x1 := vList.PCad.Left; x2 := vList.PCad.Left + vList.PCad.WorkWidth; y1 := vList.PCad.Top; y2 := vList.PCad.Top + vList.PCad.WorkHeight; LHandle := vList.PCad.GetLayerHandle(9); Cabinet := TCabinet.create(x1, y1, x2, y2, 1, ord(psSolid), clBlack, ord(bsClear), clBlack, LHandle, mydsNormal, vList.PCad); vList.PCad.AddCustomFigure(9, Cabinet, False); end; except on E: Exception do AddExceptionToLogEx('U_Common.CreateVirtualCabinetInCAD', E.Message); end; end; procedure ReScaleDrawingToListFormat(aOldListW, aOldListH: double); var ListFormat: TListFormatType; Grp: TSCSFigureGrp; rp: TDoublePoint; i: Integer; Cabinet: TCabinet; CabinetExt: TCabinetExt; SCSFigureGrp: TSCSFigureGrp; cp: TDoublePoint; BoundRect: TDoubleRect; koefx, koefy: double; deltax, deltay: double; oldsizex, oldsizey, newsizex, newsizey: double; NewListW, NewListH: double; Figure: TFigure; begin try BeginProgress; NewListW := GCadForm.PCad.WorkWidth; NewListH := GCadForm.PCad.WorkHeight; GCadForm.PCad.SelectAll(1); GCadForm.PCad.SelectAll(2); GCadForm.PCad.SelectAll(8); GCadForm.PCad.SelectAll(9); BoundRect := GCadForm.PCad.GetSelectionRect; GCadForm.PCad.DeselectAll(0); rp := DoublePoint(BoundRect.Left, BoundRect.Top); // 1 - подложка GCadForm.PCad.SelectAll(1); oldsizex := abs(BoundRect.Right - BoundRect.Left); oldsizey := abs(BoundRect.Bottom - BoundRect.Top); deltax := aOldListW - oldsizex; newsizex := NewListW - deltax; koefx := newsizex / oldsizex; deltay := aOldListH - oldsizey; newsizey := NewListH - deltay; koefy := newsizey / oldsizey; GCadForm.PCad.ScaleSelection(koefx, koefy, rp); GCadForm.PCad.DeSelectAll(1); // (2-6) СКС GCadForm.PCad.SelectAll(2); Grp := SCSGroupSelection; if Grp <> nil then begin Grp.Scale(koefx, koefy, rp); Grp.UnGroup; GCadForm.PCad.Figures.Remove(Grp); end; GCadForm.PCad.DeSelectAll(2); // отдельно Scale для TSCSFigureGrp for i := 0 to GCadForm.PCad.FigureCount - 1 do begin if CheckFigureByClassName(TFigure(GCadForm.PCad.Figures[i]), cTSCSFigureGrp) then begin SCSFigureGrp := TSCSFigureGrp(GCadForm.PCad.Figures[i]); SCSFigureGrp.Scale(koefx, koefy, rp); end; end; //Залочил,потому что ниже данный ActiveNet пересчитывается ещё раз { // 8 - архитектурный if ActiveNet <> nil then ActiveNet.Scale(koefx, koefy, rp); } // 9 - кабинеты for i := 0 to GCadForm.Pcad.FigureCount - 1 do begin Figure := TFigure(GCadForm.Pcad.Figures[i]); if Figure is TCabinet then begin Cabinet := TCabinet(Figure); Cabinet.Scale(koefx, koefy, rp); if Cabinet.FNumberObject <> nil then begin cp.x := (Cabinet.ActualPoints[1].x + Cabinet.ActualPoints[3].x) / 2; cp.y := (Cabinet.ActualPoints[1].y + Cabinet.ActualPoints[3].y) / 2; Cabinet.FNumberObject.move(CP.x - Cabinet.FNumberObject.CenterPoint.x, CP.y - Cabinet.FNumberObject.CenterPoint.y); end; MoveObjectsToCabinetOnMove(Cabinet); end else if Figure is TCabinetExt then begin CabinetExt := TCabinetExt(Figure); CabinetExt.Scale(koefx, koefy, rp); CabinetExt.CenterNumberObject; end // Если арх. объект else if Figure is TNet then begin TNet(Figure).Scale(koefx, koefy, rp); end; end; RefreshCAD(GCadForm.PCad); except on E: Exception do AddExceptionToLogEx('U_Common.ReScaleDrawingToListFormat', E.Message); end; EndProgress; end; procedure DeleteDxfLayers(aPCad: TPowerCad); var i: integer; vLayer: TLayer; vLNbr: Integer; vList: TList; begin vList := TList.Create; try BeginProgress; for i := 10 to aPcad.Layers.count - 1 do begin vLayer := TLayer(aPcad.Layers[i]); if vLayer.isDxf then vList.add(vLayer); end; for i := 0 to vList.Count - 1 do begin vLayer := TLayer(vList[i]); vLNbr := aPCad.GetLayerNbr(vLayer); aPCad.DeleteLayerWithNbr(vLNbr); end; except on E: Exception do AddExceptionToLogEx('U_Common.DeleteDxfLayers', E.Message); end; EndProgress; FreeAndNil(vList); end; function CheckFigureInDXFLayer(aFigure: TFigure): Boolean; var i: integer; Layer: Tlayer; fLNbr: integer; begin Result := false; try for i := 10 to GCadForm.PCad.LayerCount - 1 do begin Layer := TLayer(GCadForm.PCad.Layers[i]); if Layer.IsDxf then begin if (aFigure.LayerHandle = LongInt(Layer)) then Result := true; end; end; except on E: Exception do AddExceptionToLogEx('U_Common.CheckFigureInDXFLayer', E.Message); end; end; procedure ApplyUOMForProject(aOldUOM, aNewUOM: Integer); var i: Integer; vList: TF_CAD; //vLists: TList; begin try // *UNDO* // vLists := TList.Create; // for i := 0 to FSCS_Main.MDIChildCount - 1 do // begin // vList := TF_CAD(FSCS_Main.MDIChildren[i]); // vLists.add(vList); // end; // SaveForProjectUndo(vLists, True, False); // // метрическая if (aNewUOM = umSM) or (aNewUOM = umM) then begin // была американская, поставить на все листы метрическую if (aOldUOM = umIn) or (aOldUOM = umFt) then begin for i := 0 to FSCS_Main.MDIChildCount - 1 do begin vList := TF_CAD(FSCS_Main.MDIChildren[i]); vList.PCad.RulerSystem := rsMetric; end; end; end else // американская if (aNewUOM = umIn) or (aNewUOM = umFt) then begin // была метрическая, поставить на все листы американскую if (aOldUOM = umSM) or (aOldUOM = umM) then begin for i := 0 to FSCS_Main.MDIChildCount - 1 do begin vList := TF_CAD(FSCS_Main.MDIChildren[i]); vList.PCad.RulerSystem := rsWhitworth; end; end; end; except on E: Exception do AddExceptionToLogEx('U_Common.ApplyUOMForProject', E.Message); end; end; function GetUOMString(aUOM: Integer): string; begin try Result := ' '; if aUOM = umSM then Result := Result + cMetric_sm; if aUOM = umM then Result := Result + cMetric_m; if aUOM = umIn then Result := Result + cWhitworth_in; if aUOM = umFt then Result := Result + cWhitworth_ft; except on E: Exception do AddExceptionToLogEx('U_Common.GetUOMString', E.Message); end; end; // перевести метры в текущую систему измерений function MetreToUOM(aValue: Double): Double; begin Result := 0; try Result := FloatInUOM(AValue, umM, GCurrProjUnitOfMeasure); except on E: Exception do AddExceptionToLogEx('U_Common.MetreToUOM', E.Message); end; end; // перевести текущую систему измерений в метры function UOMToMetre(aValue: Double): Double; begin Result := 0; try Result := FloatInUOM(AValue, GCurrProjUnitOfMeasure, umM); except on E: Exception do AddExceptionToLogEx('U_Common.UOMToMetre', E.Message); end; end; procedure UpdateAllTracesLengthAndRefreshTextBoxOnAllLists; var i, j: Integer; vList: TF_CAD; vLine: TOrtholine; SavedGCadForm: TF_CAD; begin try for i := 0 to FSCS_Main.MDIChildCount - 1 do begin vList := TF_CAD(FSCS_Main.MDIChildren[i]); if vList.FListType = lt_Normal then begin for j := 0 to vList.PCad.FigureCount - 1 do begin if CheckFigureByClassName(TFigure(vLIst.PCad.Figures[j]), cTOrthoLine) then begin SavedGCadForm := GCadForm; GCadForm := vList; vLine := TOrthoLine(vLIst.PCad.Figures[j]); vLine.UpdateLengthTextBox(true, false); vLine.ReCreateNotesGroup(True); SetConFigureCoordZInPM(vLine.JoinConnector1.ID, vLine.ActualZOrder[1]); SetConFigureCoordZInPM(vLine.JoinConnector2.ID, vLine.ActualZOrder[2]); GCadForm := SavedGCadForm; end; end; end; end; except on E: Exception do AddExceptionToLogEx('UpdateAllTracesLengthOnAllLists', E.Message); end; end; procedure UpdateAllTracesLengthOnAllLists; var i, j: Integer; vList: TF_CAD; vLine: TOrtholine; SavedGCadForm: TF_CAD; begin try for i := 0 to FSCS_Main.MDIChildCount - 1 do begin vList := TF_CAD(FSCS_Main.MDIChildren[i]); if vList.FListType = lt_Normal then begin for j := 0 to vList.PCad.FigureCount - 1 do begin if CheckFigureByClassName(TFigure(vLIst.PCad.Figures[j]), cTOrthoLine) then begin SavedGCadForm := GCadForm; GCadForm := vList; vLine := TOrthoLine(vLIst.PCad.Figures[j]); vLine.UpdateLengthTextBox(true, false); GCadForm := SavedGCadForm; end; end; end; end; except on E: Exception do AddExceptionToLogEx('UpdateAllTracesLengthOnAllLists', E.Message); end; end; function CadsToIntCads(aList: TList): TIntList; var i: Integer; ID: Integer; begin Result := TIntList.Create; try for i := 0 to aList.Count - 1 do begin ID := TF_CAD(aList[i]).FCADListID; Result.Add(ID); end; except on E: Exception do AddExceptionToLogEx('U_Common.CadsToIntCads', E.Message); end; end; function IntCadsToCads(aIntList: TIntList): TList; var i: Integer; ID: Integer; Cad: TF_CAD; begin Result := TList.Create; try for i := 0 to aIntList.Count - 1 do begin ID := aIntList[i]; Cad := GetListByID(ID); Result.Add(Cad); end; except on E: Exception do AddExceptionToLogEx('U_Common.IntCadsToCads', E.Message); end; end; function FiguresToIntFigures(aList: TList): TIntList; var i: Integer; ID: Integer; begin Result := TIntList.Create; try for i := 0 to aList.Count - 1 do begin ID := TFigure(aList[i]).ID; Result.Add(ID); end; except on E: Exception do AddExceptionToLogEx('U_Common.FiguresToIntFigures', E.Message); end; end; function IntFiguresToFigures(aIntList: TIntList): TList; var i: Integer; ID: Integer; Figure: TFigure; begin Result := TList.Create; try for i := 0 to aIntList.Count - 1 do begin ID := aIntList[i]; Figure := GetFigureByID(GCadForm, ID); Result.Add(Figure); end; except on E: Exception do AddExceptionToLogEx('U_Common.IntFiguresToFigures', E.Message); end; end; function CheckExistBetweenFloorOnList(aCad: TF_CAD): Boolean; var i: integer; figure: Tfigure; begin Result := False; try for i := 0 to aCad.PCad.FigureCount - 1 do begin figure := TFigure(aCad.PCad.Figures[i]); if CheckFigureByClassName(figure, cTConnectorObject) then if (TConnectorObject(figure).FConnRaiseType = crt_BetweenFloorUp) or (TConnectorObject(figure).FConnRaiseType = crt_BetweenFloorDown) or (TConnectorObject(figure).FConnRaiseType = crt_TrunkUp) or (TConnectorObject(figure).FConnRaiseType = crt_TrunkDown) then begin Result := True; Break; end; end; except on E: Exception do AddExceptionToLogEx('U_Common.CheckExistBetweenFloorOnList', E.Message); end; end; function CheckTTextExistForDXF(aBlock: TBlock): Boolean; var i: integer; InFigure: TFigure; begin Result := false; try for i := 0 to aBlock.InFigures.Count - 1 do begin InFigure := TFigure(aBlock.InFigures[i]); if InFigure.ClassName = 'TText' then begin Result := true; break; end; end; except on E: Exception do AddExceptionToLogEx('U_Common.CheckTTextExistForDXF', E.Message); end; end; procedure ConvertBMPToJpeg(aBmp: TBitmap; aFileName: string); var Jpeg: TJPEGImage; begin try Jpeg := TJpegImage.Create; Jpeg.Assign(aBmp); JPeg.SaveToFile(ChangeFileExt(aFileName, '.jpg')); FreeAndNil(Jpeg); except on E: Exception do AddExceptionToLogEx('U_Common.ConvertBMPToJpeg', E.Message); end; end; //Tolik 25/08/2021 - старая закомменчена - см ниже. procedure SaveSubstrateArchPlan(aFileName: string); var Bmp: TBitmap; Jpeg: TJPEGImage; ExtStr: string; BmpFileName: string; // Tolik 04/11/2019 -- OldMapScale: Integer; OldPCadMapScale: Double; InFileName: String; GExportUSeScaleFlag: Boolean; ScaleVal: Integer; // Tolik 06/11/2019 -- // Проверить, влезет ли хотя бы в 24 бита при текущем формате листа // если нет -- плясать от 400% до 100% по зуму (а вдруг) Procedure CheckCurrentScale(var aVal: Integer); var form: TForm; //PictW, PictH, PictureSize: Integer; PictW, PictH, PictureSize: Extended; pr_Dpm, prDpm_ : Extended; begin pr_Dpm := GCadForm.PCad.DotsPerMilOrig; Form := GCadForm.PCad.GetForm; if Form <> nil then pr_Dpm := Form.PixelsPerInch / 25.4; prDpm_ := pr_Dpm * 4; aVal := 400; while aVal > 100 do begin PictW := Round((GCadForm.PCad.WorkWidth) * prDpm_); PictH := Round((GCadForm.PCad.WorkHeight) * prDpm_); PictureSize := PictW*PictH; PictureSize := PictureSize * 3; // 24 bit if PictureSize > 200000000 then begin aVal := aVal - 100; prDpm_ := pr_Dpm * aVal / 100; end else break; end; end; // begin try OldMapScale := 0; // Tolik 04/11/2019 -- OldPCadMapScale := 1; inFileName := ExtractFileName(aFileName); ExtStr := ExtractFileExt(aFileName); if ExtStr = '.bmp' then begin GCadForm.PCad.SaveSubstrateAsBitmap(aFileName); end else if (ExtStr = '.jpg') then begin BmpFileName := ChangeFileExt(aFileName, '.bmp'); if inFileName = '3d.jpg' then begin OldMapScale := GCadForm.PCad.ZoomScale; OldPCadMapScale := GCadForm.PCad.MapScale; //Tolik 19/07/2021 -- пока нет решения - будет 200%. Проблема в потере надписей мелким шрифтом на подложке для // 3Д... раньше ставили 400%, но на Win XP, видно, не хватает памяти (или если видяхи нет) // тогда на 3Д вместо подложки будет черно-серо-бело-непонятний лист..... //CheckCurrentScale(ScaleVal); ScaleVal := 200; // //GCadForm.PCad.MapScale := ScaleVal; //GCadForm.PCad.MapScale := 400; GExportUSeScaleFlag := GExportUSeScale; GExportUSeScale := True; //GCadForm.SetZoomScale(400); GCadForm.SetZoomScale(ScaleVal); GCadForm.PCad.Refresh; end; GCadForm.PCad.SaveSubstrateAsBitmap(BmpFileName); Bmp := TBitmap.Create; Bmp.LoadFromFile(BmpFileName); Bmp.SaveToFile(aFileName); ConvertBMPToJpeg(Bmp, aFileName); FreeAndNil(Bmp); DeleteFile(BmpFileName); if OldMapScale > 0 then begin //GCadForm.PCad.MapsCale := OldPCadMapScale; GCadForm.SetZoomScale(OldMapScale); GExportUSeScale := GExportUSeScaleFlag; end; end; except on E: Exception do AddExceptionToLogEx('U_Common.GetSubstrateArchPlanBitmap', E.Message); end; end; (* procedure SaveSubstrateArchPlan(aFileName: string); var Bmp: TBitmap; Jpeg: TJPEGImage; ExtStr: string; BmpFileName: string; // Tolik 04/11/2019 -- OldMapScale: Integer; OldPCadMapScale: Double; InFileName: String; GExportUSeScaleFlag: Boolean; ScaleVal: Integer; // Tolik 06/11/2019 -- // Проверить, влезет ли хотя бы в 24 бита при текущем формате листа // если нет -- плясать от 400% до 100% по зуму (а вдруг) Procedure CheckCurrentScale(var aVal: Integer); var form: TForm; //PictW, PictH, PictureSize: Integer; PictW, PictH, PictureSize: Extended; pr_Dpm, prDpm_ : Extended; begin pr_Dpm := GCadForm.PCad.DotsPerMilOrig; Form := GCadForm.PCad.GetForm; if Form <> nil then pr_Dpm := Form.PixelsPerInch / 25.4; prDpm_ := pr_Dpm * 4; aVal := 400; while aVal > 100 do begin PictW := Round((GCadForm.PCad.WorkWidth) * prDpm_); PictH := Round((GCadForm.PCad.WorkHeight) * prDpm_); PictureSize := PictW*PictH; PictureSize := PictureSize * 3; // 24 bit if PictureSize > 200000000 then begin aVal := aVal - 100; prDpm_ := pr_Dpm * aVal / 100; end else break; end; end; // begin try OldMapScale := 0; // Tolik 04/11/2019 -- OldPCadMapScale := 1; inFileName := ExtractFileName(aFileName); ExtStr := ExtractFileExt(aFileName); if ExtStr = '.bmp' then begin GCadForm.PCad.SaveSubstrateAsBitmap(aFileName); end else if (ExtStr = '.jpg') then begin BmpFileName := ChangeFileExt(aFileName, '.bmp'); if inFileName = '3d.jpg' then begin OldMapScale := GCadForm.PCad.ZoomScale; OldPCadMapScale := GCadForm.PCad.MapScale; //Tolik 19/07/2021 -- пока нет решения - будет 200%. Проблема в потере надписей мелким шрифтом на подложке для // 3Д... раньше ставили 400%, но на Win XP, видно, не хватает памяти (или если видяхи нет) // тогда на 3Д вместо подложки будет черно-серо-бело-непонятний лист..... //CheckCurrentScale(ScaleVal); ScaleVal := 200; // GCadForm.PCad.MapScale := ScaleVal; //GCadForm.PCad.MapScale := 400; GExportUSeScaleFlag := GExportUSeScale; GExportUSeScale := True; //GCadForm.SetZoomScale(400); GCadForm.SetZoomScale(ScaleVal); GCadForm.PCad.Refresh; end; GCadForm.PCad.SaveSubstrateAsBitmap(BmpFileName); Bmp := TBitmap.Create; Bmp.LoadFromFile(BmpFileName); Bmp.SaveToFile(aFileName); ConvertBMPToJpeg(Bmp, aFileName); FreeAndNil(Bmp); DeleteFile(BmpFileName); if OldMapScale > 0 then begin GCadForm.PCad.MapsCale := OldPCadMapScale; GCadForm.SetZoomScale(OldMapScale); GExportUSeScale := GExportUSeScaleFlag; end; end; except on E: Exception do AddExceptionToLogEx('U_Common.GetSubstrateArchPlanBitmap', E.Message); end; end; *) procedure DeleteHouseOnCAD(aListID, AObjectID: Integer); var vHouse: THouse; vList: TF_CAD; vFigure: TFigure; begin try // Нельзя здесь - иначе на КАДе на том что нужно удалится, а вот с ПМ - не с того // такая проверка - в procedure TF_MAIN.DelCompon(AComponent: TSCSComponent; ANode: TTreeNode; //if aListID <> GCadForm.FCADListID then // aListID := GCadForm.FCADListID; // а что бы исключить зависание КАДа лучше наверное так сделаем: if aListID <> GCadForm.FCADListID then exit; vList := GetListByID(aListID); if (vList <> nil) then begin vFigure := GetHouseByID(vList, AObjectID); if vFigure <> nil then begin if CheckFigureByClassName(vFigure, cTHouse) then begin THouse(vFigure).Delete; RefreshCAD(vList.PCad); end; end; end; except on E: Exception do addExceptionToLogEx('U_Common.DeleteHouseOnCAD', E.Message); end; end; procedure DeleteApproachOnCAD(aListID, aHouseID, AComponID: Integer); var vList: TF_CAD; House: THouse; Approach: TConnectorObject; begin try if aListID <> GCadForm.FCADListID then exit; vList := GetListByID(aListID); if vList <> nil then begin Approach := GetApproachByComponID(vList, AComponID); if Approach <> nil then begin Approach.Delete(False, False); RefreshCAD(vList.PCad); end; end; except on E: Exception do AddExceptionToLogEx('U_Common.DeleteApproachOnCAD', E.Message); end; end; procedure SnapConnectorToHouse(aConnector: TConnectorObject; aSnapHouse: THouse); var i: Integer; pt: TDoublePoint; SegIndex: Integer; begin try pt := aConnector.ActualPoints[1]; SegIndex := -1; For i := 1 to aSnapHouse.PointCount do begin if aSnapHouse.IsPointInSegment(i, pt.x, pt.y) then begin SegIndex := i; break; end; end; if SegIndex = - 1 then exit; aSnapHouse.InsertKnot(SegIndex, pt); aConnector.FIsHouseJoined := True; aConnector.FHouse := aSnapHouse; aSnapHouse.fJoined.Add(aConnector); except on E: Exception do AddExceptionToLogEx('U_Common.SnapConnectorToHouse', E.Message); end; end; function GetIDElementFromComplexObjByTrace(AID_List, AIDComplexFigure, AIDTrace: Integer): Integer; var vHouse: THouse; vLine: TOrthoLine; Join1, Join2: TConnectorObject; vList: TF_CAD; begin Result := -1; try //на выходе: //ID элемента комплексного объекта(подъезда), или //0 - трасса подключена к комплексному объекту(тоесть дому) //-1 - трасса ни чем не связана с домом vList := GetListByID(AID_List); if vList = nil then exit; vHouse := GetHouseByID(vList, AIDComplexFigure); vLine := TOrthoLine(GetFigureByID(vList, AIDTrace)); if (vHouse = nil) or (vLine = nil) then exit; Join1 := TConnectorObject(vLine.JoinConnector1); Join2 := TConnectorObject(vLine.JoinConnector2); if Join1.FIsHouseJoined then if Join1.FHouse <> nil then if Join1.FHouse = vHouse then begin Result := 0; exit; end; if Join2.FIsHouseJoined then if Join2.FHouse <> nil then if Join2.FHouse = vHouse then begin Result := 0; exit; end; if Join1.JoinedConnectorsList.Count > 0 then if TConnectorObject(Join1.JoinedConnectorsList[0]).FIsApproach then if TConnectorObject(Join1.JoinedConnectorsList[0]).FHouse = vHouse then Result := TConnectorObject(Join1.JoinedConnectorsList[0]).FComponID; if Join2.JoinedConnectorsList.Count > 0 then if TConnectorObject(Join2.JoinedConnectorsList[0]).FIsApproach then if TConnectorObject(Join2.JoinedConnectorsList[0]).FHouse = vHouse then Result := TConnectorObject(Join2.JoinedConnectorsList[0]).FComponID; except on E: Exception do AddExceptionToLogEx('U_Common.GetIDElementFromComplexObjByTrace', E.Message); end; end; function GetConnectedTracesToConnetorByID(AIDList, AIDConnectorFigure: Integer): TIntList; var CADList: TF_CAD; vFigure: TFigure; ConnectorFigure: TConnectorObject; JoinedConnector: TConnectorObject; Approach: TConnectorObject; House: THouse; i, j, k: Integer; begin Result := TIntList.Create; ConnectorFigure := nil; CADList := GetListByID(AIDList); if CADList <> nil then begin vFigure := GetFigureByID(CADList, AIDConnectorFigure); if vFigure = nil then vFigure := GetHouseByID(CADList, AIDConnectorFigure); if vFigure <> nil then begin // CONNECTOR if CheckFigureByClassName(vFigure, cTConnectorObject) then begin ConnectorFigure := TConnectorObject(vFigure); // трассы присоединены напрямую if ConnectorFigure.JoinedConnectorsList.Count = 0 then begin for i := 0 to ConnectorFigure.JoinedOrtholinesList.Count - 1 do Result.Add(TOrthoLine(ConnectorFigure.JoinedOrtholinesList[i]).ID); end else // Через точ. объекты for i := 0 to ConnectorFigure.JoinedConnectorsList.Count - 1 do begin JoinedConnector := TConnectorObject(ConnectorFigure.JoinedConnectorsList[i]); for j := 0 to JoinedConnector.JoinedOrtholinesList.Count - 1 do Result.Add(TOrthoLine(JoinedConnector.JoinedOrtholinesList[j]).ID); end; end // HOUSE else if CheckFigureByClassName(vFigure, cTHouse) then begin House := THouse(vFigure); // перебрать связующие коннекторы for i := 0 to House.fJoined.Count - 1 do begin JoinedConnector := TConnectorObject(House.fJoined[i]); for j := 0 to JoinedConnector.JoinedOrtholinesList.Count - 1 do Result.Add(TOrthoLine(JoinedConnector.JoinedOrtholinesList[j]).ID); end; // перебрать подъезды for i := 0 to House.fApproaches.Count - 1 do begin Approach := TConnectorObject(House.fApproaches[i]); for j := 0 to Approach.JoinedConnectorsList.Count - 1 do begin JoinedConnector := TConnectorObject(Approach.JoinedConnectorsList[j]); for k := 0 to JoinedConnector.JoinedOrtholinesList.Count - 1 do Result.Add(TOrthoLine(JoinedConnector.JoinedOrtholinesList[k]).ID); end; end; end; end; end; end; function GetConnectedFigures(AFigure: TFigure; AClearConnToRes: Boolean=false; ASkipList: TList=nil): TList; //#From Oleg# //15.09.2010 var i, j: Integer; JoinedConnObject: TConnectorObject; //ListOfPassage: TF_CAD; //ConnOfPassage: TConnectorObject; //ConnectedObjectsFromBetweenFloorConnector: TRapList; JoinedLine: TOrtholine; JoinedConnector: TConnectorObject; FigureToResult: TFigure; procedure AddFigureToResult(AFigureToRes: TFigure); begin if (ASkipList = nil) or (ASkipList.IndexOf(AFigureToRes) = -1) then Result.Add(AFigureToRes); end; //*** Вернет подключенные объекты (на другом листе) к соединителю, что подключен к ь-э переходу function GetConnectedObjectsFromBetweenFloorConnector(AConnObject: TConnectorObject): TRapList; var IndexFigure: Integer; ConnectedFigures: TRapList; ListOfPassage: TF_CAD; ConnOfPassage: TConnectorObject; i: Integer; begin Result := nil; ListOfPassage := GetListOfPassage(AConnObject.FID_ListToPassage); if ListOfPassage <> nil then begin ConnOfPassage := TConnectorObject(GetFigureByID(ListOfPassage, AConnObject.FID_ConnToPassage)); if ConnOfPassage <> nil then begin ConnectedFigures := TRapList.Create; for i := 0 to ConnOfPassage.JoinedOrtholinesList.Count - 1 do ConnectedFigures.Add(TOrthoLine(ConnOfPassage.JoinedOrtholinesList.List^[i])); Result := ConnectedFigures; end; end; end; procedure GetObjectsFromOrtholineConnector(AConnector: TConnectorObject); var ConnRaiseType: TConnRaiseType; //ConnObject: TConnectorObject; FigureToResult: TFigure; i: integer; ConnectedObjectsFromBetweenFloorConnector: TRapList; begin if AClearConnToRes then begin if AConnector.JoinedConnectorsList.Count = 0 then AddFigureToResult(AConnector) else for i := 0 to AConnector.JoinedConnectorsList.Count - 1 do begin FigureToResult := TConnectorObject(AConnector.JoinedConnectorsList.List^[i]); AddFigureToResult(FigureToResult); //Result.Add(FigureToResult); end; end else begin ConnRaiseType := AConnector.FConnRaiseType; if (ConnRaiseType = crt_BetweenFloorUp) or (ConnRaiseType = crt_BetweenFloorDown) then begin ConnectedObjectsFromBetweenFloorConnector := GetConnectedObjectsFromBetweenFloorConnector(AConnector); if ConnectedObjectsFromBetweenFloorConnector <> nil then begin for i := 0 to ConnectedObjectsFromBetweenFloorConnector.Count - 1 do begin FigureToResult := TFigure(ConnectedObjectsFromBetweenFloorConnector.List^[i]); if FigureToResult is TOrtholine then AddFigureToResult(FigureToResult);//Result.Add(FigureToResult); end; ConnectedObjectsFromBetweenFloorConnector.Free; end; end else begin for i := 0 to AConnector.JoinedOrtholinesList.Count - 1 do begin JoinedLine := TOrthoLine(AConnector.JoinedOrtholinesList.List^[i]); if JoinedLine <> TOrthoLine(AFigure) then AddFigureToResult(JoinedLine); //Result.Add(JoinedLine); end; for i := 0 to AConnector.JoinedConnectorsList.Count - 1 do begin FigureToResult := TConnectorObject(AConnector.JoinedConnectorsList.List^[i]); AddFigureToResult(FigureToResult); //Result.Add(FigureToResult); end; end; end; end; begin Result := TList.Create; if AFigure is TConnectorObject then begin if TConnectorObject(AFigure).ConnectorType = ct_Clear then begin for i := 0 to TConnectorObject(AFigure).JoinedOrtholinesList.Count - 1 do begin FigureToResult := TOrthoLine(TConnectorObject(AFigure).JoinedOrtholinesList.List^[i]); AddFigureToResult(FigureToResult);//Result.Add(FigureToResult); end; end else for i := 0 to TConnectorObject(AFigure).JoinedConnectorsList.Count - 1 do begin JoinedConnObject := TConnectorObject(TConnectorObject(AFigure).JoinedConnectorsList.List^[i]); for j := 0 to JoinedConnObject.JoinedOrtholinesList.Count - 1 do begin FigureToResult := TOrthoLine(JoinedConnObject.JoinedOrtholinesList.List^[j]); AddFigureToResult(FigureToResult); //Result.Add(FigureToResult); end; end; end else if AFigure is TOrthoLine then begin // Сторона 1 //ConnObject := TConnectorObject(TOrthoLine(AFigure).JoinConnector1); //ConnRaiseType := ConnObject.FConnRaiseType; //if (ConnRaiseType = crt_BetweenFloorUp) or (ConnRaiseType = crt_BetweenFloorDown) then //begin // ConnectedObjectsFromBetweenFloorConnector := GetConnectedObjectsFromBetweenFloorConnector(ConnObject); // if ConnectedObjectsFromBetweenFloorConnector <> nil then // for i := 0 to ConnectedObjectsFromBetweenFloorConnector.Count - 1 do // begin // FigureToResult := TFigure(ConnectedObjectsFromBetweenFloorConnector.List^[i]); // if FigureToResult is TOrtholine then // Result.Add(FigureToResult); // end; //end //else //begin // for i := 0 to ConnObject.JoinedOrtholinesList.Count - 1 do // begin // JoinedLine := TOrthoLine(ConnObject.JoinedOrtholinesList.List^[i]); // if JoinedLine <> TOrthoLine(AFigure) then // Result.Add(JoinedLine); // end; // for i := 0 to ConnObject.JoinedConnectorsList.Count - 1 do // begin // FigureToResult := TConnectorObject(ConnObject.JoinedConnectorsList.List^[i]); // Result.Add(FigureToResult); // end; //end; // Сторона 2 //ConnObject := TConnectorObject(TOrthoLine(AFigure).JoinConnector2); //ConnRaiseType := ConnObject.FConnRaiseType; //if (ConnRaiseType = crt_BetweenFloorUp) or (ConnRaiseType = crt_BetweenFloorDown) then //begin // ConnectedObjectsFromBetweenFloorConnector := GetConnectedObjectsFromBetweenFloorConnector(ConnObject); // if ConnectedObjectsFromBetweenFloorConnector <> nil then // for i := 0 to ConnectedObjectsFromBetweenFloorConnector.Count - 1 do // begin // FigureToResult := TFigure(ConnectedObjectsFromBetweenFloorConnector.List^[i]); // if FigureToResult is TOrtholine then // Result.Add(FigureToResult); // end; //end //else //begin // for i := 0 to ConnObject.JoinedOrtholinesList.Count - 1 do // begin // JoinedLine := TOrthoLine(ConnObject.JoinedOrtholinesList.List^[i]); // if JoinedLine <> TOrthoLine(AFigure) then // Result.Add(JoinedLine); // end; // for i := 0 to ConnObject.JoinedConnectorsList.Count - 1 do // begin // FigureToResult := TConnectorObject(ConnObject.JoinedConnectorsList.List^[i]); // Result.Add(FigureToResult); // end; //end; GetObjectsFromOrtholineConnector(TConnectorObject(TOrthoLine(AFigure).JoinConnector1)); GetObjectsFromOrtholineConnector(TConnectorObject(TOrthoLine(AFigure).JoinConnector2)); end; end; function GetConnectorsOtherSides(aConnector: TConnectorObject): TList; var JoinedLine: TOrtholine; RaiseConn: TConnectorObject; i, j: Integer; // Tolik 30/03/2018 -- ConnLineByVLines: TList; JoinedConn, LineConn: TConnectorObject; CanAddVLine: Boolean; JoinedLinesList, LineList: TList; vLineFound: Boolean; ResultList: TList; Procedure GetConnectorsOtherSidesByVertLines(aConn: TConnectorObject); var i,j: Integer; LineConn, NextConn: TConnectorObject; begin vLineFound := False; NextConn := Nil; if aConn.ConnectorType = ct_Clear then begin for i := 0 to aConn.JoinedOrthoLinesList.Count - 1 do begin JoinedLine := TOrthoLine(aConn.JoinedOrthoLinesList[i]); if JoinedLine.FIsVertical then begin if not vLineFound then begin if LineList.IndexOf(JoinedLine) = -1 then begin vLineFound := true; LineList.Add(JoinedLine); if JoinedLine.JoinConnector1.ID = aConn.ID then NextConn := TConnectorObject(JoinedLine.JoinConnector2) else if JoinedLine.JoinConnector2.ID = aConn.ID then NextConn := TConnectorObject(JoinedLine.JoinConnector1); if NextConn <> nil then if NextConn.JoinedConnectorsList.Count > 0 then NextConn := TConnectorObject(NextConn.JoinedConnectorsList[0]); end; end; end else begin if not JoinedLine.FIsRaiseUpDown then if JoinedLinesList.IndexOf(JoinedLine) = -1 then begin if TConnectorObject(JoinedLine.JoinConnector1).ID <> aConn.ID then begin if ResultList.IndexOf(TConnectorObject(JoinedLine.JoinConnector1)) = -1 then ResultList.Add(TConnectorObject(JoinedLine.JoinConnector1)); end else if TConnectorObject(JoinedLine.JoinConnector2).ID <> aConn.ID then begin if ResultList.IndexOf(TConnectorObject(JoinedLine.JoinConnector2)) = -1 then ResultList.Add(TConnectorObject(JoinedLine.JoinConnector2)); end; if aConnector.FJoinedOrthoLinesByVerticals.IndexOf(JoinedLine) = -1 then aConnector.FJoinedOrthoLinesByVerticals.Add(JoinedLine); LineConn := TConnectorObject(JoinedLine.JoinConnector1); if LineConn.Id = AConn.Id then LineConn := TConnectorObject(JoinedLine.JoinConnector2); if LineConn.JoinedConnectorsList.count > 0 then LineConn := TConnectorObject(LineConn.JoinedConnectorsList[0]); if ResultList.IndexOf(LineConn) = -1 then ResultList.Add(LineConn); end; end; end; end else begin for i := 0 to aConn.JoinedConnectorsList.Count - 1 do begin JoinedConn := TConnectorObject(aConn.JoinedConnectorsList[i]); for j := 0 to JoinedConn.JoinedOrtholinesList.Count - 1 do begin JoinedLine := TOrthoLine(JoinedConn.JoinedOrtholinesList[j]); if JoinedLine.FIsVertical then begin if not VLineFound then begin if LineList.IndexOf(JoinedLine) = -1 then begin vLineFound := true; LineList.Add(JoinedLine); if JoinedLine.JoinConnector1.ID = JoinedConn.ID then NextConn := TConnectorObject(JoinedLine.JoinConnector2) else if JoinedLine.JoinConnector2.ID = JoinedConn.ID then NextConn := TConnectorObject(JoinedLine.JoinConnector1); if NextConn <> nil then if NextConn.JoinedConnectorsList.Count > 0 then NextConn := TConnectorObject(NextConn.JoinedConnectorsList[0]); end; end; end else begin if not JoinedLine.FIsRaiseUpDown then begin if JoinedLinesList.IndexOf(JoinedLine) = -1 then begin if aConnector.FJoinedOrthoLinesByVerticals.IndexOf(JoinedLine) = -1 then aConnector.FJoinedOrthoLinesByVerticals.Add(JoinedLine); if JoinedLine.JoinConnector1.ID = JoinedConn.Id then LineConn := TConnectorObject(JoinedLine.JoinConnector2) else if JoinedLine.JoinConnector2.ID = JoinedConn.Id then LineConn := TConnectorObject(JoinedLine.JoinConnector1); if LineConn.JoinedConnectorsList.Count > 0 then LineConn := TConnectorObject(LineConn.JoinedConnectorsList[0]); if ResultList.IndexOf(LineConn) = -1 then ResultList.Add(LineConn); end; end; end; end; end; end; if NextConn <> nil then begin GetConnectorsOtherSidesByVertLines(NextConn); end; end; begin //Result := TList.Create; ResultList := TList.Create; if aConnector.FJoinedOrthoLinesByVerticals = nil then aConnector.FJoinedOrthoLinesByVerticals := TList.Create else aConnector.FJoinedOrthoLinesByVerticals.Clear; if AConnector.FModConnsOtherSides <> nil then FreeAndNil(AConnector.FModConnsOtherSides); JoinedLinesList := TList.Create; if aConnector.ConnectorType = ct_Clear then begin for i := 0 to AConnector.JoinedOrtholinesList.Count - 1 do begin JoinedLine := TOrthoLine(AConnector.JoinedOrtholinesList[i]); if not JoinedLine.FisVertical then if not JoinedLine.FisRaiseUpDown then begin if aConnector.FJoinedOrthoLinesByVerticals.IndexOf(JoinedLine) = -1 then aConnector.FJoinedOrthoLinesByVerticals.Add(JoinedLine); LineConn := TConnectorObject(JoinedLine.JoinConnector1); if LineConn.ID = AConnector.ID then LineConn := TConnectorObject(JoinedLine.JoinConnector2); if LineConn.JoinedConnectorsList.Count > 0 then LineConn := TConnectorObject(LineConn.JoinedconnectorsList[0]); if ResultList.IndexOf(LineConn) = -1 then ResultList.Add(LineConn); end; JoinedLinesList.Add(JoinedLine); end; end else if aConnector.ConnectorType = ct_NB then begin for i := 0 to AConnector.JoinedConnectorsList.Count - 1 do begin JoinedConn := TConnectorObject(AConnector.JoinedConnectorsList[i]); for j := 0 to JoinedConn.JoinedOrthoLinesList.Count - 1 do begin JoinedLine := TOrthoLine(JoinedConn.JoinedOrthoLinesList[j]); if not JoinedLine.FisVertical then if not JoinedLine.FisRaiseUpDown then begin if aConnector.FJoinedOrthoLinesByVerticals.IndexOf(JoinedLine) = -1 then aConnector.FJoinedOrthoLinesByVerticals.Add(JoinedLine); LineConn := TConnectorObject(JoinedLine.JoinConnector1); if LineConn.ID = JoinedConn.ID then LineConn := TConnectorObject(JoinedLine.JoinConnector2); if LineConn.JoinedConnectorsList.Count > 0 then LineConn := TConnectorObject(LineConn.JoinedconnectorsList[0]); if ResultList.IndexOf(LineConn) = -1 then ResultList.Add(LineConn); end; JoinedLinesList.Add(JoinedLine); end; end; end; // трассы через с-п RaiseConn := GetRaiseConn(aConnector); if RaiseConn <> nil then begin for i := 0 to RaiseConn.JoinedOrtholinesList.Count - 1 do begin JoinedLine := TOrthoLine(RaiseConn.JoinedOrtholinesList[i]); if not JoinedLine.FIsRaiseUpDown then begin if JoinedLine.JoinConnector1 <> RaiseConn then if ResultList.IndexOf(JoinedLine.JoinConnector1) = -1 then //Result.Add(JoinedLine.JoinConnector1); ResultList.Add(JoinedLine.JoinConnector1); if JoinedLine.JoinConnector2 <> RaiseConn then if ResultList.IndexOf(JoinedLine.JoinConnector2) = -1 then //Result.Add(JoinedLine.JoinConnector2); ResultList.Add(JoinedLine.JoinConnector2); end; end; end; //Tolik -- 30/03/2018 -- трассы через коннекторы вертикальных соединений LineList := TList.Create; GetConnectorsOtherSidesByVertLines(aConnector); GetConnectorsOtherSidesByVertLines(aConnector); LineList.Free; JoinedLinesList.free; // Result := ResultList; end; function GetEndPointByHouse(aHouse: THouse; aCurrentWA: TConnectorObject): TConnectorObject; var i, j: Integer; Joined: TConnectorObject; AllTrace: TList; begin Result := nil; try for i := 0 to aHouse.fJoined.Count - 1 do begin Joined := TConnectorObject(aHouse.fJoined[i]); AllTrace := GetAllTraceInCAD(Joined, aCurrentWA); if (AllTrace <> nil) and (AllTrace.Count > 0) then begin // Tolik -- 07/02/2017 -- FreeAndNil(AllTrace); // Result := Joined; exit; end; // Tolik -- 07/02/2017 -- if (AllTrace <> nil) then FreeAndNil(AllTrace); // end; except on E: Exception do AddExceptionToLogEx('U_Common.GetEndPointByHouse', E.Message); end; end; procedure SetLineStatusInfo(aLineParams: PLineFigureParams); var i: integer; vList: TF_CAD; vFigure: TOrthoLine; begin try vList := GetListByID(aLineParams.ListID); if vList <> nil then begin vFigure := TOrthoLine(GetFigureByID(vList, aLineParams.FigureID)); if vFigure = nil then vFigure := TOrthoLine(GetFigureByIDInSCSFigureGroups(vList, aLineParams.FigureID)); if vFigure <> nil then begin vFigure.FCableFullnessSide1 := aLineParams.FullnesCableSide1; vFigure.FCableFullnessSide2 := aLineParams.FullnesCableSide2; vFigure.FCableChannelFullness := aLineParams.ChannelFullness; vFigure.FCableChannelClosedSide1 := aLineParams.ClosedTypeForChannelSide1; vFigure.FCableChannelClosedSide2 := aLineParams.ClosedTypeForChannelSide1; vFigure.FDefectDegree := aLineParams.DefectObjDegree; end; end; except on E: Exception do AddExceptionToLogEx('U_Common.SetLineStatusInfo', E.Message); end; end; procedure SetConnStatusInfo(aConnParams: PConnFigureParams); var i: integer; vList: TF_CAD; vFigure: TConnectorObject; begin try vList := GetListByID(aConnParams.ListID); if vList <> nil then begin vFigure := TConnectorObject(GetFigureByID(vList, aConnParams.FigureID)); if vFigure = nil then vFigure := TConnectorObject(GetFigureByIDInSCSFigureGroups(vList, aConnParams.FigureID)); if vFigure <> nil then begin vFigure.FConnFullness := aConnParams.Fullness; vFigure.FDefectDegree := aConnParams.DefectObjDegree; end; end; except on E: Exception do AddExceptionToLogEx('U_Common.SetConnStatusInfo', E.Message); end; end; procedure LoadSubWithMaster(aFName: string); var Jpeg: TJpegImage; Bmp: TBMPObject; begin try aFName := AnsiLowerCaseFileName(aFName); // подложка if pos('.scb', aFName) <> 0 then begin FSCS_Main.LoadSubstrate(aFName); end else // арх. план if pos('.sca', aFName) <> 0 then begin FSCS_Main.LoadFPlan(aFName); end else // BMP if pos('.bmp', aFName) <> 0 then begin GCadForm.PCad.InsertBitmap(1, 0, 0, aFName, false, false); end else // JPG & JPEG if (pos('.jpg', aFName) <> 0) or (pos('.jpeg', aFName) <> 0) then begin //Tolik 09/08/2019 -- GCadForm.PCad.InsertBitmap(1, 0, 0, aFName, false, false); {Bmp := TBMPObject(GCadForm.PCad.InsertBitmap(1, 0, 0, aFName, false, false)); Jpeg := TJpegImage.create; Jpeg.LoadFromFile(aFName); Bmp.Picture.Width := Jpeg.Width; Bmp.Picture.Height := Jpeg.Height; Bmp.Picture.Canvas.Draw(0, 0, Jpeg); //Bmp.Picture.PixelFormat := pf24bit; FreeAndNil(Jpeg);} // end // один из векторых чертежей else begin LoadDXFFileWithName(GCadForm.PCad, aFName); end; GCadForm.PCad.DeselectAll(0); except on E: Exception do AddExceptionToLogEx('U_Common.LoadSubWithMaster', E.Message); end; end; // Tolik 27/03/2018 -- //procedure CreateVerticalOnConnector(aConnector: TConnectorObject; aHeight: Double); Function CreateVerticalOnConnector(aConnector: TConnectorObject; aHeight: Double): TOrthoLine; // var ConnectedConn: TConnectorObject; VertConn: TConnectorObject; VertLine: TOrthoLine; x, y, z: double; i: integer; JoinedLine: TOrthoLine; JoinedConn: TConnectorObject; ObjParams: TObjectParams; begin //Tolik 27/03/2018 -- Result := Nil; // BaseBeginUpdate; try x := AConnector.ActualPoints[1].x; y := AConnector.ActualPoints[1].y; z := AConnector.ActualZOrder[1]; // создать подъем-спуск коннектор VertConn := TConnectorObject.Create(x, y, AHeight, AConnector.LayerHandle, mydsNormal, GCadForm.PCad); VertConn.ConnectorType := ct_Clear; // создать вертикаль линия VertLine := TOrthoLine.Create(x, y, AHeight, x, y, z, 1,ord(psSolid), clBlack, 0, AConnector.LayerHandle, mydsNormal, GCadForm.PCad, False); VertLine.SetJConnector1(TConnectorObject(AConnector)); VertLine.SetJConnector2(TConnectorObject(VertConn)); VertLine.ActualZOrder[1] := AConnector.ActualZOrder[1]; VertLine.ActualZOrder[2] := VertConn.ActualZOrder[1]; SetLineFigureCoordZInPM(VertLine.ID, 1, VertLine.ActualZOrder[1]); SetLineFigureCoordZInPM(VertLine.ID, 2, VertLine.ActualZOrder[2]); // СОЗДАТЬ НА КАД =========================================== GCadForm.PCad.AddCustomFigure (GLN(AConnector.LayerHandle), VertConn, False); VertConn.Name := cCadClasses_Mes12; SetNewObjectNameInPM(VertConn.ID, VertConn.Name); ObjParams := GetFigureParams(VertConn.ID); VertConn.Name := ObjParams.Name; VertConn.FIndex := ObjParams.MarkID; GCadForm.PCad.AddCustomFigure (GLN(AConnector.LayerHandle), VertLine, False); VertLine.Name := cCadClasses_Mes32; SetNewObjectNameInPM(VertLine.ID, VertLine.Name); ObjParams := GetFigureParams(VertLine.ID); VertLine.Name := ObjParams.Name; VertLine.FIndex := ObjParams.MarkID; VertLine.FIsVertical := True; VertLine.CalculLength := VertLine.LengthCalc; VertLine.LineLength := VertLine.CalculLength; SetLineFigureLengthInPM(VertLine.ID, VertLine.LineLength); VertLine.ReCreateCaptionsGroup(True, false); VertLine.UpdateLengthTextBox(True, false); VertLine.ReCreateNotesGroup(True); VertLine.ShowCaptions := False; VertLine.ShowNotes := False; VertLine.IsShowBlock := False; // *** for i := 0 to VertConn.JoinedOrtholinesList.Count - 1 do begin JoinedLine := TOrthoLine(VertConn.JoinedOrtholinesList[i]); if JoinedLine <> VertLine then begin JoinedLine.CalculLength := JoinedLine.LengthCalc; JoinedLine.LineLength := JoinedLine.CalculLength; SetLineFigureLengthInPM(JoinedLine.ID, JoinedLine.LineLength); JoinedLine.UpdateLengthTextBox(True, false); JoinedLine.ReCreateDrawFigureBlock; end; end; VertConn.LockMove := False;//True; VertConn.LockModify := True; VertLine.LockMove := False; VertLine.LockModify := True; SetConnBringToFront(AConnector); SetConnBringToFront(VertConn); Result := VertLine; // Tolik 27/03/2018 RefreshCAD(GCadForm.PCad); except on E: Exception do addExceptionToLogEx('U_Common.CreateVerticalTrace', E.Message); end; BaseEndUpdate; end; //Tolik 27/03/2018 -- Function CreateVerticalOnPointObject(aPointObject: TConnectorObject; aHeight: Double): TOrthoLine; //procedure CreateVerticalOnPointObject(aPointObject: TConnectorObject; aHeight: Double); // var ConnectedConn: TConnectorObject; VertConn: TConnectorObject; VertLine: TOrthoLine; x, y, z: double; i: integer; JoinedLine: TOrthoLine; JoinedConn: TConnectorObject; JoinedConnBase: TConnectorObject; ObjParams: TObjectParams; //TempRaisedConnectors: TList; CurIndex: Integer; begin // Tolik 27/03/2018 -- Result := Nil; // BaseBeginUpdate; try x := APointObject.ActualPoints[1].x; y := APointObject.ActualPoints[1].y; z := APointObject.ActualZOrder[1]; // создать присоединенный коннектор ConnectedConn := TConnectorObject.Create(x, y, z, APointObject.LayerHandle, mydsNormal, GCadForm.PCad); ConnectedConn.ConnectorType := ct_Clear; GCadForm.PCad.AddCustomFigure (GLN(APointObject.LayerHandle), ConnectedConn, False); ConnectedConn.Name := cCadClasses_Mes12; SetNewObjectNameInPM(ConnectedConn.ID, ConnectedConn.Name); ObjParams := GetFigureParams(ConnectedConn.ID); ConnectedConn.Name := ObjParams.Name; ConnectedConn.FIndex := ObjParams.MarkID; // создать вертикаль коннектор VertConn := TConnectorObject.Create(x + 10, y - 10, AHeight, APointObject.LayerHandle, mydsNormal, GCadForm.PCad); VertConn.ConnectorType := ct_Clear; // создать вертикаль линия VertLine := TOrthoLine.Create(x, y, z, x + 10, y - 10, AHeight, 1,ord(psSolid), clBlack, 0, APointObject.LayerHandle, mydsNormal, GCadForm.PCad, False); VertLine.SetJConnector1(TConnectorObject(ConnectedConn)); VertLine.SetJConnector2(TConnectorObject(VertConn)); VertLine.ActualZOrder[1] := ConnectedConn.ActualZOrder[1]; VertLine.ActualZOrder[2] := VertConn.ActualZOrder[1]; SetLineFigureCoordZInPM(VertLine.ID, 1, VertLine.ActualZOrder[1]); SetLineFigureCoordZInPM(VertLine.ID, 2, VertLine.ActualZOrder[2]); // приконнектить подъем SnapConnectorToPointObject(ConnectedConn, APointObject, true); ConnectedConn.MoveConnector(APointObject.ActualPoints[1].x - ConnectedConn.ActualPoints[1].x, APointObject.ActualPoints[1].y - ConnectedConn.ActualPoints[1].y, false, false); VertConn.MoveConnector(-10, 10, False); // СОЗДАТЬ НА КАД =========================================== GCadForm.PCad.AddCustomFigure (GLN(APointObject.LayerHandle), VertConn, False); VertConn.Name := cCadClasses_Mes12; SetNewObjectNameInPM(VertConn.ID, VertConn.Name); ObjParams := GetFigureParams(VertConn.ID); VertConn.Name := ObjParams.Name; VertConn.FIndex := ObjParams.MarkID; GCadForm.PCad.AddCustomFigure (GLN(APointObject.LayerHandle), VertLine, False); VertLine.Name := cCadClasses_Mes32; SetNewObjectNameInPM(VertLine.ID, VertLine.Name); ObjParams := GetFigureParams(VertLine.ID); VertLine.Name := ObjParams.Name; VertLine.FIndex := ObjParams.MarkID; VertLine.FIsVertical := True; VertConn.LockMove := False;//True; VertConn.LockModify := True; VertLine.LockMove := False; VertLine.LockModify := True; ConnectedConn.LockMove := True; ConnectedConn.LockModify := True; // Commented by Tolik 22/04/2016 -- // Переприсоединять не совсем правильно, т.к. при создании вертикали получится точечный объект внизу, // а приконнекченные к нему трассы поднимутся на вершину ... { // переподсоединить трассы к подъему TempRaisedConnectors := TList.Create; for i := 0 to APointObject.JoinedConnectorsList.Count - 1 do begin JoinedConn := TConnectorObject(APointObject.JoinedConnectorsList[i]); if JoinedConn <> ConnectedConn then TempRaisedConnectors.Add(JoinedConn); end; // отвязка for i := 0 to TempRaisedConnectors.Count - 1 do begin JoinedConn := TConnectorObject(TempRaisedConnectors[i]); UnsnapConnectorFromPointObject(JoinedConn, APointObject, true); end; // перепривязка к вершине CurIndex := TempRaisedConnectors.Count - 1; // вязать без сортировок for i := CurIndex downto 0 do begin JoinedConn := TConnectorObject(TempRaisedConnectors[i]); SnapConnectorToConnector(JoinedConn, VertConn, true); VertConn := JoinedConn; end; if TempRaisedConnectors <> nil then FreeAndNil(TempRaisedConnectors); } VertLine.CalculLength := VertLine.LengthCalc; VertLine.LineLength := VertLine.CalculLength; SetLineFigureLengthInPM(VertLine.ID, VertLine.LineLength); VertLine.ReCreateCaptionsGroup(True, false); VertLine.UpdateLengthTextBox(True, false); VertLine.ReCreateNotesGroup(True); VertLine.ShowCaptions := False; VertLine.ShowNotes := False; VertLine.IsShowBlock := False; // *** for i := 0 to VertConn.JoinedOrtholinesList.Count - 1 do begin JoinedLine := TOrthoLine(VertConn.JoinedOrtholinesList[i]); if JoinedLine <> VertLine then begin JoinedLine.CalculLength := JoinedLine.LengthCalc; JoinedLine.LineLength := JoinedLine.CalculLength; SetLineFigureLengthInPM(JoinedLine.ID, JoinedLine.LineLength); JoinedLine.UpdateLengthTextBox(True, false); JoinedLine.ReCreateDrawFigureBlock; end; end; SetConnBringToFront(APointObject); SetConnBringToFront(VertConn); RefreshCAD(GCadForm.PCad); SetNewObjectNameInPM(VertConn.ID, VertConn.Name); Result := VertLine; // Tolik 27/03/2018 -- except on E: Exception do AddExceptionToLogEx('U_Common.CreateVerticalOnPointObject', E.Message); end; BaseEndUpdate; end; // Tolik 13/11/2019 -- function CheckTheSamePoint(Figure1, Figure2: TFigure): Boolean; // Только для ТОЧЕЧНЫХ !!!! begin Result := false; if ((CompareValue(TConnectorObject(Figure1).ActualPoints[1].x, TConnectorObject(Figure2).ActualPoints[1].x) = 0) and (CompareValue(TConnectorObject(Figure1).ActualPoints[1].y, TConnectorObject(Figure2).ActualPoints[1].y) = 0)) then Result := true; end; // Tolik function RaiseFromConnector(aConn: TConnectorObject): TOrthoLine; var i, j: Integer; JoinedConn: TConnectorObject; begin Result := nil; if aConn.ConnectorType = ct_Nb then begin for i := 0 to aConn.JoinedConnectorsList.Count - 1 do begin JoinedConn := TConnectorObject(aConn.JoinedConnectorsList[i]); for j := 0 to JoinedConn.JoinedOrthoLinesList.Count - 1 do begin if TOrthoLine(JoinedConn.JoinedOrthoLinesList[j]).FIsRaiseUpDown then begin Result := TOrthoLine(JoinedConn.JoinedOrthoLinesList[j]); exit; end; end; end; end else begin for i := 0 to aConn.JoinedOrthoLinesList.Count - 1 do begin if TOrthoLine(aConn.JoinedOrthoLinesList[i]).FIsRaiseUpDown then begin Result := TOrthoLine(aConn.JoinedOrthoLinesList[i]); break; end; end; end; end; // 13/11/2019 -- переписана с учетом использования вертикальных конструкций // вертикальная линия по двум точкам procedure CreateVerticalOnTwoPointObjects(aPointObject1, APointObject2: TConnectorObject; aHeight: Double); var ConnectedConn: TConnectorObject; VertConn: TConnectorObject; VertLine: TOrthoLine; x, y, z: double; i: integer; JoinedLine: TOrthoLine; JoinedConn: TConnectorObject; JoinedConnBase: TConnectorObject; ObjParams: TObjectParams; //TempRaisedConnectors: TList; CurIndex: Integer; Conn1, Conn2, Point1, Point2: TConnectorObject; CompareResult: integer; SnapLine1, SnapLine2: TOrthoLine; function GetPointUPDown(aConn: TConnectorObject; aZ: Double; aDirection: Integer): TConnectorObject; var i: Integer; ResultConn: TConnectorObject; CheckResult: Integer; Function GetNextConn(aClearConn: TConnectorObject): TConnectorObject; var j: Integer; JoinedLine: TOrthoLine; begin Result := Nil; JoinedLine := nil; for j := 0 to aClearConn.JoinedOrtholinesList.Count - 1 do begin //JoinedLine := TOrthoLine(aClearConn.JoinedOrtholinesList[j]); if CheckTheSamePoint(TOrthoLine(aClearConn.JoinedOrtholinesList[j]).JoinConnector1, TOrthoLine(aClearConn.JoinedOrtholinesList[j]).JoinConnector2) then begin if CompareValue(TConnectorObject(TOrthoLine(aClearConn.JoinedOrtholinesList[j]).JoinConnector1).ActualZOrder[1], aConn.ActualZOrder[1]) = aDirection then begin Result := TConnectorObject(TOrthoLine(aClearConn.JoinedOrtholinesList[j]).JoinConnector1); if Result.JoinedConnectorsList.Count > 0 then Result := TConnectorObject(Result.JoinedConnectorsList[0]); JoinedLine := TOrthoLine(aClearConn.JoinedOrtholinesList[j]); break; end else if CompareValue(TConnectorObject(TOrthoLine(aClearConn.JoinedOrtholinesList[j]).JoinConnector2).ActualZOrder[1], aConn.ActualZOrder[1]) = aDirection then begin Result := TConnectorObject(TOrthoLine(aClearConn.JoinedOrtholinesList[j]).JoinConnector2); if Result.JoinedConnectorsList.Count > 0 then Result := TConnectorObject(Result.JoinedConnectorsList[0]); JoinedLine := TOrthoLine(aClearConn.JoinedOrtholinesList[j]); break; end; end; end; // если прыгнули выше или ниже коннектора -- выставить возможные трассы для снапа if JoinedLine <> nil then begin if aDirection = 1 then // трасса на нижнем коннекторе (идет вверх) begin if Comparevalue(Result.ActualZOrder[1], Point2.ActualZOrder[1]) = 1 then SnapLine1 := JoinedLine; end else // трасса на верхнем коннекторе (идет вниз) begin if Comparevalue(Result.ActualZOrder[1], Point1.ActualZOrder[1]) = -1 then SnapLine2 := JoinedLine; end end; end; begin Result := aConn; ResultConn := nil; //Check Z achieved CheckResult := CompareValue(aConn.ActualZOrder[1], aZ); //Down if aDirection = -1 then begin if CheckResult < 1 then // <= aZ exit; end else begin //UP if aDirection = 1 then if CheckResult > -1 then // >= aZ exit; end; if aConn.ConnectorType = ct_Nb then begin for i := 0 to aConn.JoinedConnectorsList.Count - 1 do begin ResultConn := GetNextConn(TConnectorObject(aConn.JoinedConnectorsList[i])); if ResultConn <> nil then break; end; end else ResultConn := GetNextConn(aConn); if ResultConn <> nil then Result := GetPointUPDown(ResultConn, aZ, aDirection); end; Procedure GetConnsToCreate(var aConn1, aConn2, aPoint1, aPoint2: TConnectorObject); var i,j,k: Integer; begin aConn1 := nil; aConn2 := nil; // нет присоединенных трасс if aPoint1.JoinedConnectorsList.Count = 0 then aConn1 := aPoint1; if aPoint2.JoinedConnectorsList.Count = 0 then aConn2 := aPoint2; if aConn1 <> nil then if aConn2 <> nil then exit; // нашли точки для конннекта -- нах отсюда if aConn1 = nil then aConn1 := GetPointUPDown(aPoint1, aPoint2.ActualZOrder[1], 1); if aConn2 = nil then aConn2 := GetPointUPDown(aPoint2, aPoint1.ActualZOrder[1], -1); end; // можно ли снапнуть объект на трассу function CheckCanSnapPointToLine(aLine: TOrthoLine; aConn: TConnectorObject): Boolean; var i, j: Integer; Joinedconn: TConnectorObject; JoinedLine: TOrthoLine; begin Result := True; //проверка по присоединенным трассам if aConn.ConnectorType = ct_NB then begin for i := 0 to aConn.JoinedConnectorsList.Count - 1 do begin JoinedConn := TConnectorObject(aConn.JoinedConnectorsList[i]); for j := 0 to JoinedConn.JoinedOrtholinesList.Count - 1 do begin JoinedLine := TOrthoLine(JoinedConn.JoinedOrtholinesList[j]); if CheckTheSamePoint(JoinedLine.JoinConnector1, JoinedLine.JoinConnector2) then begin Result := False; exit; end; end; end; end else begin for j := 0 to aConn.JoinedOrtholinesList.Count - 1 do begin JoinedLine := TOrthoLine(aConn.JoinedOrtholinesList[j]); if CheckTheSamePoint(JoinedLine.JoinConnector1, JoinedLine.JoinConnector2) then begin Result := False; exit; end; end; end; // если попадаем на вертикаль или райз, и запрещено использование вертикальных трасс - тоже низзя... if (aLine.FIsVertical or aLine.FIsRaiseUpDown) then if not GUseVerticalTraces then Result := False; end; // Procedure SnapPointToLine(aPoint: TConnectorObject; aLine: TOrthoLine); begin if aLine.FIsVertical then SnapPointObjectToVertical(aPoint, aLine) else if aLine.FIsRaiseUpDown then begin ConvertRaiseToVertical(aLine); SnapPointObjectToVertical(aPoint, aLine); end else SnapPointObjectToOrthoLine(aPoint, aLine); end; begin BaseBeginUpdate; try //определить высоту расположения CompareResult := Comparevalue(aPointObject1.ActualZOrder[1], aPointObject2.ActualZOrder[1]); Point1 := aPointObject1; // точки для сверки высот (попадание на трассу) Point2 := aPointObject2; // //возможные трассы для снапа SnapLine1 := nil; SnapLine2 := nil; case CompareResult of -1: GetConnsToCreate(Conn1, Conn2, aPointObject1, aPointObject2); // первый ниже 1: begin GetConnsToCreate(Conn1, Conn2, aPointObject2, aPointObject1); // второй ниже Point1 := aPointObject2; Point2 := aPointObject1; end; 0: begin // на одной высоте Conn1 := aPointObject1; Conn2 := aPointObject2; end; end; // если можно снапнуть поинт на трассу ... if SnapLine1 <> nil then begin if CheckCanSnapPointToLine(SnapLine1, Point2) then begin SnapPointToLine(Point2, SnapLine1); BaseEndUpdate; exit; end; end; if SnapLine2 <> nil then begin if CheckCanSnapPointToLine(SnapLine2, Point1) then begin SnapPointToLine(Point1, SnapLine2); BaseEndUpdate; exit; end; end; x := Conn1.ActualPoints[1].x; y := Conn1.ActualPoints[1].y; z := Conn1.ActualZOrder[1]; // создать присоединенный коннектор ConnectedConn := TConnectorObject.Create(x, y, z, APointObject1.LayerHandle, mydsNormal, GCadForm.PCad); ConnectedConn.ConnectorType := ct_Clear; GCadForm.PCad.AddCustomFigure (GLN(APointObject1.LayerHandle), ConnectedConn, False); ConnectedConn.Name := cCadClasses_Mes12; // создать вертикаль коннектор VertConn := TConnectorObject.Create(x + 10, y - 10, AHeight, APointObject1.LayerHandle, mydsNormal, GCadForm.PCad); VertConn.ConnectorType := ct_Clear; // 28/04/2016 -- GCadForm.PCad.AddCustomFigure (GLN(APointObject1.LayerHandle), VertConn, False); VertConn.Name := cCadClasses_Mes12; // создать вертикаль линия VertLine := TOrthoLine.Create(x, y, z, x + 10, y - 10, AHeight, 1,ord(psSolid), clBlack, 0, APointObject1.LayerHandle, mydsNormal, GCadForm.PCad, False); VertLine.SetJConnector1(TConnectorObject(ConnectedConn)); VertLine.SetJConnector2(TConnectorObject(VertConn)); VertLine.ActualZOrder[1] := ConnectedConn.ActualZOrder[1]; VertLine.ActualZOrder[2] := VertConn.ActualZOrder[1]; SetLineFigureCoordZInPM(VertLine.ID, 1, VertLine.ActualZOrder[1]); SetLineFigureCoordZInPM(VertLine.ID, 2, VertLine.ActualZOrder[2]); GCadForm.PCad.AddCustomFigure (GLN(APointObject1.LayerHandle), VertLine, False); if GUseVerticalTraces then begin VertLine.Name := cCadClasses_Mes32; VertLine.FIsVertical := True; end else VertLine.Name := cCadClasses_Mes20; SetNewObjectNameInPM(VertLine.ID, VertLine.Name); ObjParams := GetFigureParams(VertLine.ID); VertLine.Name := ObjParams.Name; VertLine.FIndex := ObjParams.MarkID; {VertConn.LockMove := True; VertConn.LockModify := True;} VertLine.LockMove := False; VertLine.LockModify := True; // приконнектить подъем // здесь соединяем вручную, чтобы не ломать механизм снапа //SnapConnectorToPointObject(ConnectedConn, APointObject1, true); if ConnectedConn.JoinedConnectorsList.IndexOf(APointObject1) = -1 then ConnectedConn.JoinedConnectorsList.Insert(0, APointObject1); if aPointObject1.JoinedConnectorsList.IndexOf(ConnectedConn) = -1 then aPointObject1.JoinedConnectorsList.Add(ConnectedConn); DeleteObjectFromPM(ConnectedConn.ID, ConnectedConn.Name); // Tolik 19/11/2019 -- // ConnectedConn.MoveConnector(APointObject1.ActualPoints[1].x - ConnectedConn.ActualPoints[1].x, APointObject1.ActualPoints[1].y - ConnectedConn.ActualPoints[1].y, false, false); // Tolik //здесь соединяем вручную, чтобы не ломать механизм снапа if VertConn.JoinedConnectorsList.IndexOf(APointObject2) = -1 then VertConn.JoinedConnectorsList.Insert(0, APointObject2); if aPointObject2.JoinedConnectorsList.IndexOf(VertConn) = -1 then aPointObject2.JoinedConnectorsList.Add(VertConn); DeleteObjectFromPM(VertConn.ID, VertConn.Name); // Tolik 19/11/2019 -- //SnapConnectorToPointObject(VertConn, APointObject2, true); VertConn.MoveConnector(APointObject2.ActualPoints[1].x - VertConn.ActualPoints[1].x, APointObject2.ActualPoints[1].y - VertConn.ActualPoints[1].y, false, false); // Tolik -- 11/05/2016 если не удалились при снапе, удалить поннекторы из ПМ if CanDeleteObjectFromPM(F_ProjMan.GSCSBase.CurrProject.CurrList.SCSID, ConnectedConn.ID) then DeleteObjectFromPM(ConnectedConn.ID, ConnectedConn.Name); if CanDeleteObjectFromPM(F_ProjMan.GSCSBase.CurrProject.CurrList.SCSID, VertConn.ID) then DeleteObjectFromPM(VertConn.ID, VertConn.Name); VertLine.CalculLength := VertLine.LengthCalc; VertLine.LineLength := VertLine.CalculLength; SetLineFigureLengthInPM(VertLine.ID, VertLine.LineLength); VertLine.ReCreateCaptionsGroup(True, false); VertLine.UpdateLengthTextBox(True, false); VertLine.ReCreateNotesGroup(True); VertLine.ShowCaptions := False; VertLine.ShowNotes := False; VertLine.IsShowBlock := False; //ЕСЛИ разрешено использование вертикальных трасс, проверить наличие райзов и преобразовать в вертикали if GUseVerticalTraces then begin JoinedLine := RaiseFromConnector(Conn1); if JoinedLine <> nil then ConvertRaiseToVertical(JoinedLine); JoinedLine := RaiseFromConnector(Conn2); if JoinedLine <> nil then ConvertRaiseToVertical(JoinedLine); end; RefreshCAD(GCadForm.PCad); except on E: Exception do AddExceptionToLogEx('U_Common.CreateVerticalOnPointObject', E.Message); end; BaseEndUpdate; end; (* // вертикальная линия по двум точкам procedure CreateVerticalOnTwoPointObjects(aPointObject1, APointObject2: TConnectorObject; aHeight: Double); var ConnectedConn: TConnectorObject; VertConn: TConnectorObject; VertLine: TOrthoLine; x, y, z: double; i: integer; JoinedLine: TOrthoLine; JoinedConn: TConnectorObject; JoinedConnBase: TConnectorObject; ObjParams: TObjectParams; //TempRaisedConnectors: TList; CurIndex: Integer; begin BaseBeginUpdate; try x := APointObject1.ActualPoints[1].x; y := APointObject1.ActualPoints[1].y; z := APointObject1.ActualZOrder[1]; // создать присоединенный коннектор ConnectedConn := TConnectorObject.Create(x, y, z, APointObject1.LayerHandle, mydsNormal, GCadForm.PCad); ConnectedConn.ConnectorType := ct_Clear; GCadForm.PCad.AddCustomFigure (GLN(APointObject1.LayerHandle), ConnectedConn, False); ConnectedConn.Name := cCadClasses_Mes12; // SetNewObjectNameInPM(ConnectedConn.ID, ConnectedConn.Name); // ObjParams := GetFigureParams(ConnectedConn.ID); // ConnectedConn.Name := ObjParams.Name; // ConnectedConn.FIndex := ObjParams.MarkID; // создать вертикаль коннектор VertConn := TConnectorObject.Create(x + 10, y - 10, AHeight, APointObject1.LayerHandle, mydsNormal, GCadForm.PCad); VertConn.ConnectorType := ct_Clear; // 28/04/2016 -- GCadForm.PCad.AddCustomFigure (GLN(APointObject1.LayerHandle), VertConn, False); VertConn.Name := cCadClasses_Mes12; // SetNewObjectNameInPM(VertConn.ID, VertConn.Name); // ObjParams := GetFigureParams(VertConn.ID); // VertConn.Name := ObjParams.Name; // VertConn.FIndex := ObjParams.MarkID; // // создать вертикаль линия VertLine := TOrthoLine.Create(x, y, z, x + 10, y - 10, AHeight, 1,ord(psSolid), clBlack, 0, APointObject1.LayerHandle, mydsNormal, GCadForm.PCad, False); {VertLine := TOrthoLine.Create(x, y, z, x, y, AHeight, 1,ord(psSolid), clBlack, 0, APointObject1.LayerHandle, mydsNormal, GCadForm.PCad, False);} VertLine.SetJConnector1(TConnectorObject(ConnectedConn)); VertLine.SetJConnector2(TConnectorObject(VertConn)); VertLine.ActualZOrder[1] := ConnectedConn.ActualZOrder[1]; VertLine.ActualZOrder[2] := VertConn.ActualZOrder[1]; SetLineFigureCoordZInPM(VertLine.ID, 1, VertLine.ActualZOrder[1]); SetLineFigureCoordZInPM(VertLine.ID, 2, VertLine.ActualZOrder[2]); //VertConn.MoveConnector(-10, 10, False); // СОЗДАТЬ НА КАД =========================================== // 28/04/2016 -- вот здесь не нужно (т.к. уже произошел СНАП на точечный объект) { GCadForm.PCad.AddCustomFigure (GLN(APointObject1.LayerHandle), VertConn, False); VertConn.Name := cCadClasses_Mes12; SetNewObjectNameInPM(VertConn.ID, VertConn.Name); ObjParams := GetFigureParams(VertConn.ID); VertConn.Name := ObjParams.Name; VertConn.FIndex := ObjParams.MarkID; } GCadForm.PCad.AddCustomFigure (GLN(APointObject1.LayerHandle), VertLine, False); VertLine.Name := cCadClasses_Mes32; SetNewObjectNameInPM(VertLine.ID, VertLine.Name); ObjParams := GetFigureParams(VertLine.ID); VertLine.Name := ObjParams.Name; VertLine.FIndex := ObjParams.MarkID; VertLine.FIsVertical := True; {VertConn.LockMove := True; VertConn.LockModify := True;} VertLine.LockMove := False; VertLine.LockModify := True; // приконнектить подъем SnapConnectorToPointObject(ConnectedConn, APointObject1, true); ConnectedConn.MoveConnector(APointObject1.ActualPoints[1].x - ConnectedConn.ActualPoints[1].x, APointObject1.ActualPoints[1].y - ConnectedConn.ActualPoints[1].y, false, false); // Tolik SnapConnectorToPointObject(VertConn, APointObject2, true); VertConn.MoveConnector(APointObject2.ActualPoints[1].x - VertConn.ActualPoints[1].x, APointObject2.ActualPoints[1].y - VertConn.ActualPoints[1].y, false, false); // Tolik -- 11/05/2016 если не удалились при снапе, удалить поннекторы из ПМ if CanDeleteObjectFromPM(F_ProjMan.GSCSBase.CurrProject.CurrList.SCSID, ConnectedConn.ID) then DeleteObjectFromPM(ConnectedConn.ID, ConnectedConn.Name); if CanDeleteObjectFromPM(F_ProjMan.GSCSBase.CurrProject.CurrList.SCSID, VertConn.ID) then DeleteObjectFromPM(VertConn.ID, VertConn.Name); {ConnectedConn.LockMove := True; ConnectedConn.LockModify := True;} { // переподсоединить трассы к подъему TempRaisedConnectors := TList.Create; for i := 0 to APointObject1.JoinedConnectorsList.Count - 1 do begin JoinedConn := TConnectorObject(APointObject1.JoinedConnectorsList[i]); if JoinedConn <> ConnectedConn then TempRaisedConnectors.Add(JoinedConn); end; // отвязка for i := 0 to TempRaisedConnectors.Count - 1 do begin JoinedConn := TConnectorObject(TempRaisedConnectors[i]); UnsnapConnectorFromPointObject(JoinedConn, APointObject1, true); end; // перепривязка к вершине CurIndex := TempRaisedConnectors.Count - 1; // вязать без сортировок for i := CurIndex downto 0 do begin JoinedConn := TConnectorObject(TempRaisedConnectors[i]); SnapConnectorToConnector(JoinedConn, VertConn, true); VertConn := JoinedConn; end; if TempRaisedConnectors <> nil then FreeAndNil(TempRaisedConnectors); } VertLine.CalculLength := VertLine.LengthCalc; VertLine.LineLength := VertLine.CalculLength; SetLineFigureLengthInPM(VertLine.ID, VertLine.LineLength); VertLine.ReCreateCaptionsGroup(True, false); VertLine.UpdateLengthTextBox(True, false); VertLine.ReCreateNotesGroup(True); VertLine.ShowCaptions := False; VertLine.ShowNotes := False; VertLine.IsShowBlock := False; // *** {for i := 0 to VertConn.JoinedOrtholinesList.Count - 1 do begin JoinedLine := TOrthoLine(VertConn.JoinedOrtholinesList[i]); if JoinedLine <> VertLine then begin JoinedLine.CalculLength := JoinedLine.LengthCalc; JoinedLine.LineLength := JoinedLine.CalculLength; SetLineFigureLengthInPM(JoinedLine.ID, JoinedLine.LineLength); JoinedLine.UpdateLengthTextBox(True, false); JoinedLine.ReCreateDrawFigureBlock; end; end; } //SetConnBringToFront(APointObject1); //SetConnBringToFront(APointObject2); {SetConnBringToFront(VertConn);} RefreshCAD(GCadForm.PCad); {SetNewObjectNameInPM(VertConn.ID, VertConn.Name);} except on E: Exception do AddExceptionToLogEx('U_Common.CreateVerticalOnPointObject', E.Message); end; BaseEndUpdate; end; *) // Tolik -- 28/06/2016 -- до сраки -- переписано ниже (* function CheckOtherConnectorsOnLevel(aSelf: TConnectorObject; X, Y: Double): TList; var i, j: integer; GetConn: TConnectorObject; GetLine: TOrthoLine; isVertical: Boolean; begin Result := nil; try // IsVertical isVertical := False; if aSelf.JoinedConnectorsList.Count = 0 then begin for i := 0 to aSelf.JoinedOrtholinesList.Count - 1 do begin GetLine := TOrthoLine(aSelf.JoinedOrtholinesList[i]); if GetLine.FIsVertical then begin isVertical := True; Break; end; end; end else begin for i := 0 to aSelf.JoinedConnectorsList.Count - 1 do begin GetConn := TConnectorObject(aSelf.JoinedConnectorsList[i]); for j := 0 to GetConn.JoinedOrtholinesList.Count - 1 do begin GetLine := TOrthoLine(GetConn.JoinedOrtholinesList[j]); if GetLine.FIsVertical then begin isVertical := True; Break; end; end; end; end; if not isVertical then exit; Result := TList.Create; for i := 0 to GCadForm.PCad.FigureCount - 1 do begin if CheckFigureByClassName(TFigure(GCadForm.PCad.Figures[i]), cTConnectorObject) then begin GetConn := TConnectorObject(GCadForm.PCad.Figures[i]); if GetConn <> aSelf then if GetConn.IsPointIn(X, Y) then begin if GetConn.ConnectorType <> ct_Clear then Result.Add(GetConn) else if GetConn.JoinedConnectorsList.Count = 0 then Result.Add(GetConn); end; end; end; except on E: Exception do AddExceptionToLogEx('U_Common.CheckOtherConnectorsOnLevel', E.Message); end; end; *) // Tolik -- 28/06/2016 -- как-то так... { function CheckOtherConnectorsOnLevel(aSelf: TConnectorObject; X, Y: Double): TList; var i, j: integer; GetConn: TConnectorObject; GetLine: TOrthoLine; isVertical: Boolean; currConn: TConnectorObject; currVLine: TOrthoLine; PassedLineList: TList; Procedure GetConnList(AConn: TConnectorObject); var i: Integer; begin if AConn <> aSelf then begin if AConn.JoinedConnectorsList.Count = 0 then begin if Result.IndexOf(aConn) = -1 then Result.Add(AConn); end else begin if (TConnectorObject(aConn.JoinedCOnnectorsList[0]).Id <> aSelf.ID) and (Result.IndexOf(TConnectorObject(aConn.JoinedConnectorsList[0])) = -1) then Result.Add(TConnectorObject(aConn.JoinedCOnnectorsList[0])); end; end; for i := 0 to AConn.JoinedOrtholinesList.Count - 1 do begin if (TOrthoLine(AConn.JoinedOrtholinesList[i]).FIsVertical and (TOrthoLine(AConn.JoinedOrtholinesList[i]).ID <> currVLine.ID)) then begin currConn := Nil; CurrVLine := TOrthoLine(AConn.JoinedOrtholinesList[i]); if TConnectorObject(TOrthoLine(AConn.JoinedOrtholinesList[i]).JoinConnector1).ID <> aConn.ID then currConn := TConnectorObject(TOrthoLine(AConn.JoinedOrtholinesList[i]).JoinConnector1) else if TConnectorObject(TOrthoLine(AConn.JoinedOrtholinesList[i]).JoinConnector2).ID <> aConn.ID then currConn := TConnectorObject(TOrthoLine(AConn.JoinedOrtholinesList[i]).JoinConnector2); if currConn <> nil then GetConnList(CurrConn); end; end; end; begin Result := nil; try IsVertical := False; GetLine := Nil; // tolik --09/09/2016 // if aSelf.JoinedConnectorsList.Count = 0 then if aSelf.ConnectorType = ct_Clear then begin for i := 0 to aSelf.JoinedOrtholinesList.Count - 1 do begin GetLine := TOrthoLine(aSelf.JoinedOrtholinesList[i]); if GetLine.FIsVertical then begin isVertical := True; Break; end; end; end else if aSelf.ConnectorType = ct_NB then begin if aSelf.JoinedConnectorsList.Count > 0 then begin for i := 0 to ASelf.JoinedConnectorsList.Count - 1 do begin GetConn := TConnectorObject(aSelf.JoinedConnectorsList[i]); for j := 0 to GetConn.JoinedOrtholinesList.Count - 1 do begin GetLine := TOrthoLine(GetConn.JoinedOrtholinesList[j]); if GetLine.FIsVertical then begin isVertical := True; Break; end; end; if isVertical then break; end; end; end; if not isVertical then exit; if ((GetLine <> nil) and (not GetLine.Deleted)) then begin PassedLineList := TList.Create; PassedLineList.Add(GetLine); Result := TList.Create; currVLine := GetLine; GetConnList(TConnectorObject(GetLine.JoinCOnnector1)); currVLine := GetLine; GetConnList(TConnectorObject(GetLine.JoinCOnnector2)); end; except on E: Exception do AddExceptionToLogEx('U_Common.CheckOtherConnectorsOnLevel', E.Message); end; end; } // 12/09/2016 -- Tolik function CheckOtherConnectorsOnLevel(aSelf: TConnectorObject; X, Y: Double): TList; var i, j: integer; GetConn: TConnectorObject; GetLine: TOrthoLine; isVertical: Boolean; currConn: TConnectorObject; currVLine: TOrthoLine; PassedLineList: TList; JoinedLine: TOrthoLine; Procedure GetLineList(AConn: TConnectorObject); var i, j: Integer; TempConn: TConnectorObject; begin if (aConn.ConnectorType = ct_Clear) and (aConn.JoinedConnectorsList.Count = 0) then begin for i := 0 to aConn.JoinedOrtholinesList.Count - 1 do begin if (TOrthoLine(aConn.JoinedOrtholinesList[i]).FIsVertical and (PassedLineList.IndexOf(TOrthoLine(aConn.JoinedOrtholinesList[i])) = -1)) then begin PassedLineList.Add(TOrthoLine(aConn.JoinedOrtholinesList[i])); if TConnectorObject(TOrthoLine(aConn.JoinedOrtholinesList[i]).JoinConnector1).Id <> aConn.Id then begin GetLineList(TConnectorObject(TOrthoLine(aConn.JoinedOrtholinesList[i]).JoinConnector1)) end else if TConnectorObject(TOrthoLine(aConn.JoinedOrtholinesList[i]).JoinConnector2).Id <> aConn.Id then begin GetLineList(TConnectorObject(TOrthoLine(aConn.JoinedOrtholinesList[i]).JoinConnector2)); end; end; end; end else begin TempConn := Nil; if aConn.ConnectorType = ct_NB then TempConn := AConn else if (aConn.ConnectorType = ct_Clear) and (aConn.JoinedConnectorsList.Count > 0) then TempConn := TconnectorObject(aConn.JoinedConnectorsList[0]); if (TempConn <> nil) and(not TempConn.Deleted) then begin if TempConn.ConnectorType = ct_NB then begin for i := 0 to TempConn.JoinedConnectorsList.Count - 1 do begin for j := 0 to TConnectorObject(TempConn.JoinedConnectorsList[i]).JoinedOrthoLinesList.Count - 1 do begin if TOrthoLine(TConnectorObject(TempConn.JoinedConnectorsList[i]).JoinedOrthoLinesList[j]).FIsVertical and (PassedLineList.IndexOf(TOrthoLine(TConnectorObject(TempConn.JoinedConnectorsList[i]).JoinedOrthoLinesList[j])) = -1) then begin PassedLineList.Add(TOrthoLine(TConnectorObject(TempConn.JoinedConnectorsList[i]).JoinedOrthoLinesList[j])); if TempConn.JoinedConnectorsList.IndexOf(TConnectorObject(TOrthoLine(TConnectorObject(TempConn.JoinedConnectorsList[i]).JoinedOrthoLinesList[j]).Joinconnector1)) = -1 then begin GetLineList(TConnectorObject(TOrthoLine(TConnectorObject(TempConn.JoinedConnectorsList[i]).JoinedOrthoLinesList[j]).JoinConnector1)) end else if TempConn.JoinedConnectorsList.IndexOf(TConnectorObject(TOrthoLine(TConnectorObject(TempConn.JoinedConnectorsList[i]).JoinedOrthoLinesList[j]).Joinconnector2)) = -1 then begin GetLineList(TConnectorObject(TOrthoLine(TConnectorObject(TempConn.JoinedConnectorsList[i]).JoinedOrthoLinesList[j]).JoinConnector2)); end; end; end; end; end; end; end; end; begin Result := nil; try IsVertical := False; GetLine := Nil; // tolik --09/09/2016 // if aSelf.JoinedConnectorsList.Count = 0 then if aSelf.ConnectorType = ct_Clear then begin for i := 0 to aSelf.JoinedOrtholinesList.Count - 1 do begin GetLine := TOrthoLine(aSelf.JoinedOrtholinesList[i]); if GetLine.FIsVertical then begin isVertical := True; Break; end; end; end else if aSelf.ConnectorType = ct_NB then begin if aSelf.JoinedConnectorsList.Count > 0 then begin for i := 0 to ASelf.JoinedConnectorsList.Count - 1 do begin GetConn := TConnectorObject(aSelf.JoinedConnectorsList[i]); for j := 0 to GetConn.JoinedOrtholinesList.Count - 1 do begin GetLine := TOrthoLine(GetConn.JoinedOrtholinesList[j]); if GetLine.FIsVertical then begin isVertical := True; Break; end; end; if isVertical then break; end; end; end; if not isVertical then exit; if ((GetLine <> nil) and (not GetLine.Deleted)) then begin PassedLineList := TList.Create; PassedLineList.Add(GetLine); GetLineList(TConnectorObject(GetLine.JoinCOnnector1)); GetLineList(TConnectorObject(GetLine.JoinCOnnector2)); if PassedLineList.Count > 0 then begin Result := TList.Create; for i := 0 to PassedLineList.Count - 1 do begin JoinedLine := TOrthoLine(PassedLineList[i]); if aSelf.ConnectorType = ct_Clear then begin if TConnectorObject(TOrthoLine(PassedLineList[i]).JoinConnector1).Id <> aSelf.Id then begin if TConnectorObject(TOrthoLine(PassedLineList[i]).JoinConnector1).JoinedConnectorsList.Count > 0 then currConn := TconnectorObject(TConnectorObject(TOrthoLine(PassedLineList[i]).JoinConnector1).JoinedConnectorsList[0]) else currConn := TConnectorObject(TOrthoLine(PassedLineList[i]).JoinConnector1); if Result.IndexOf(currConn) = -1 then Result.Add(currConn); end; if TConnectorObject(TOrthoLine(PassedLineList[i]).JoinConnector2).Id <> aSelf.Id then begin if TConnectorObject(TOrthoLine(PassedLineList[i]).JoinConnector2).JoinedConnectorsList.Count > 0 then currConn := TconnectorObject(TConnectorObject(TOrthoLine(PassedLineList[i]).JoinConnector2).JoinedConnectorsList[0]) else currConn := TConnectorObject(TOrthoLine(PassedLineList[i]).JoinConnector2); if Result.IndexOf(currConn) = -1 then Result.Add(currConn); end; end else if aSelf.ConnectorType = ct_NB then begin if (aSelf.JoinedConnectorsList.IndexOf(TConnectorObject(JoinedLine.JoinConnector1)) = -1) then begin if TConnectorObject(JoinedLine.JoinConnector1).JoinedConnectorsList.Count > 0 then currConn := TconnectorObject(TConnectorObject(JoinedLine.JoinConnector1).JoinedConnectorsList[0]) else currConn := TConnectorObject(JoinedLine.JoinConnector1); if Result.IndexOf(currConn) = -1 then Result.Add(currConn); end; if (aSelf.JoinedConnectorsList.IndexOf(TConnectorObject(JoinedLine.JoinConnector2)) = -1) then begin if TConnectorObject(JoinedLine.JoinConnector2).JoinedConnectorsList.Count > 0 then currConn := TconnectorObject(TConnectorObject(JoinedLine.JoinConnector2).JoinedConnectorsList[0]) else currConn := TConnectorObject(JoinedLine.JoinConnector2); if Result.IndexOf(currConn) = -1 then Result.Add(currConn); end; end; end; end; FreeAndNil(PassedLineList); end; except on E: Exception do AddExceptionToLogEx('U_Common.CheckOtherConnectorsOnLevel', E.Message); end; end; // procedure SetLiteStatus(aStatus: Boolean); var isPrjOpen: Boolean; begin try GLiteVersion := aStatus; if GLiteVersion then begin FSCS_Main.mainFormat.Visible := False; FSCS_Main.mainTools.Visible := False; FSCS_Main.tbsToolsExpert.Visible := False; //29.12.2011 FSCS_Main.tbLineExpert.Visible := False; //Tolik 23/07/2017 -- FSCS_Main.tbPieExpert.Visible := False; // FSCS_Main.tbRectangleExpert.Visible := False; FSCS_Main.tbEllipseExpert.Visible := False; FSCS_Main.tbCircleExpert.Visible := False; FSCS_Main.tbArcExpert.Visible := False; FSCS_Main.tbElipticArcExpert.Visible := False; FSCS_Main.tbPolyLineExpert.Visible := False; FSCS_Main.tbPointExpert.Visible := False; FSCS_Main.tbTextExpert.Visible := False; FSCS_Main.tbRichTextExpert.Visible := False; FSCS_Main.tbKnifeExpert.Visible := False; FSCS_Main.tbHDimLineExpert.Visible := False; FSCS_Main.tbVDimLineExpert.Visible := False; //29.03.2012 FSCS_Main.tbWallRectExpert.Visible := False; //29.03.2012 FSCS_Main.tbWallPathExpert.Visible := False; FSCS_Main.tbHouseExpert.Visible := False; //29.03.2012 FSCS_Main.tbWallRectNoob.Visible := False; //29.03.2012 FSCS_Main.tbWallPathNoob.Visible := False; FSCS_Main.tbHouseNoob.Visible := False; FSCS_Main.aMasterAutoTrace.Visible := False; FSCS_Main.aMasterAutoTraceElectric.Visible := False; FSCS_Main.aCreateNormsOnCad.Visible := False; FSCS_Main.aManual_Interfaces.Visible := False; end else begin FSCS_Main.mainFormat.Visible := True; FSCS_Main.mainTools.Visible := True; FSCS_Main.tbsToolsExpert.Visible := True; //29.12.2011 //Tolik 23/07/2017 -- FSCS_Main.tbPieExpert.Visible := True; // FSCS_Main.tbLineExpert.Visible := True; FSCS_Main.tbRectangleExpert.Visible := True; FSCS_Main.tbEllipseExpert.Visible := True; FSCS_Main.tbCircleExpert.Visible := True; FSCS_Main.tbArcExpert.Visible := True; FSCS_Main.tbElipticArcExpert.Visible := True; FSCS_Main.tbPolyLineExpert.Visible := True; FSCS_Main.tbPointExpert.Visible := True; FSCS_Main.tbTextExpert.Visible := True; FSCS_Main.tbRichTextExpert.Visible := True; FSCS_Main.tbKnifeExpert.Visible := True; FSCS_Main.tbHDimLineExpert.Visible := True; FSCS_Main.tbVDimLineExpert.Visible := True; //29.03.2012 FSCS_Main.tbWallRectExpert.Visible := True; //29.03.2012 FSCS_Main.tbWallPathExpert.Visible := True; FSCS_Main.tbHouseExpert.Visible := True; //29.03.2012 FSCS_Main.tbWallRectNoob.Visible := True; //29.03.2012 FSCS_Main.tbWallPathNoob.Visible := True; FSCS_Main.tbHouseNoob.Visible := True; FSCS_Main.aMasterAutoTrace.Visible := True; FSCS_Main.aMasterAutoTraceElectric.Visible := True; FSCS_Main.aCreateNormsOnCad.Visible := True; FSCS_Main.aManual_Interfaces.Visible := True; end; isPrjOpen := CheckIsOpenProject(false); if FSCS_Main.Visible then //16.08.2012 - если только запуск программы, то нефиг вызывать одно и тоже несколько раз FSCS_Main.SetMenuStatus(isPrjOpen); except on E: Exception do AddExceptionToLogEx('U_Common.SetLiteStatus', E.Message); end; end; function CheckJoinVertical(aObject: TConnectorObject; aHeight: double = -1): Boolean; var i, j: integer; JoinedConn: TConnectorObject; JoinedLine: TOrthoLine; //Tolik NB_Connector: TConnectorObject; RaiseConn1, RaiseConn2: TConnectorObject; Conn1isBusy, conn2isBusy: Boolean; // begin Result := false; try if aObject.ConnectorType = ct_clear then begin // Tolik -- 22/04/2016 -- if aObject.JoinedConnectorsList.Count > 0 then begin // перестрахуююсь на всякий .. if TConnectorObject(aObject.JoinedConnectorsList[0]).ConnectorType = ct_NB then begin NB_Connector := TConnectorObject(aObject.JoinedConnectorsList[0]); for i := 0 to NB_Connector.JoinedConnectorsList.Count - 1 do begin JoinedConn := TConnectorObject(NB_Connector.JoinedConnectorsList[i]); for j := 0 to JoinedConn.JoinedOrtholinesList.Count - 1 do begin JoinedLine := TOrthoLine(JoinedConn.JoinedOrtholinesList[j]); //если есть вертикаль, то и так все понятно if JoinedLine.FIsVertical then begin Result := True; break; end else // если есть с/п, нужно преверить, будет ли он разделен в результате подъема трассы, и, если // да, то вернуть результат if (JoinedLine.FIsRaiseUpDown and (aHeight <> -1)) then begin RaiseConn1 := TConnectorObject(JoinedLine.JoinConnector1); RaiseConn2 := TConnectorObject(JoinedLine.JoinConnector2); // попадаем на райз if (((CompareValue(RaiseConn1.ActualZOrder[1], aHeight) = -1) and (CompareValue(RaiseConn2.ActualZOrder[1], aHeight) = 1)) or ((CompareValue(RaiseConn1.ActualZOrder[1], aHeight) = -1) and (CompareValue(RaiseConn2.ActualZOrder[1], aHeight) = 1))) then begin Result := True; break; end else // если перепрыгиваем райз, проверяем, может ли он перевернуться begin if NB_Connector.JoinedConnectorsList.IndexOf(RaiseConn1) = -1 then if ((RaiseConn1.JoinedConnectorsList.Count > 0) or (RaiseConn1.JoinedOrtholinesList.Count > 1)) then begin Result := True; Exit; end; if NB_Connector.JoinedConnectorsList.IndexOf(RaiseConn2) = -1 then if ((RaiseConn2.JoinedConnectorsList.Count > 0) or (RaiseConn2.JoinedOrtholinesList.Count > 1)) then begin Result := True; Exit; end; end; end; end; end; end; end else begin // for i := 0 to aObject.JoinedOrtholinesList.Count - 1 do begin JoinedLine := TOrthoLine(aObject.JoinedOrtholinesList[i]); if JoinedLine.FIsVertical then begin Result := True; Break; end; end; end; end // сюда, по идее, не попадем .... else begin for i := 0 to aObject.JoinedConnectorsList.Count - 1 do begin JoinedConn := TConnectorObject(aObject.JoinedConnectorsList[i]); for j := 0 to JoinedConn.JoinedOrtholinesList.Count - 1 do begin JoinedLine := TOrthoLine(JoinedConn.JoinedOrtholinesList[j]); if JoinedLine.FIsVertical then begin Result := True; Break; end; end; if Result then //#From Oleg# //15.09.2010 Break; //// BREAK //// end; end; except on E: Exception do AddExceptionToLogEx('U_Common.CheckJoinVertical', E.Message); end; end; // Tolik -- 22/04/2016 -- старая для истории -- { procedure PutObjectOnHeight(aObject: TConnectorObject; aHeight: Double); var i, j: integer; JoinedConn: TConnectorObject; JoinedLine: TOrthoLine; begin try AObject.ActualZOrder[1] := aHeight; if aObject.ConnectorType = ct_Clear then begin for i := 0 to aObject.JoinedOrtholinesList.Count - 1 do begin JoinedLine := aObject.JoinedOrtholinesList[i]; if JoinedLine.JoinConnector1 = aObject then begin SetLineFigureCoordZInPM(JoinedLine.ID, 1, aObject.ActualZOrder[1]); JoinedLine.ActualZOrder[1] := aObject.ActualZOrder[1]; end; if JoinedLine.JoinConnector2 = aObject then begin SetLineFigureCoordZInPM(JoinedLine.ID, 2, aObject.ActualZOrder[1]); JoinedLine.ActualZOrder[2] := aObject.ActualZOrder[1]; end; JoinedLine.CalculLength := JoinedLine.LengthCalc; JoinedLine.LineLength := JoinedLine.CalculLength; SetLineFigureLengthInPM(JoinedLine.ID, JoinedLine.LineLength); JoinedLine.UpdateLengthTextBox(True, true); JoinedLine.ReCreateNotesGroup(True); end; end else begin // установить новые значения for i := 0 to aObject.JoinedConnectorsList.Count - 1 do begin JoinedConn := aObject.JoinedConnectorsList[i]; JoinedConn.ActualZOrder[1] := aObject.ActualZOrder[1]; for j := 0 to JoinedConn.JoinedOrtholinesList.Count - 1 do begin JoinedLine := JoinedConn.JoinedOrtholinesList[j]; if JoinedLine.JoinConnector1 = JoinedConn then begin SetLineFigureCoordZInPM(JoinedLine.ID, 1, aObject.ActualZOrder[1]); JoinedLine.ActualZOrder[1] := aObject.ActualZOrder[1]; end; if JoinedLine.JoinConnector2 = JoinedConn then begin SetLineFigureCoordZInPM(JoinedLine.ID, 2, aObject.ActualZOrder[1]); JoinedLine.ActualZOrder[2] := aObject.ActualZOrder[1]; end; JoinedLine.CalculLength := JoinedLine.LengthCalc; JoinedLine.LineLength := JoinedLine.CalculLength; SetLineFigureLengthInPM(JoinedLine.ID, JoinedLine.LineLength); JoinedLine.UpdateLengthTextBox(True, true); JoinedLine.ReCreateNotesGroup(True); end; SetConFigureCoordZInPM(JoinedConn.ID, JoinedConn.ActualZOrder[1]); end; end; SetConFigureCoordZInPM(aObject.ID, aHeight); except on E: Exception do AddExceptionToLogEx('U_Common.PutObjectOnHeight', E.Message); end; end; } // Tolik -- переломана совсем -- 22/04/2016 -- // вызовется только если на точечном есть вертикаль // точечный объект сюда не придет, т.к. мы двигаем ортолинию, ее коннекторы имеют тип ct_Cleat, // поэтому водящий коннектор как параметр в смысле ct_NB рассматривать не будем // procedure PutObjectOnHeight(aObject: TConnectorObject; aHeight: Double); procedure PutObjectOnHeight(aObject: TConnectorObject; aHeight: Double; ATraceList: TList); var i, j, k: integer; JoinedConn: TConnectorObject; JoinedLine: TOrthoLine; NB_Connector: TConnectorObject; // объект на коннекторе (если есть и коннектор пустой) VertLine: TOrthoLine; // вертикаль LowVConn, HighVConn: TConnectorObject; // коннекторы вертикали CanSnapToVertical: Boolean; DirectionUP, DirectionDown: Boolean; // направление сдвига от базового положения коннектора (вверх/вниз) LastObject: TConnectorObject; // следующий коннектор (вверх/вниз) если есть коленчастое построение(пока не получим последний возможный) WayList: TList; // путь до точки спуска/подъема (трассы) CanLook: Boolean; RaisedLinesList: TList; // список поднятых трасс от коннектора CanRaiseLine: Boolean; ConnectorToSnap, TempConn: TConnectorObject; CanRaiseAllTracesAtOnce: Boolean; ObjParams: TObjectParams; NeedToCreateVLine: Boolean; // добавить вертикаль от точки спуска/подъема, если перескочим CreateDConn: TConnectorObject; // созданный коннектор (если поднимаемся/опускаемся от пересечения трасс и не все трассы можно двигать) RaiseLineToVertical: TOrthoLine; // райз, который нужно преобразовать в вертикаль (если поймаем) CanDelEmptyLines: Boolean; // произвести удаление пройденных вертикалей, если они ни к чему не подключены с одной стороны CanDelConnectorsFromPointObject: Boolean; // можно удалять коннекторы с точечного объекта TempLineList: TList; aObjectVLinesCount : integer; //19/04/2017 -*- MoveRaiseFlag: Boolean; // function CanRaiseAllTraces(aConnector: TConnectorObject): Boolean; var i: Integer; VLine1, vLine2: TOrthoLine; LastConn: TConnectorObject; ConnRaiseLine: TOrthoLine; DirectionUP, DirectionDown: Boolean; begin Result := True; if (ConnectorToSnap <> nil) and (ConnectorToSnap.ConnectorType = ct_NB) then begin Result := False; exit; end; // если не поднимаем хоть одну приконнекченную трассу(не райз и не вертикаль) for i := 0 to aConnector.JoinedOrthoLinesList.Count - 1 do begin if ((ATraceList.IndexOf(TOrthoLine(aConnector.JoinedOrtholinesList[i])) = -1) and (not TOrthoLine(aConnector.JoinedOrtholinesList[i]).FIsVertical) and (not TOrthoLine(aConnector.JoinedOrtholinesList[i]).FIsRaiseUpDown)) then begin Result := False; exit; end; end; if result then begin ConnRaiseLine := Nil; VLine1 := Nil; VLine2 := Nil; for i := 0 to aConnector.JoinedOrthoLinesList.Count - 1 do begin if TOrthoLine(aConnector.JoinedOrtholinesList[i]).FIsRaiseUpDown then begin // если райз ConnRaiseLine := TOrthoLine(aConnector.JoinedOrtholinesList[i]); Break; //// BREAK ////; end else if TOrthoLine(aConnector.JoinedOrtholinesList[i]).FIsVertical then begin // первая вертикаль if VLine1 = nil then VLine1 := TOrthoLine(aConnector.JoinedOrtholinesList[i]) else // вторая вертикаль if VLine2 = nil then begin VLine2 := TOrthoLine(aConnector.JoinedOrtholinesList[i]); break; end; end; end; // если есть райз if ConnRaiseLine <> nil then begin LastConn := nil; if TConnectorObject(ConnRaiseLine.JoinConnector1).Id <> aObject.ID then LastConn := TConnectorObject(ConnRaiseLine.JoinConnector1) else if TConnectorObject(ConnRaiseLine.JoinConnector2).Id <> aObject.ID then LastConn := TConnectorObject(ConnRaiseLine.JoinConnector2); if LastConn <> nil then begin if CompareValue(LastConn.ActualZOrder[1],aHeight) = 0 then begin Result := False; exit; end; end; end else if VLine1 <> nil then begin // направление (вверх/вниз) DirectionUp := False; DirectionDown := False; if CompareValue(aObject.ActualZOrder[1], aHeight) = -1 then DirectionUp := True else if CompareValue(aObject.ActualZOrder[1], aHeight) = 1 then DirectionDown := True; // одна вертикаль if VLine2 = nil then begin // попали на коннектор if (Comparevalue(TConnectorObject(VLine1.JoinConnector1).ActualZOrder[1], aheight) = 0) or (Comparevalue(TConnectorObject(VLine1.JoinConnector2).ActualZOrder[1], aheight) = 0) then begin Result := False; exit; end else // не попали на коннектор begin LastConn := TConnectorObject(VLine1.JoinConnector1); if DirectionUp then begin if CompareValue(LastConn.ActualZOrder[1], TConnectorObject(VLine1.JoinConnector2).ActualZOrder[1]) = -1 then LastConn := TconnectorObject(VLine1.JoinConnector2); for i := 0 to LastConn.JoinedOrthoLinesList.Count - 1 do begin if TOrthoLine(LastConn.JoinedOrthoLinesList[i]).FIsVertical and (TOrthoLine(LastConn.JoinedOrthoLinesList[i]).ID <> VLine1.Id) then begin Result := False; break; end; end; end else if DirectionDown then begin if CompareValue(LastConn.ActualZOrder[1], TConnectorObject(VLine1.JoinConnector2).ActualZOrder[1]) = 1 then LastConn := TconnectorObject(VLine1.JoinConnector2); for i := 0 to LastConn.JoinedOrthoLinesList.Count - 1 do begin if TOrthoLine(LastConn.JoinedOrthoLinesList[i]).FIsVertical and (TOrthoLine(LastConn.JoinedOrthoLinesList[i]).ID <> VLine1.Id) then begin Result := False; break; end; end; end; end; end else // две вертикали begin if DirectionUP then begin LastConn := TConnectorObject(VLine1.JoinConnector1); if Comparevalue(LastConn.ActualZOrder[1], TConnectorObject(VLine1.JoinConnector2).ActualZOrder[1]) = -1 then LastConn := TConnectorObject(VLine1.JoinConnector2); if Comparevalue(LastConn.ActualZOrder[1], TConnectorObject(VLine2.JoinConnector1).ActualZOrder[1]) = -1 then LastConn := TConnectorObject(VLine2.JoinConnector1); if Comparevalue(LastConn.ActualZOrder[1], TConnectorObject(VLine2.JoinConnector2).ActualZOrder[1]) = -1 then LastConn := TConnectorObject(VLine2.JoinConnector2); if Comparevalue(LastConn.ActualZOrder[1], aHeight) <> 1 then begin Result := False; exit; end; end else if DirectionDown then begin LastConn := TConnectorObject(VLine1.JoinConnector1); if Comparevalue(LastConn.ActualZOrder[1], TConnectorObject(VLine1.JoinConnector2).ActualZOrder[1]) = 1 then LastConn := TConnectorObject(VLine1.JoinConnector2); if Comparevalue(LastConn.ActualZOrder[1], TConnectorObject(VLine2.JoinConnector1).ActualZOrder[1]) = 1 then LastConn := TConnectorObject(VLine2.JoinConnector1); if Comparevalue(LastConn.ActualZOrder[1], TConnectorObject(VLine2.JoinConnector2).ActualZOrder[1]) = 1 then LastConn := TConnectorObject(VLine2.JoinConnector2); if Comparevalue(LastConn.ActualZOrder[1], aHeight) <> -1 then begin Result := False; exit; end; end; end; end; end; end; Function HasConnectorVertLine(AConnector: TConnectorObject; aList: TList): Boolean; var i: Integer; JoinedLine: TOrthoLine; begin Result := False; for i := 0 to AConnector.JoinedOrtholinesList.Count - 1 do begin JoinedLine := TOrthoLine(AConnector.JoinedOrtholinesList[i]); if AList.IndexOf(JoinedLine) = -1 then begin Result := True; break; end; end; end; Procedure CreateVertLineOnHeight; var i: Integer; VConn1, VConn2 : TConnectorObject; vLine: TOrthoLine; SnapConn, TempConn: TConnectorObject; WayLine: TOrthoLine; NbConn: TConnectorObject; begin VConn1 := nil; VConn2 := nil; if (CanRaiseAllTracesAtOnce and (aObjectVLinesCount = 1) and (WayList.Count = 1)) then begin VLine := Nil; for i := 0 to aObject.JoinedOrtholinesList.Count - 1 do begin if TOrthoLine(aObject.JoinedOrtholinesList[i]).FIsVertical then begin VLine := TOrthoLine(aObject.JoinedOrtholinesList[i]); break; end; end; // переворот вертикали if (TOrthoLine(WayList[0]).Id = VLine.Id) and (aObject.JoinedConnectorsList.Count = 0) then Exit; end; // вверх if DirectionUP then begin if HighVConn = nil then begin {if NB_Connector <> nil then HighVConn := NB_Connector else} if CreatedConn <> nil then HighVConn := CreatedConn; end; if HighVConn <> nil then begin VConn1 := HighVConn; Vconn2 := AObject; { if WayList.Count > 0 then begin WayLine := TOrthoLine(WayList[WayList.Count - 1]); HighVConn := TConnectorObject(WayLine.JoinConnector1); if CompareValue(HighVConn.ActualZOrder[1], TConnectorObject(WayLine.JoinConnector2).ActualZOrder[1]) = -1 then HighVConn := TConnectorObject(WayLine.JoinConnector2); end; NbConn := nil; if HighVConn.JoinedConnectorsList.Count > 0 then NbConn := TConnectorObject(HighVConn.JoinedConnectorsList[0]); if (VConn1 = nil) or ((VConn1 <> nil) and (CompareValue(VConn1.ActualZOrder[1], HighVConn.ActualZOrder[1]) = -1)) then begin if NbConn = nil then VConn1 := HighVConn else // если перескакиваем через точечный объект, нужно припиздячить к нему пустой коннектор для создания вертикали begin VConn1 := TConnectorObject.Create(HighVConn.ActualPoints[1].x, HighVConn.ActualPoints[1].y, HighVConn.ActualZOrder[1], HighVConn.LayerHandle, mydsNormal, GCadForm.PCad); VConn1.ConnectorType := ct_Clear; GCadForm.PCad.AddCustomFigure (GLN(HighVConn.LayerHandle), VConn1, False); VConn1.Name := cCadClasses_Mes12; SetNewObjectNameInPM(VConn1.ID, VConn1.Name); ObjParams := GetFigureParams(VConn1.ID); VConn1.Name := ObjParams.Name; VConn1.FIndex := ObjParams.MarkID; //приконнектить к точечному NbConn.JoinedConnectorsList.Add(VConn1); VConn1.JoinedConnectorsList.Add(NbConn); DeleteObjectFromPM(VConn1.ID, VConn1.Name); end; end; } { if WayList.Count > 1 then TempConn := TConnectorObject(TOrthoLine(WayList[WayList.Count - 1]).JoinConnector1) else TempConn := HighVConn; } // создать коннекторы (первый - от верхнего коннектора) {VConn1 := TConnectorObject.Create(HighVConn.ActualPoints[1].x, HighVConn.ActualPoints[1].y, HighVConn.ActualZOrder[1], HighVConn.LayerHandle, mydsNormal, GCadForm.PCad); VConn1.ConnectorType := ct_Clear; GCadForm.PCad.AddCustomFigure (GLN(HighVConn.LayerHandle), VConn1, False); VConn1.Name := cCadClasses_Mes12; SetNewObjectNameInPM(VConn1.ID, VConn1.Name); ObjParams := GetFigureParams(VConn1.ID); VConn1.Name := ObjParams.Name; VConn1.FIndex := ObjParams.MarkID;} {VConn2 := CreateDConn; VConn2 := TConnectorObject.Create(HighVConn.ActualPoints[1].x, HighVConn.ActualPoints[1].y, AHeight, HighVConn.LayerHandle, mydsNormal, GCadForm.PCad); VConn2.ConnectorType := ct_Clear; GCadForm.PCad.AddCustomFigure (GLN(HighVConn.LayerHandle), VConn2, False); VConn2.Name := cCadClasses_Mes12; SetNewObjectNameInPM(VConn2.ID, VConn2.Name); ObjParams := GetFigureParams(VConn2.ID); VConn2.Name := ObjParams.Name; VConn2.FIndex := ObjParams.MarkID;} // выравникание {TConnectorObject(aObject).Move(TempConn.ActualPoints[1].x - TConnectorObject(aObject).ActualPoints[1].x, TempConn.ActualPoints[1].y - TConnectorObject(aObject).ActualPoints[1].y); } {VConn2.Move(TConnectorObject(aObject).ActualPoints[1].x - VConn2.ActualPoints[1].x, TConnectorObject(aObject).ActualPoints[1].y - VConn2.ActualPoints[1].y); VConn1.Move(TConnectorObject(aObject).ActualPoints[1].x - VConn1.ActualPoints[1].x, TConnectorObject(aObject).ActualPoints[1].y - VConn1.ActualPoints[1].y); } // VertLine := TOrthoLine.Create(VConn1.ActualPoints[1].x, VConn1.ActualPoints[1].y, VConn1.ActualZOrder[1], VConn1.ActualPoints[1].x, VConn1.ActualPoints[1].y, VConn2.ActualZOrder[1], 1,ord(psSolid), clBlack, 0, AObject.LayerHandle, mydsNormal, GCadForm.PCad, False); VertLine.SetJConnector1(TConnectorObject(VConn1)); VertLine.SetJConnector2(TConnectorObject(VConn2)); VertLine.ActualZOrder[1] := VConn1.ActualZOrder[1]; VertLine.ActualZOrder[2] := VConn2.ActualZOrder[1]; GCadForm.PCad.AddCustomFigure (GLN(aObject.LayerHandle), VertLine, False); SetLineFigureCoordZInPM(VertLine.ID, 1, VertLine.ActualZOrder[1]); SetLineFigureCoordZInPM(VertLine.ID, 2, VertLine.ActualZOrder[2]); // приконнектить подъем // 05/05/2016 -- коннектить не будем, уже есть { if HighVConn.ConnectorType = ct_NB then begin SnapConnectorToPointObject(VConn1, HighVConn, true); VConn1.MoveConnector(HighVConn.ActualPoints[1].x - VConn1.ActualPoints[1].x, HighVConn.ActualPoints[1].y - VConn1.ActualPoints[1].y, false, false); end else if HighVConn.ConnectorType = ct_Clear then SnapConnectorToConnector(VConn1, HighVConn);} //SnapConnectorToConnector(VConn2, aObject); //VertConn.MoveConnector(-10, 10, False); // СОЗДАТЬ НА КАД =========================================== {GCadForm.PCad.AddCustomFigure (GLN(APointObject.LayerHandle), VertConn, False); VertConn.Name := cCadClasses_Mes12;} {_SetNewObjectNameInPM(VertConn.ID, VertConn.Name); ObjParams := GetFigureParams(VertConn.ID); VertConn.Name := ObjParams.Name; VertConn.FIndex := ObjParams.MarkID; GCadForm.PCad.AddCustomFigure (GLN(APointObject.LayerHandle), VertLine, False);} VertLine.Name := cCadClasses_Mes32; SetNewObjectNameInPM(VertLine.ID, VertLine.Name); ObjParams := GetFigureParams(VertLine.ID); VertLine.Name := ObjParams.Name; VertLine.FIndex := ObjParams.MarkID; VertLine.FIsVertical := True; {VertConn.LockMove := False;//True; VertConn.LockModify := True;} VertLine.LockMove := False; VertLine.LockModify := True; {ConnectedConn.LockMove := True; ConnectedConn.LockModify := True;} // Commented by Tolik 22/04/2016 -- // Переприсоединять не совсем правильно, т.к. при создании вертикали получится точечный объект внизу, // а приконнекченные к нему трассы поднимутся на вершину ... { // переподсоединить трассы к подъему TempRaisedConnectors := TList.Create; for i := 0 to APointObject.JoinedConnectorsList.Count - 1 do begin JoinedConn := TConnectorObject(APointObject.JoinedConnectorsList[i]); if JoinedConn <> ConnectedConn then TempRaisedConnectors.Add(JoinedConn); end; // отвязка for i := 0 to TempRaisedConnectors.Count - 1 do begin JoinedConn := TConnectorObject(TempRaisedConnectors[i]); UnsnapConnectorFromPointObject(JoinedConn, APointObject, true); end; // перепривязка к вершине CurIndex := TempRaisedConnectors.Count - 1; // вязать без сортировок for i := CurIndex downto 0 do begin JoinedConn := TConnectorObject(TempRaisedConnectors[i]); SnapConnectorToConnector(JoinedConn, VertConn, true); VertConn := JoinedConn; end; if TempRaisedConnectors <> nil then FreeAndNil(TempRaisedConnectors); } VertLine.CalculLength := VertLine.LengthCalc; VertLine.LineLength := VertLine.CalculLength; SetLineFigureLengthInPM(VertLine.ID, VertLine.LineLength); VertLine.ReCreateCaptionsGroup(True, false); VertLine.UpdateLengthTextBox(True, false); VertLine.ReCreateNotesGroup(True); VertLine.ShowCaptions := False; VertLine.ShowNotes := False; VertLine.IsShowBlock := False; end; end else // вниз if DirectionDown then begin if LowVConn = Nil then begin { if NB_Connector <> nil then LowVConn := NB_Connector else} if CreatedConn <> nil then LowVConn := CreatedConn; end; if WayList.Count > 1 then TempConn := TConnectorObject(TOrthoLine(WayList[WayList.Count - 1]).JoinConnector1) else TempConn := LowVConn; if LowVConn <> nil then begin // создать коннекторы {VConn1 := TConnectorObject.Create(LowVConn.ActualPoints[1].x, LowVConn.ActualPoints[1].y, AHeight, LowVConn.LayerHandle, mydsNormal, GCadForm.PCad); VConn1.ConnectorType := ct_Clear; GCadForm.PCad.AddCustomFigure (GLN(LowVConn.LayerHandle), VConn1, False); VConn1.Name := cCadClasses_Mes12; SetNewObjectNameInPM(VConn1.ID, VConn1.Name); ObjParams := GetFigureParams(VConn1.ID); VConn1.Name := ObjParams.Name; VConn1.FIndex := ObjParams.MarkID;} if CreatedConn <> nil then VConn1 := CreateDConn else VConn1 := LowVConn; VConn1 := AObject; Vconn2 := LowVConn; {VConn2 := TConnectorObject.Create(LowVConn.ActualPoints[1].x, LowVConn.ActualPoints[1].y, LowVConn.ActualZOrder[1], LowVConn.LayerHandle, mydsNormal, GCadForm.PCad); VConn2.ConnectorType := ct_Clear; GCadForm.PCad.AddCustomFigure (GLN(LowVConn.LayerHandle), VConn2, False); VConn2.Name := cCadClasses_Mes12; SetNewObjectNameInPM(VConn2.ID, VConn2.Name); ObjParams := GetFigureParams(VConn2.ID); VConn2.Name := ObjParams.Name; VConn2.FIndex := ObjParams.MarkID;} // выравнивание {TConnectorObject(aObject).Move(VConn2.ActualPoints[1].x - TConnectorObject(aObject).ActualPoints[1].x, VConn2.ActualPoints[1].y - TConnectorObject(aObject).ActualPoints[1].y); } { VConn2.Move(TConnectorObject(aObject).ActualPoints[1].x - VConn2.ActualPoints[1].x, TConnectorObject(aObject).ActualPoints[1].y - VConn2.ActualPoints[1].y); VConn1.Move(TConnectorObject(aObject).ActualPoints[1].x - VConn1.ActualPoints[1].x, TConnectorObject(aObject).ActualPoints[1].y - VConn1.ActualPoints[1].y); } // VertLine := TOrthoLine.Create(VConn1.ActualPoints[1].x, VConn1.ActualPoints[1].y, VConn1.ActualZOrder[1], VConn1.ActualPoints[1].x, VConn1.ActualPoints[1].y, VConn2.ActualZOrder[1], 1,ord(psSolid), clBlack, 0, AObject.LayerHandle, mydsNormal, GCadForm.PCad, False); VertLine.SetJConnector1(TConnectorObject(VConn1)); VertLine.SetJConnector2(TConnectorObject(VConn2)); VertLine.ActualZOrder[1] := VConn1.ActualZOrder[1]; VertLine.ActualZOrder[2] := VConn2.ActualZOrder[1]; GCadForm.PCad.AddCustomFigure (GLN(aObject.LayerHandle), VertLine, False); SetLineFigureCoordZInPM(VertLine.ID, 1, VertLine.ActualZOrder[1]); SetLineFigureCoordZInPM(VertLine.ID, 2, VertLine.ActualZOrder[2]); // приконнектить подъем //05/05/2016 --- снапы нах { if LowVConn.ConnectorType = ct_NB then begin SnapConnectorToPointObject(VConn2, LowVConn, true); VConn2.MoveConnector(LowVConn.ActualPoints[1].x - VConn2.ActualPoints[1].x, LowVConn.ActualPoints[1].y - VConn2.ActualPoints[1].y, false, false); end else if LowVConn.ConnectorType = ct_Clear then SnapConnectorToConnector(VConn2, LowVConn); SnapConnectorToConnector(VConn1, aObject);} VertLine.Name := cCadClasses_Mes32; SetNewObjectNameInPM(VertLine.ID, VertLine.Name); ObjParams := GetFigureParams(VertLine.ID); VertLine.Name := ObjParams.Name; VertLine.FIndex := ObjParams.MarkID; VertLine.FIsVertical := True; VertLine.LockMove := False; VertLine.LockModify := True; VertLine.CalculLength := VertLine.LengthCalc; VertLine.LineLength := VertLine.CalculLength; SetLineFigureLengthInPM(VertLine.ID, VertLine.LineLength); VertLine.ReCreateCaptionsGroup(True, false); VertLine.UpdateLengthTextBox(True, false); VertLine.ReCreateNotesGroup(True); VertLine.ShowCaptions := False; VertLine.ShowNotes := False; VertLine.IsShowBlock := False; end; end; end; Procedure LookUPDOWN; var i: Integer; VLineConn, TempConn: TConnectorObject; VLine: TOrthoLine; VLineFound: boolean; procedure LookForVLine; var j: Integer; begin for j := 0 to TempConn.JoinedOrtholinesList.Count - 1 do begin //if TOrthoLine(TempConn.JoinedOrtholinesList[j]).FIsVertical then if (TOrthoLine(TempConn.JoinedOrtholinesList[j]).FIsVertical) or (TOrthoLine(TempConn.JoinedOrtholinesList[j]).FIsRaiseUpDown) then begin // вертикаль VLine := TOrthoLine(TempConn.JoinedOrtholinesList[j]); VLineConn := Nil; if DirectionUP then begin if CompareValue(TConnectorObject(VLine.JoinConnector1).ActualZOrder[1], TempConn.ActualZOrder[1]) = 1 then HighVConn := TConnectorObject(VLine.JoinConnector1) else if CompareValue(TConnectorObject(VLine.JoinConnector2).ActualZOrder[1], TempConn.ActualZOrder[1]) = 1 then HighVConn := TConnectorObject(VLine.JoinConnector2); end else if DirectionDown then begin if CompareValue(TConnectorObject(VLine.JoinConnector1).ActualZOrder[1], TempConn.ActualZOrder[1]) = -1 then LowVConn := TConnectorObject(VLine.JoinConnector1) else if CompareValue(TConnectorObject(VLine.JoinConnector2).ActualZOrder[1], TempConn.ActualZOrder[1]) = -1 then LowVConn := TConnectorObject(VLine.JoinConnector2); end; end; //если вертикаль выше текущей точки if ((HighVConn <> nil) or (LowVConn <> nil)) then begin // добавить вертикаль в список прохождения if WayList.IndexOf(VLine) = -1 then WayList.Add(VLine); // возможность топать дальше VLineFound := True; if DirectionUP then begin if HighVConn <> nil then begin // если высота подъема совпадает с высотой коннектора вертикали if (CompareValue(HighVConn.ActualZOrder[1],aHeight) = 0) then begin LastObject := nil; // сброс стартовой точки CanLook := False; // сброс цикла (выше не поднимаемся) LastObject := HighVConn; // коннектор для подключения ConnectorToSnap := HighVConn; // Если НБ if ConnectorToSnap.JoinedConnectorsList.Count > 0 then ConnectorToSnap := TConnectorObject(ConnectorToSnap.JoinedConnectorsList[0]); end else // или попадаем на вертикаль if (CompareValue(HighVConn.ActualZOrder[1],aHeight) = 1) then begin LastObject := nil; // сброс стартовой точки CanLook := False; // сброс цикла (выше не поднимаемся) // сброс коннектора (не него не попадем) HighVConn := nil; CanSnapToVertical := True; break; end else // высота коннектора меньше высоты подъема if CompareValue(HighVConn.ActualZOrder[1],aHeight) = -1 then begin LastObject := HighVConn; // переход CanLook := True; // можно искать выше break; end end; end else if DirectionDown then begin if LowVConn <> nil then begin // если высота подъема совпадает с высотой коннектора вертикали if (CompareValue(LowVConn.ActualZOrder[1],aHeight) = 0) then begin LastObject := nil; // сброс стартовой точки CanLook := False; // сброс цикла (ниже не опустимся) // коннектор для присоединения трассы ConnectorToSnap := LowVConn; // Если НБ if ConnectorToSnap.JoinedConnectorsList.Count > 0 then ConnectorToSnap := TConnectorObject(ConnectorToSnap.JoinedConnectorsList[0]); end else // или попадаем на вертикаль if (CompareValue(LowVConn.ActualZOrder[1],aHeight) = -1) then begin LastObject := nil; // сброс стартовой точки CanLook := False; // сброс цикла (ниже не опустимся) // сброс коннектора, если на него не попадем LowVConn := nil; CanSnapToVertical := True; break; end else // высота коннектора больше высоты спуска if CompareValue(LowVConn.ActualZOrder[1],aHeight) = 1 then begin LastObject := LowVConn; // переход CanLook := True; // можно искать ниже LowVConn := nil; break; end; end; end; end; end; end; begin VLineFound := False; Nb_Connector := Nil; // сброс LowVConn := Nil; HighVConn := Nil; CreateDConn := nil; // точечный на коннекторе if LastObject <> nil then begin for i := 0 to LastObject.JoinedConnectorsList.Count - 1 do begin if TConnectorObject(LastObject.JoinedConnectorsList[i]).ConnectorType = ct_Nb then begin NB_Connector := TConnectorObject(LastObject.JoinedConnectorsList[i]); break; end; end; end; // точечный есть - идем от него if NB_Connector <> nil then begin for i := 0 to NB_Connector.JoinedConnectorsList.Count - 1 do begin TempConn := TConnectorObject(NB_Connector.JoinedConnectorsList[i]); LookForVLine; if VLineFound then break; end; if not VLineFound then CanLook := False; // сброс цикла, если ничего нет end // точечного нет - идем от коннектора else begin TempConn := LastObject; LookForVLine; if not VLineFound then CanLook := False; // сброс цикла, если ничего нет end; end; function CheckNeedToCreateVLine : boolean; var i, j: Integer; vConn: TConnectorObject; currLine: TOrthoLine; RaiseLine: TOrthoLine; CanAddLine: Boolean; begin Result := False; // если стоим на точечном - создаем однозначно (или поднимаеи/опускаем без прохождения // вертикали/райза, причем не все трассы пересечения) if (((aObject.JoinedConnectorsList.Count > 0) and (WayList.Count = 0)) or ((WayList.Count = 0) and (aObject.JoinedConnectorsList.Count = 0) and (not CanRaiseAllTracesAtOnce))) then begin Result := True; if CreatedConn = Nil then begin // создаем коннектор вертикали CreateDConn := TConnectorObject.Create(aObject.ActualPoints[1].x, aObject.ActualPoints[1].y, aObject.ActualZOrder[1], aObject.LayerHandle, mydsNormal, GCadForm.PCad); CreateDConn.ConnectorType := ct_Clear; GCadForm.PCad.AddCustomFigure (GLN(aObject.LayerHandle), CreateDConn, False); CreateDConn.Name := cCadClasses_Mes12; // SetNewObjectNameInPM(CreateDConn.ID, CreateDConn.Name); // ObjParams := GetFigureParams(CreateDConn.ID); // CreateDConn.Name := ObjParams.Name; // CreateDConn.FIndex := ObjParams.MarkID; // прицепить к объекту(если есть) if aObject.JoinedCOnnectorsList.Count > 0 then begin CreatedConn.JoinedConnectorsList.Add(TConnectorObject(aObject.JoinedConnectorsList[0])); TConnectorObject(aObject.JoinedConnectorsList[0]).JoinedConnectorsList.Add(CreatedConn); DeleteObjectFromPM(CreatedConn.ID, CreatedConn.Name); // Tolik 19/11/2019 -- end // если не все трассы двигаем и точечного нет - переконнектить все, что не двигаем на созданный коннектор else begin if not CanRaiseAllTracesAtOnce then begin CanAddLine := True; While CanAddLine do begin CanAddLine := False; for i := 0 to aObject.JoinedOrtholinesList.Count - 1 do begin CurrLine := TOrthoLine(aObject.JoinedOrtholinesList[i]); if ATraceList.IndexOf(CurrLine) = -1 then begin // перепривязка aObject.JoinedOrtholinesList.Remove(CurrLine); CreateDConn.JoinedOrtholinesList.Add(CurrLine); if TConnectorObject(currLine.JoinConnector1).Id = aObject.ID then CurrLine.SetJConnector1(CreatedConn) else if TConnectorObject(CurrLine.JoinConnector2).Id = aObject.ID then CurrLine.SetJConnector2(CreatedConn); CanAddLine := True; break; end; end; end; end; end; end; // выравнять коннектор по точечному объекту if aObject.JoinedConnectorsList.Count > 0 then CreatedConn.Move(TConnectorObject(aObject.JoinedConnectorsList[0]).ActualPoints[1].x - CreatedConn.ActualPoints[1].x, TConnectorObject(aObject.JoinedConnectorsList[0]).ActualPoints[1].y - CreatedConn.ActualPoints[1].y); // Exit; end; // если пересечение трасс vConn := Nil; // Если есть пройденные вертикали // if WayList.Count > 0 then if WayList.Count > 0 then begin // если райз и поднимаем все сразу - нех проверять создавать ли вертикаль (не нужно ни х создавать) currLine := TOrthoLine(WayList[WayList.Count - 1]); if currLine.FIsRaiseUpDown and CanRaiseAllTracesAtOnce then VConn := nil else begin if DirectionUp then begin if CompareValue(TConnectorObject(currLine.JoinConnector1).ActualZOrder[1], TConnectorObject(currLine.JoinConnector2).ActualZOrder[1]) = 1 then VConn := TConnectorObject(TConnectorObject(currLine.JoinConnector1)) else if CompareValue(TConnectorObject(currLine.JoinConnector1).ActualZOrder[1], TConnectorObject(currLine.JoinConnector2).ActualZOrder[1]) = -1 then VConn := TConnectorObject(TConnectorObject(currLine.JoinConnector2)); end else if DirectionDown then begin if CompareValue(TConnectorObject(currLine.JoinConnector1).ActualZOrder[1], TConnectorObject(currLine.JoinConnector2).ActualZOrder[1]) = -1 then VConn := TConnectorObject(TConnectorObject(currLine.JoinConnector1)) else if CompareValue(TConnectorObject(currLine.JoinConnector1).ActualZOrder[1], TConnectorObject(currLine.JoinConnector2).ActualZOrder[1]) = 1 then VConn := TConnectorObject(TConnectorObject(currLine.JoinConnector2)); end; end; if VConn <> nil then begin if (CompareValue(VConn.ActualZOrder[1], aHeight) <> 0) and ((VConn.JoinedConnectorsList.Count > 0) or (vConn.JoinedOrtholinesList.Count > 1)) then begin //07/04/2016 -- создавать вертикаль только в том случае, если не она не будет переворачиваться в результате сдвига // нужно создать вертикаль Result := True; // создаем нижний коннектор вертикали // if CreatedConn = nil then begin if (VConn.ConnectorType = ct_Clear) and (VConn.JoinedConnectorsList.Count = 0) and (VConn.JoinedOrtholinesList.Count > 0) then CreatedConn := vConn else begin CreateDConn := TConnectorObject.Create(VConn.ActualPoints[1].x, VConn.ActualPoints[1].y, VConn.ActualZOrder[1], VConn.LayerHandle, mydsNormal, GCadForm.PCad); CreateDConn.ConnectorType := ct_Clear; GCadForm.PCad.AddCustomFigure (GLN(VConn.LayerHandle), CreateDConn, False); CreateDConn.Name := cCadClasses_Mes12; SetNewObjectNameInPM(CreateDConn.ID, CreateDConn.Name); ObjParams := GetFigureParams(CreateDConn.ID); CreateDConn.Name := ObjParams.Name; CreateDConn.FIndex := ObjParams.MarkID; // прицепить сразу (к объекту, если есть) if VConn.ConnectorType = ct_NB then begin vConn.JoinedConnectorsList.Add(CreatedConn); CreateDConn.JoinedConnectorsList.Add(VConn); DeleteObjectFromPm(CreatedConn.ID, CreatedConn.Name); end else if vConn.ConnectorType = ct_Clear then begin if VConn.JoinedConnectorsList.Count > 0 then begin // ct_NB TConnectorObject(VConn.JoinedConnectorsList[0]).JoinedConnectorsList.Add(CreatedConn); CreatedConn.JoinedCOnnectorsList.Add(TConnectorObject(VConn.JoinedConnectorsList[0])); DeleteObjectFromPm(CreatedConn.ID, CreatedConn.Name); end end; end; end; end // просто поднять коннектор последней вертикали else ConnectorToSnap := VConn; end; end // если не проходим вертикаль - пляшем от пустого коннектора else begin { if CreateDConn <> nil then begin for i := 0 to CreateDConn.JoinedOrtholinesList.Count - 1 do begin if TOrthoLine(CreateDConn.JoinedOrtholinesList[i]).FIsVertical or TOrthoLine(CreateDConn.JoinedOrtholinesList[i]).FIsRaiseUpDown then begin Result := True; exit; end; end; end else begin if aObject.JoinedConnectorsList.Count = 0 then begin // если нет приконнекченного точечного for i := 0 to aObject.JoinedOrthoLinesList.Count - 1 do begin if TOrthoLine(aObject.JoinedOrtholinesList[i]).FIsVertical or TOrthoLine(aObject.JoinedOrtholinesList[i]).FIsRaiseUpDown then begin Result := True; exit; end; end; end // если есть приконнекченный точечный else begin for i := 0 to TconnectorObject(aObject.JoinedConnectorsList[0]).JoinedConnectorsList.Count - 1 do begin VConn := TConnectorObject(TconnectorObject(aObject.JoinedConnectorsList[0]).JoinedConnectorsList[i]); for j := 0 to VConn.JoinedOrtholinesList.Count - 1 do begin if TOrthoLine(VConn.JoinedOrtholinesList[j]).FIsRaiseUpDown or TOrthoLine(VConn.JoinedOrtholinesList[j]).FIsVertical then begin Result := True; exit; end; end; end; end end; } end; end; // переконнектить трассы, которые не будут подниматься, на новый коннектор // Здесь заодно определяется коннектор для снапа function ReconnectOnPointByConn(AConn: TConnectorObject): TConnectorObject; Var ConnectedConn: TConnectorObject; i: Integer; ReconnLine, LastVLine: TOrthoLine; CanReconnect: Boolean; LastConnector, NB_Conn: TConnectorObject; CanCreateNewConn: Boolean; RaiseConn: TConnectorObject; RaiseLine: TOrthoLine; SelTrace: TOrthoLine; begin Result := nil; CanCreateNewConn := False; RaiseLine := nil; ConnectedConn := nil; // определяем коннектор для снапа if WayList.Count > 0 then begin // последняя вертикаль (или райз) на пути прохождения коннектора трассы LastVLine := TOrthoLine(WayList[WayList.Count - 1]); LastConnector := TConnectorObject(LastVLine.JoinConnector1); if DirectionUP then begin if CompareValue(LastConnector.ActualZOrder[1], TConnectorObject(LastVLine.JoinConnector2).ActualZOrder[1]) = -1 then LastConnector := TConnectorObject(LastVLine.JoinConnector2); end else if DirectionDown then begin if CompareValue(LastConnector.ActualZOrder[1], TConnectorObject(LastVLine.JoinConnector2).ActualZOrder[1]) = 1 then LastConnector := TConnectorObject(LastVLine.JoinConnector2); end; if CompareValue(LastConnector.ActualZOrder[1], aHeight) = 0 then begin if LastConnector.JoinedConnectorsList.Count = 0 then ConnectorToSnap := LastConnector else ConnectorToSnap := TConnectorObject(LastConnector.JoinedConnectorsList[0]); end; end; // если нельзя двинуть все концы трасс одновременно, нужно переконнектить на новый коннектор if not CanRaiseAllTracesAtOnce then begin // создать коннектор ConnectedConn := TConnectorObject.Create(AConn.ActualPoints[1].x, AConn.ActualPoints[1].y, AConn.ActualZOrder[1], AConn.LayerHandle, mydsNormal, GCadForm.PCad); ConnectedConn.ConnectorType := ct_Clear; GCadForm.PCad.AddCustomFigure (GLN(AConn.LayerHandle), ConnectedConn, False); ConnectedConn.Name := cCadClasses_Mes12; SetNewObjectNameInPM(ConnectedConn.ID, ConnectedConn.Name); ObjParams := GetFigureParams(ConnectedConn.ID); ConnectedConn.Name := ObjParams.Name; ConnectedConn.FIndex := ObjParams.MarkID; // определить, есть ли райз, чтобы не потерять его характеристики for i := 0 to aObject.JoinedOrtholinesList.Count - 1 do begin if TOrthoLine(aObject.JoinedOrtholinesList[i]).FIsRaiseUpDown then begin RaiseLine := TOrthoLine(aObject.JoinedOrtholinesList[i]); // противоположный коннектор райза if TConnectorObject(RaiseLine.JoinConnector1).ID <> aObject.Id then RaiseConn := TConnectorObject(RaiseLine.JoinConnector1) else if TConnectorObject(RaiseLine.JoinConnector2).ID <> aObject.Id then RaiseConn := TConnectorObject(RaiseLine.JoinConnector2); end; end; for i := aObject.JoinedOrtholinesList.Count - 1 downto 1 do begin ReconnLine := TOrthoLine(aObject.JoinedOrthoLinesList[i]); //if ATraceList.IndexOf(ReconnLine) = -1 then begin if ReconnLine.JoinConnector1.Id = aObject.Id then begin ReconnLine.JoinConnector1 := ConnectedConn; aObject.JoinedOrtholinesList.Remove(ReconnLine); if ConnectedConn.JoinedOrthoLinesList.IndexOf(ReconnLine) = -1 then ConnectedConn.JoinedOrtholinesList.Add(ReconnLine); end else if ReconnLine.JoinConnector2.Id = aObject.Id then begin ReconnLine.JoinConnector2 := ConnectedConn; aObject.JoinedOrtholinesList.Remove(ReconnLine); if ConnectedConn.JoinedOrthoLinesList.IndexOf(ReconnLine) = -1 then ConnectedConn.JoinedOrtholinesList.Add(ReconnLine); end; end; end; if (ConnectorToSnap <> nil) and (ConnectorToSnap.ConnectorType = ct_NB) then DeleteObjectFromPM(aObject.ID, aObject.Name); // переконнектить райз if RaiseLine <> nil then begin if RaiseLine.FObjectFromRaisedLine = aObject then RaiseLine.FObjectFromRaisedLine := ConnectedConn; if (RaiseConn.FObjectFromRaise <> nil) and (RaiseConn.FObjectFromRaise.Id = aObject.ID) then Raiseconn.FObjectFromRaise := ConnectedConn; if ConnectedConn.Name <> aObject.Name then begin ConnectedConn.Name := aObject.Name; SetNewObjectNameInPM(ConnectedConn.ID, ConnectedConn.Name); aObject.Name := cCadClasses_Mes12; if ((ConnectorToSnap = nil) or ((ConnectorToSnap <> nil) and (ConnectorToSnap.ConnectorType = ct_clear))) then SetNewObjectNameInPM(aObject.ID, aObject.Name); end; ConnectedConn.FConnRaiseType := aObject.FConnRaiseType; aObject.FConnRaiseType := crt_None; ConnectedConn.FObjectFromRaise := aObject.FObjectFromRaise; aObject.FObjectFromRaise := Nil; end; end; Result := ConnectedConn; (* // переконнектить только для пересечения трасс без точечного объекта if AConn.JoinedConnectorsList.Count = 0 then begin // если ортолиния не одна -- тогда будем проверять (есть смысл в реконнекте) if AConn.JoinedOrtholinesList.Count > 1 then begin // нужно ли пересоединение трасс for i := 0 to AConn.JoinedOrthoLinesList.count - 1 do begin ReconnLine := TOrthoLine(AConn.JoinedOrtholinesList[i]); if ReconnLine.FIsRaiseUpDown then RaiseLine := ReconnLine; // если двигаем не все - нужно if (not ReconnLine.FIsVertical) and (not ReconnLine.FIsRaiseUpDown) and (ATraceList.IndexOf(ReconnLine) = -1) then begin CanCreateNewConn := True; // Break; //// BREAK ////; end; // end; if (not CanCreateNewConn) and (not CanRaiseAllTracesAtOnce) and (RaiseLine = nil) then CanCreateNewConn := True; if CanCreateNewConn then begin // создать коннектор ConnectedConn := TConnectorObject.Create(AConn.ActualPoints[1].x, AConn.ActualPoints[1].y, AConn.ActualZOrder[1], AConn.LayerHandle, mydsNormal, GCadForm.PCad); ConnectedConn.ConnectorType := ct_Clear; GCadForm.PCad.AddCustomFigure (GLN(AConn.LayerHandle), ConnectedConn, False); ConnectedConn.Name := cCadClasses_Mes12; SetNewObjectNameInPM(ConnectedConn.ID, ConnectedConn.Name); ObjParams := GetFigureParams(ConnectedConn.ID); ConnectedConn.Name := ObjParams.Name; ConnectedConn.FIndex := ObjParams.MarkID; // переконнектить трассы CanReconnect := True; // если нельзя двинуть все - отрываем все, кроме первой (ее подвинем) if (not CanRaiseAllTracesAtOnce) then begin While CanReconnect do begin CanReconnect := False; for i := 1 to aConn.JoinedOrthoLinesList.Count - 1 do begin ReconnLine := TOrthoLine(aConn.JoinedOrthoLinesList[i]); While AConn.JoinedOrthoLinesList.IndexOf(ReconnLine) <> -1 do AConn.JoinedOrtholinesList.Remove(ReconnLine); if ConnectedConn.JoinedOrtholinesList.IndexOf(ReconnLine) = -1 then ConnectedConn.JoinedOrtholinesList.Add(ReconnLine); if TConnectorObject(ReconnLine.JoinConnector1).ID = aConn.ID then begin if ReconnLine.FIsRaiseUpDown then RaiseConn := TConnectorObject(ReconnLine.JoinConnector1); ReconnLine.JoinConnector1 := ConnectedConn; end else if TConnectorObject(ReconnLine.JoinConnector2).ID = aConn.ID then begin if ReconnLine.FIsRaiseUpDown then RaiseConn := TConnectorObject(ReconnLine.JoinConnector1); ReconnLine.JoinConnector2 := ConnectedConn; end; // 20/07/2016 Tolik -- переопределить параметры для райза, иначе пропадет изображение райза на Каде if ReconnLine.FIsRaiseUpDown then begin RaiseConn := nil; // противоположный коннектор райза (чтобы не потерять объект) if TConnectorObject(ReconnLine.JoinConnector1).Id <> aObject.Id then RaiseConn := TConnectorObject(ReconnLine.JoinConnector1) else if TConnectorObject(ReconnLine.JoinConnector2).Id <> aObject.Id then RaiseConn := TConnectorObject(ReconnLine.JoinConnector2); if RaiseConn <> nil then begin if RaiseConn.FObjectFromRaise.Id = aObject.ID then RaiseConn.FObjectFromRaise := ConnectedConn; end; // ConnectedConn.FObjectFromRaise := AObject.FObjectFromRaise; if ReconnLine.FObjectFromRaisedLine = aObject then ReconnLine.FObjectFromRaisedLine := ConnectedConn; ConnectedConn.FConnRaiseType := aObject.FConnRaiseType; ConnectedConn.Name := AObject.Name; // переименовать в ПМ SetNewObjectNameInPM(ConnectedConn.ID, ConnectedConn.Name); //RaiseConn.JoinedOrthoLinesList.Remove(ReconnLine); if (TConnectorObject(ReconnLine.JoinConnector1).FObjectFromRaise <> nil) and (TConnectorObject(ReconnLine.JoinConnector1).FObjectFromRaise.Id = AConn.ID) then TConnectorObject(ReconnLine.JoinConnector1).FObjectFromRaise := ConnectedConn else if (TConnectorObject(ReconnLine.JoinConnector2).FObjectFromRaise <> nil) and (TConnectorObject(ReconnLine.JoinConnector2).FObjectFromRaise.Id = AConn.ID) then TConnectorObject(ReconnLine.JoinConnector2).FObjectFromRaise := ConnectedConn; {if RaiseConn.JoinedOrthoLinesList.Count = 0 then RaiseConn.Delete;} // если переконнектили на райзе = сбросить признаки райза на том конекторе, который будем двигать AObject.FObjectFromRaise := Nil; AObject.FConnRaiseType := Crt_None; // просто коннектор aObject.Name := cCadClasses_Mes12; // переименовать в ПМ SetNewObjectNameInPM(AObject.ID, AObject.Name); end; CanReconnect := True; break; end; end; end; // если на по пути подъема/спуска проходим несколько трасс - ищем последний коннектор if WayList.Count > 0 then begin // ищем последнюю вертикаль для коннекта, если не попадаем на вертикаль, ищем коннектор LastVLine := TOrthoLine(WayList[WayList.Count - 1]); // если попадаем на вертикаль - создавать коннектор не нужно, а созданный коннектор - сбросить if ((CompareValue(TConnectorObject(LastVLine.JoinConnector1).ActualZOrder[1], aHeight) = -1) and (CompareValue(TConnectorObject(LastVLine.JoinConnector2).ActualZOrder[1], aHeight) = 1)) or ((CompareValue(TConnectorObject(LastVLine.JoinConnector1).ActualZOrder[1], aHeight) = 1) and (CompareValue(TConnectorObject(LastVLine.JoinConnector2).ActualZOrder[1], aHeight) = -1)) then ConnectedConn := nil else begin LastConnector := nil; // ищем последний коннектор на пути if DirectionUP then begin if (CompareValue(TConnectorObject(LastVLine.JoinConnector1).ActualZOrder[1], TConnectorObject(LastVLine.JoinConnector2).ActualZOrder[1]) = 1) then LastConnector := TConnectorObject(LastVLine.JoinConnector1) else if (CompareValue(TConnectorObject(LastVLine.JoinConnector1).ActualZOrder[1], TConnectorObject(LastVLine.JoinConnector2).ActualZOrder[1]) = -1) then LastConnector := TConnectorObject(LastVLine.JoinConnector2); end else if DirectionDown then begin if (CompareValue(TConnectorObject(LastVLine.JoinConnector1).ActualZOrder[1], TConnectorObject(LastVLine.JoinConnector2).ActualZOrder[1]) = -1) then LastConnector := TConnectorObject(LastVLine.JoinConnector1) else if (CompareValue(TConnectorObject(LastVLine.JoinConnector1).ActualZOrder[1], TConnectorObject(LastVLine.JoinConnector2).ActualZOrder[1]) = 1) then LastConnector := TConnectorObject(LastVLine.JoinConnector2); end; // смотрим куда приконнектить вертикаль (нужно ли создавать коннектор и новую вертикаль или приконнектить // к существующей вертикали и поднять ее, если можно на высоту) if LastConnector <> nil then begin // на точечном создаем однозначно новый и приконнектим к точечному сразу if LastConnector.JoinedConnectorsList.Count > 0 then begin NB_Conn := TConnectorObject(LastConnector.JoinedConnectorsList[0]); if ((NB_Conn <> nil) and (not NB_Conn.Deleted) and (CompareValue(NB_Conn.ActualZOrder[1], aHeight) <> 0)) then begin // создать коннектор ConnectedConn := TConnectorObject.Create(NB_Conn.ActualPoints[1].x, NB_Conn.ActualPoints[1].y, NB_Conn.ActualZOrder[1], NB_Conn.LayerHandle, mydsNormal, GCadForm.PCad); ConnectedConn.ConnectorType := ct_Clear; GCadForm.PCad.AddCustomFigure (GLN(NB_Conn.LayerHandle), ConnectedConn, False); ConnectedConn.Name := cCadClasses_Mes12; SetNewObjectNameInPM(ConnectedConn.ID, ConnectedConn.Name); ObjParams := GetFigureParams(ConnectedConn.ID); ConnectedConn.Name := ObjParams.Name; ConnectedConn.FIndex := ObjParams.MarkID; // приконнектить к точечному ConnectedConn.JoinedConnectorsList.Add(NB_Conn); NB_Conn.JoinedConnectorsList.Add(ConnectedConn); end; end else begin ConnectedConn := nil; if ((LastConnector.JoinedOrtholinesList.Count = 1) and ((TOrthoLine(LastConnector.JoinedOrtholinesList[0]).FIsVertical) or (TOrthoLine(LastConnector.JoinedOrtholinesList[0]).FIsRaiseUpDown))) then ConnectedConn := LastConnector else begin for i := 0 to LastConnector.JoinedOrtholinesList.Count - 1 do begin ReconnLine := TOrthoLine(LastConnector.JoinedOrtholinesList[i]); if ((not ReconnLine.FIsVertical) and (not ReconnLine.FIsRaiseUpDown) and (ATraceList.IndexOf(ReconnLine) = -1)) then begin ConnectedConn := LastConnector; break; end; end; end; end; end; end; end; Result := ConnectedConn; end else begin // if CanRaiseAllTracesAtOnce then // если есть райз и двигаем все, то и отрываем от вершины райза все begin RaiseLine := Nil; for i := 0 to aObject.JoinedOrthoLinesList.Count - 1 do begin if TOrthoLine(aObject.JoinedOrtholinesList[i]).FIsRaiseUpDown then begin RaiseLine := TOrthoLine(aObject.JoinedOrthoLinesList[i]); break; end; end; end; // если есть райз if (RaiseLine <> nil) then begin RaiseConn := nil; if TConnectorObject(RaiseLine.JoinConnector1).Id <> aObject.ID then RaiseConn := TConnectorObject(RaiseLine.JoinConnector1) else if TConnectorObject(RaiseLine.JoinConnector2).ID <> aObject.Id then RaiseConn := TConnectorObject(RaiseLine.JoinConnector2); if RaiseConn <> nil then // коненктор на втором конце райза begin // если попадаем на вторую вершину райза -- отрываемся if CompareValue(RaiseConn.ActualZOrder[1], aHeight) = 0 then begin // отрыв aObject.JoinedOrthoLinesList.Remove(RaiseLine); // if Raiseconn.JoinedConnectorsList.Count > 0 then DeleteObjectFromPM(aObject.Id, aObject.Name); // создать коннектор ConnectedConn := TConnectorObject.Create(aObject.ActualPoints[1].x, aObject.ActualPoints[1].y, aObject.ActualZOrder[1], aObject.LayerHandle, mydsNormal, GCadForm.PCad); ConnectedConn.ConnectorType := ct_Clear; GCadForm.PCad.AddCustomFigure (GLN(aObject.LayerHandle), ConnectedConn, False); // перекинуть свойства и переименовать коннеткоры (оба) ConnectedConn.Name := aObject.Name; // cCadClasses_Mes12; aObject.Name := cCadClasses_Mes12;; // перекинуть объект if ((RaiseConn.FObjectFromRaise <> nil) and (RaiseConn.FObjectFromRaise.Id = aObject.Id)) then RaiseConn.FObjectFromRaise := ConnectedConn; ConnectedConn.FConnRaiseType := aObject.FConnRaiseType; aObject.FConnRaiseType := Crt_None; ConnectedConn.FObjectFromRaise := aObject.FObjectFromRaise; aObject.FObjectFromRaise := Nil; if RaiseLine.FObjectFromRaisedLine = aObject then RaiseLine.FObjectFromRaisedLine := ConnectedConn; if Raiseconn.JoinedConnectorsList.Count = 0 then SetNewObjectNameInPM(aObject.Id, aObject.Name); SetNewObjectNameInPM(ConnectedConn.ID, ConnectedConn.Name); ObjParams := GetFigureParams(ConnectedConn.ID); ConnectedConn.Name := ObjParams.Name; ConnectedConn.FIndex := ObjParams.MarkID; ConnectedConn.JoinedOrtholinesList.Add(RaiseLine); if TConnectorObject(RaiseLine.JoinConnector1).ID = aObject.ID then TConnectorObject(RaiseLine.JoinConnector1) := ConnectedConn else if TConnectorObject(RaiseLine.JoinConnector2).ID = aObject.ID then TConnectorObject(RaiseLine.JoinConnector2) := ConnectedConn; // все непомеченные трассы - оставить на созданном конекторе (сбросить с текущего) for i := aObject.JoinedOrthoLinesList.Count - 1 downto 1 do begin //if not TOrthoLine(aObject.JoinedOrthoLinesList[i]).selected then //begin SelTrace := TOrthoLine(aObject.JoinedOrthoLinesList[i]); if TConnectorObject(SelTrace.JoinConnector1).id = aObject.Id then begin TConnectorObject(SelTrace.JoinConnector1) := ConnectedConn; AObject.JoinedOrtholinesList.Remove(SelTrace); ConnectedConn.JoinedOrtholinesList.Add(SelTrace); end else if TConnectorObject(SelTrace.JoinConnector2).id = aObject.Id then begin TConnectorObject(SelTrace.JoinConnector2) := ConnectedConn; AObject.JoinedOrtholinesList.Remove(SelTrace); ConnectedConn.JoinedOrtholinesList.Add(SelTrace); end; // end; end; end; end; end; end; end; end; *) end; // если найдет, вернет райз для преобразования в вертикаль + если в результате подъема/спуска трассы // попадем на коннектор спуска/подъема - выставит коннектор для снапа Function CheckConvertRaiseToVLine: TOrthoLine; var i, j: Integer; RaiseLine, TempLine: TOrthoLine; RaiseConn, JoinedNbConn: TConnectorObject; AllTracesMoved: boolean; CanSnapOnRaise: boolean; function CanConvertRaise: Boolean; var i: Integer; begin Result := False; if ((aObject.ConnectorType = ct_clear) and (aObject.JoinedConnectorsList.Count = 0)) then begin for i := 0 to aObject.JoinedOrtholinesList.Count - 1 do begin if (not TOrthoLine(aObject.JoinedOrtholinesList[i]).FIsVertical) and (not TOrthoLine(aObject.JoinedOrtholinesList[i]).FIsRaiseUpDown) and (ATraceList.IndexOf(TOrthoLine(aObject.JoinedOrtholinesList[i])) = -1) then begin Result := True; break; end; end; end else Result := True; end; begin Result := Nil; RaiseLine := Nil; JoinedNbConn := Nil; RaiseConn := Nil; if aObject.JoinedConnectorsList.Count > 0 then begin JoinedNbConn := TConnectorObject(aObject.JoinedConnectorsList[0]); end; // ищем райз // на точечном if JoinedNbConn <> nil then begin for i := 0 to JoinedNbConn.JoinedConnectorsList.Count - 1 do begin for j := 0 to TConnectorObject(JoinedNbConn.JoinedConnectorsList[i]).JoinedOrtholinesList.Count - 1 do begin if TOrthoLine(TConnectorObject(JoinedNbConn.JoinedConnectorsList[i]).JoinedOrtholinesList[j]).FIsRaiseUpDown then begin RaiseLine := TConnectorObject(JoinedNbConn.JoinedConnectorsList[i]).JoinedOrtholinesList[j]; break; end; end; if RaiseLine <> nil then Break; //// BREAK //// end; end else // на коннекторe begin for i := 0 to aObject.JoinedOrtholinesList.Count - 1 do begin if TOrthoLine(aObject.JoinedOrtholinesList[i]).FIsRaiseUpDown then begin RaiseLine := TOrthoLine(aObject.JoinedOrtholinesList[i]); end; end; end; if RaiseLine <> nil then begin // противоположный(от объекта) коннектор райза if ((CompareValue(TConnectorObject(RaiseLine.JoinConnector1).ActualZOrder[1], aObject.ActualZOrder[1]) <> 0) and (TConnectorObject(RaiseLine.JoinConnector1).Id <> aObject.ID)) then RaiseConn := TConnectorObject(RaiseLine.JoinConnector1) else if ((CompareValue(TConnectorObject(RaiseLine.JoinConnector2).ActualZOrder[1], aObject.ActualZOrder[1]) <> 0) and (TConnectorObject(RaiseLine.JoinConnector2).Id <> aObject.ID)) then RaiseConn := TConnectorObject(RaiseLine.JoinConnector2); end; if RaiseConn <> nil then begin // если в результате попадем на уровень второго коннектора райза -- определим коннектор для снапа и вывалимся if CompareValue(RaiseConn.ActualZOrder[1], aHeight) = 0 then begin if RaiseConn.JoinedConnectorsList.Count = 0 then ConnectorToSnap := RaiseConn else if RaiseConn.JoinedConnectorsList.Count > 0 then ConnectorToSnap := TConnectorObject(Raiseconn.JoinedConnectorsList[0]); exit;// -- и нах отсюда end; //если не попадем на уровень второго коннектора райза -- смотрим варианты // если отрываемся от поинта if JoinedNbConn <> nil then begin // если на втором коннектора райза - точечный объект или несколько ортолиний - конвертить однозначно // т.к. мы на него не попадаем if ((RaiseConn.JoinedConnectorsList.Count > 0) or (RaiseConn.JoinedOrtholinesList.Count > 1)) then Result := RaiseLine else begin // тут преобразование, если только двинем в обратную сторону от райза с поинта if DirectionUP then begin if CompareValue(RaiseConn.ActualZOrder[1], aObject.ActualZOrder[1]) = -1 then Result := RaiseLine; end else if DirectionDown then begin if CompareValue(RaiseConn.ActualZOrder[1], aObject.ActualZOrder[1]) = 1 then Result := RaiseLine; end; end; end else // если просто двигаем коннектор ортолинии, не присоединенный к поинту begin if ((aObject.JoinedOrtholinesList.Count > 2) and ((RaiseConn.JoinedConnectorsList.Count > 0) or (RaiseConn.JoinedOrtholinesList.Count > 1))) then Result := RaiseLine else begin // если двинемся от пересечения трасс в обратную от райза сторону // иначе - пох (просто двинем коннектор, а длина райза изменится -- тут таскаем кончик коннектора как хотим, // главное, что не попадаем на сам второй коннектор райза) if aObject.JoinedOrtholinesList.Count > 2 then begin if DirectionUP then begin if CompareValue(RaiseConn.ActualZOrder[1], aObject.ActualZOrder[1]) = -1 then Result := RaiseLine; end else if DirectionDown then begin if CompareValue(RaiseConn.ActualZOrder[1], aObject.ActualZOrder[1]) = 1 then Result := RaiseLine; end; end; end; end; end; if Result <> nil then begin if CanConvertRaise then ConvertRaiseToVertical(Result); exit; end; end; // если найдет, вернет райз для преобразования в вертикаль + если в результате подъема/спуска трассы // попадем на коннектор спуска/подъема - выставит коннектор для снапа {Function CheckConvertRaiseToVLine: TOrthoLine; var i, j: Integer; RaiseLine, TempLine: TOrthoLine; RaiseConn, JoinedNbConn: TConnectorObject; AllTracesMoved: boolean; CanSnapOnRaise: boolean; function GetRaiseConnByDirection(RLine: TOrthoLine): TConnectorObject; begin Result := Nil; // на всякий // если поднимаем трассу if DirectionUP then begin if CompareValue(TConnectorObject(RLine.JoinConnector1).ActualZOrder[1], TConnectorObject(RLine.JoinConnector2).ActualZOrder[1]) = 1 then Result := TConnectorObject(RLine.JoinConnector1) else if CompareValue(TConnectorObject(RLine.JoinConnector1).ActualZOrder[1], TConnectorObject(RLine.JoinConnector2).ActualZOrder[1]) = -1 then Result := TConnectorObject(RLine.JoinConnector2) end else // если опускаем трассу if DirectionDown then begin if CompareValue(TConnectorObject(RLine.JoinConnector1).ActualZOrder[1], TConnectorObject(RLine.JoinConnector2).ActualZOrder[1]) = 1 then Result := TConnectorObject(RLine.JoinConnector2) else if CompareValue(TConnectorObject(RLine.JoinConnector1).ActualZOrder[1], TConnectorObject(RLine.JoinConnector2).ActualZOrder[1]) = -1 then Result := TConnectorObject(RLine.JoinConnector1) end; end; begin Result := Nil; RaiseLine := Nil; // если есть с/п и мы по нему проходим дальше if WayList.Count > 0 then begin for i := 0 to WayList.Count - 1 do begin if TOrthoLine(WayList[i]).FIsRaiseUpDown then begin RaiseLine := TOrthoLine(WayList[i]); RaiseConn := GetRaiseConnByDirection(RaiseLine); if RaiseConn <> nil then begin if TOrthoLine(WayList[i]).FIsRaiseUpDown then begin // если в результате подъема/спуска трассы попадем не вершину С/П - определить коннектор для снапа if CompareValue(RaiseConn.ActualZOrder[1], aHeight) = 0 then begin // на пустой коннектор if RaiseConn.JoinedConnectorsList.Count = 0 then ConnectorToSnap := RaiseConn else // на точечный объект ConnectorToSnap := TConnectorObject(RaiseConn.JoinedConnectorsList[0]); end else // если в результате снапа попадем на с/п (между коннекторами) -- преобразовать в вертикаль однозначно if (((CompareValue(TConnectorObject(RaiseLine.JoinConnector1).ActualZOrder[1], aHeight) = -1) and (CompareValue(TConnectorObject(RaiseLine.JoinConnector2).ActualZOrder[1], aHeight) = 1)) or ((CompareValue(TConnectorObject(RaiseLine.JoinConnector1).ActualZOrder[1], aHeight) = 1) and (CompareValue(TConnectorObject(RaiseLine.JoinConnector2).ActualZOrder[1], aHeight) = -1))) then begin Result := RaiseLine; end else // если есть райз и его нужно перепрыгнуть и добавить вертикаль - преобразовывать однозначно if ((RaiseConn.JoinedConnectorsList.Count > 0) or (RaiseConn.JoinedOrtholinesList.Count > 1)) then begin if ((DirectionUP and (CompareValue(RaiseConn.ActualZOrder[1], aHeight) = -1)) or (DirectionDown and (CompareValue(RaiseConn.ActualZOrder[1], aHeight) = 1))) then Result := RaiseLine; end; end else begin // смотрим возможность двинуть коннектор вертикали if (i = (WayList.Count - 1)) then begin // попадание на вершину if CompareValue(RaiseConn.ActualZOrder[1], AHeight) = 0 then begin ConnectorToSnap := RaiseConn; end else begin if (RaiseConn.JoinedOrtholinesList.Count = 0) and (RaiseConn.JoinedConnectorsList.count = 0) then ConnectorToSnap := RaiseConn; end; end; end; end; end; end; end; if Result <> nil then begin ConvertRaiseToVertical(Result); exit; end; RaiseLine := nil; //просто пустой коннектор (не присоединен к точечному объекту) if aObject.JoinedConnectorsList.Count = 0 then begin for i := 0 to aObject.JoinedOrtholinesList.Count - 1 do begin if TOrthoLine(aObject.JoinedOrtholinesList[i]).FIsRaiseUpDown then begin RaiseLine := TOrthoLine(aObject.JoinedOrtholinesList[i]); if Not AllTracesMoved then begin if DirectionUP then begin if CompareValue(TConnectorObject(RaiseLine.JoinConnector1).ActualZOrder[1], TConnectorObject(RaiseLine.JoinConnector2).ActualZOrder[1]) = 1 then RaiseConn := TConnectorObject(RaiseLine.JoinConnector1) else if CompareValue(TConnectorObject(RaiseLine.JoinConnector1).ActualZOrder[1], TConnectorObject(RaiseLine.JoinConnector2).ActualZOrder[1]) = -1 then RaiseConn := TConnectorObject(RaiseLine.JoinConnector2); end else if DirectionDown then begin end; end; if RaiseLine <> nil then begin Result := RaiseLine; ConvertRaiseToVertical(Result); end; end; end; end else begin JoinedNbConn := TConnectorObject(aObject.JoinedConnectorsList[0]); for i := 0 to JoinedNBConn.JoinedConnectorsList.Count - 1 do begin for j := 0 to TConnectorObject(JoinedNBConn.JoinedConnectorsList[i]).JoinedOrtholinesList.Count - 1 do begin if TOrthoLine(TConnectorObject(JoinedNBConn.JoinedConnectorsList[i]).JoinedOrtholinesList[j]).FIsRaiseUpDown then begin RaiseLine := TOrthoLine(TConnectorObject(JoinedNBConn.JoinedConnectorsList[i]).JoinedOrtholinesList[j]); Result := RaiseLine; ConvertRaiseToVertical(Result); end; end; end; end; end; } Function CheckDeleteVLine(aLine: TOrthoLine): Boolean; var canDelLine: Boolean; LineConn: TConnectorObject; NB_Conn: TConnectorObject; begin Result := False; if not aLine.Deleted then begin if aLine.FisVertical then begin CanDelLine := False; if ((TConnectorObject(aLine.JoinConnector1).JoinedConnectorsList.Count = 0) and (TConnectorObject(aLine.JoinConnector1).JoinedOrtholinesList.Count = 1)) then CanDelLine := True else if ((TConnectorObject(aLine.JoinConnector2).JoinedConnectorsList.Count = 0) and (TConnectorObject(aLine.JoinConnector2).JoinedOrtholinesList.Count = 1)) then CanDelLine := True; if CanDelLine then begin // Сбросить подключение на коннекторах, если нужно LineConn := TConnectorObject(aLine.JoinConnector1); //если ортолиний несколько -- сбросить коннектор нах if LineConn.JoinedOrthoLinesList.Count > 1 then begin LineConn.JoinedOrtholinesList.Remove(aLine); aLine.JoinConnector1 := Nil; end; {else // иначе - если есть точечный объект - оторвать от него if LineConn.JoinedConnectorsList.Count > 0 then begin Nb_Conn := TConnectorObject(LineConn.JoinedConnectorsList[0]); LineConn.JoinedConnectorsList.Remove(NB_Conn); NB_Conn.JoinedConnectorsList.Remove(LineConn); end;} LineConn := TConnectorObject(aLine.JoinConnector2); if LineConn.JoinedOrthoLinesList.Count > 1 then begin LineConn.JoinedOrtholinesList.Remove(aLine); aLine.JoinConnector2 := Nil; end; {else // иначе - если есть точечный объект - оторвать от него if LineConn.JoinedConnectorsList.Count > 0 then begin Nb_Conn := TConnectorObject(LineConn.JoinedConnectorsList[0]); LineConn.JoinedConnectorsList.Remove(NB_Conn); NB_Conn.JoinedConnectorsList.Remove(LineConn); end;} // удалить трассу aLine.delete; Result := True; end; end; end; end; Procedure CollectConnectors; var RaisedLine: TOrthoLine; i: Integer; RaisedLineConnector: TConnectorObject; procedure JoinTwoConnectors; var CanContinue: Boolean; i: Integer; JoinedConn: TConnectorObject; JoinedLine: TOrthoLine; CreatedConn: TConnectorObject; begin // отсоединить от точечного CanContinue := True; // тут отрывать по-любому (от коннектора) While CanContinue do begin CanContinue := False; for i := 0 to RaisedLineConnector.JoinedConnectorsList.Count - 1 do begin JoinedConn := TConnectorObject(RaisedLineConnector.JoinedConnectorsList[i]); JoinedConn.JoinedConnectorsList.Remove(RaisedLineConnector); RaisedLineConnector.JoinedConnectorsList.Remove(JoinedConn); break; CanContinue := True; end; end; // переприсоединить ортолинии CanContinue := True; While CanContinue do begin CanContinue := False; for i := 0 to RaisedLineConnector.JoinedOrtholinesList.Count - 1 do begin JoinedLine := TOrthoLine(RaisedLineConnector.JoinedOrtholinesList[i]); if (ATraceList.IndexOf(JoinedLine) <> -1) and (not JoinedLine.FisVertical) and (not JoinedLine.FIsRaiseUpDown) then begin CanContinue := True; RaisedLineConnector.JoinedOrthoLinesList.Remove(JoinedLine); if TConnectorObject(JoinedLine.JoinConnector1).Id = RaisedLineConnector.ID then JoinedLine.SetJConnector1(aObject) else if TConnectorObject(JoinedLine.JoinConnector2).Id = RaisedLineConnector.ID then JoinedLine.SetJConnector2(aObject); break; end; end; end; end; begin if ATraceList.Count > 1 then begin for i := 0 to ATraceList.count - 1 do begin RaisedLine := TOrthoLine(ATraceList[i]); if aObject.JoinedOrtholinesList.IndexOf(RaisedLine) = -1 then begin if ((not RaisedLine.FIsRaiseUpDown) and (not RaisedLine.FIsVertical)) then begin RaisedLineConnector := TConnectorObject(RaisedLine.JoinConnector1); if ((RaisedLineConnector.ID <> aObject.ID) and (CompareValue(RaisedLineConnector.ActualPoints[1].x, aObject.ActualPoints[1].x) = 0) and (CompareValue(RaisedLineConnector.ActualPoints[1].y, aObject.ActualPoints[1].y) = 0)) then JoinTwoConnectors else begin RaisedLineConnector := TConnectorObject(RaisedLine.JoinConnector2); if ((RaisedLineConnector.ID <> aObject.ID) and (CompareValue(RaisedLineConnector.ActualPoints[1].x, aObject.ActualPoints[1].x) = 0) and (CompareValue(RaisedLineConnector.ActualPoints[1].y, aObject.ActualPoints[1].y) = 0)) then JoinTwoConnectors; end; if RaisedLineConnector.JoinedOrthoLinesList.Count = 1 then begin RaisedLine := TOrthoLine(RaisedLineConnector.JoinedOrthoLinesList[0]); if (RaisedLine.FIsVertical and (TempLineList.IndexOf(RaisedLine) = -1)) then TempLineList.Add(RaisedLine); end; // удалить пустой коннектор if (((RaisedLineConnector.JoinedConnectorsList.Count = 0) and (RaisedLineConnector.JoinedOrtholinesList.Count = 0)) or ((RaisedLineConnector.JoinedConnectorsList.Count = 1) and (RaisedLineConnector.JoinedOrtholinesList.Count = 0))) then RaisedLineConnector.Delete; end; end; end; end; end; Procedure CheckDisJoinConnectorFromVLines(aConnector: TConnectorObject); var i : integer; HasVLines: Boolean; VLine: TOrthoLine; NewConn: TCOnnectorObject; CanContinue: Boolean; isMovingObject: Boolean; vLine1, vLine2: TOrthoLine; CanDisJoin: Boolean; // можно ли сбросить вертикальные трассы с точечного при сдвиге function CanDisJoinVLines(aConn: TConnectorObject): Boolean; var i: Integer; VLinesCount: integer; JoinedVLine: TOrthoLine; VLineConn: TConnectorObject; begin Result := False; VLinesCount := 0; for i := 0 to aConn.JoinedOrthoLinesList.Count - 1 do begin if TOrthoLine(aConn.JoinedOrtholinesList[i]).FIsVertical then begin inc(VLinesCount); JoinedVLine := TOrthoLine(aConn.JoinedOrthoLinesList[i]); end; end; aObjectVLinesCount := VLinesCount; // между двумя вертикалями отрываем однозначно (если это не тот коннектор, который двигаем) if VLinesCount = 2 then begin CanDisJoin := True; if isMovingObject then begin // определяем вертикали VLine1 := Nil; VLine2 := Nil; for i := 0 to aConn.JoinedOrtholinesList.count - 1 do begin if TOrthoLine(aConn.JoinedOrtholinesList[i]).FIsVertical then begin if vLine1 = Nil then VLine1 := TOrthoLine(aConn.JoinedOrtholinesList[i]) else begin if VLine1.Id <> TOrthoLine(aConn.JoinedOrtholinesList[i]).Id then begin VLine2 := TOrthoLine(aConn.JoinedOrtholinesList[i]); break; end; end; end; end; // Попадание на вертикаль 1 if (((CompareValue(TConnectorObject(VLine1.JoinConnector1).ActualZOrder[1], aHeight) = -1) and (CompareValue(TConnectorObject(VLine1.JoinConnector2).ActualZOrder[1], aHeight) = 1)) or ((CompareValue(TConnectorObject(VLine1.JoinConnector2).ActualZOrder[1], aHeight) = -1) and (CompareValue(TConnectorObject(VLine1.JoinConnector1).ActualZOrder[1], aHeight) = 1))) then CanDisJoin := False; // Попадание на вертикаль 2 if CanDisJoin then begin if (((CompareValue(TConnectorObject(VLine2.JoinConnector1).ActualZOrder[1], aHeight) = -1) and (CompareValue(TConnectorObject(VLine2.JoinConnector2).ActualZOrder[1], aHeight) = 1)) or ((CompareValue(TConnectorObject(VLine2.JoinConnector2).ActualZOrder[1], aHeight) = -1) and (CompareValue(TConnectorObject(VLine2.JoinConnector1).ActualZOrder[1], aHeight) = 1))) then CanDisJoin := False; end; if CanDisJoin then Result := True else aObjectVLinesCount := 2; // сыграет при снапе на вертикаль (не будем делать, а просто двинем коннектор на высоту) exit; end else begin Result := True; exit; end; end; if VLinesCount = 1 then begin // если перескакиваем вертикаль - тоже отрываем if WayList.Count > 1 then begin Result := True; exit; end; // в обратную сторону от вертикали и поднимаем не все трассы if (WayList.Count = 0) and (not CanRaiseAllTracesAtOnce) then begin Result := True; exit; end; VLineConn := nil; // попадание на второй коннектор вертикали if TConnectorObject(JoinedVLine.JoinConnector1).ID = aObject.ID then VLineConn := TConnectorObject(JoinedVLine.JoinConnector2) else if TConnectorObject(JoinedVLine.JoinConnector2).ID = aObject.ID then VLineConn := TConnectorObject(JoinedVLine.JoinConnector1); if (VLineConn <> nil) and (CompareValue(VLineConn.ActualZOrder[1], aHeight) = 0) then begin Result := True; exit; end; end; end; begin HasVLines := False; isMovingObject := False; if aConnector.Id = aObject.Id then isMovingObject := True; if aConnector <> nil then begin for i := 0 to aConnector.JoinedOrthoLinesList.Count - 1 do begin if TOrthoLine(aConnector.JoinedOrtholinesList[i]).FIsVertical then begin HasVLines := True; breaK; end; end; end; if HasVLines then begin if ((not isMovingObject) or (isMovingObject and CanDisJoinVLines(aObject))) then begin // оставить пустой коннектор на вертикалях, чтобы не потащить их за собой при снапе на вертикаль // или на точечный NewConn := TConnectorObject.Create(aConnector.ActualPoints[1].x, aConnector.ActualPoints[1].y, aConnector.ActualZOrder[1], aConnector.LayerHandle, mydsNormal, GCadForm.PCad); NewConn.ConnectorType := ct_Clear; GCadForm.PCad.AddCustomFigure (GLN(aConnector.LayerHandle), NewConn, False); NewConn.Name := cCadClasses_Mes12; SetNewObjectNameInPM(NewConn.ID, NewConn.Name); ObjParams := GetFigureParams(NewConn.ID); NewConn.Name := ObjParams.Name; NewConn.FIndex := ObjParams.MarkID; // переконнектить трассы в точке рассоединения от вертикали на новый коннектор CanContinue := True; While CanContinue do begin CanContinue := False; for i := 0 to aConnector.JoinedOrthoLinesList.count - 1 do begin vLine := TOrthoLine(aConnector.JoinedOrtholinesList[i]); if ((VLine.FIsVertical) or (aTraceList.IndexOf(VLine) = -1)) then begin CanContinue := True; aConnector.JoinedOrtholinesList.Remove(VLine); if TConnectorObject(VLine.JoinConnector1).ID = aConnector.ID then begin VLine.SetJConnector1(NewConn); end else if TConnectorObject(VLine.JoinConnector2).ID = aConnector.ID then begin vLine.SetJConnector2(NewConn); end; break; end; end; end; end; end; end; // удалить кабель на пути прохождения коннектора (если идем в обратную сторону от уже проложенных) Procedure DeleteCableFromWay(aConnector: TConnectorObject); Var i, j, k, l: Integer; ComponsToDelList: TList; LineCatalog, JoinedLineCatalog: TSCSCatalog; SCSCompon, JoinedCompon: TSCSComponent; currTrace, JoinedTrace: TOrthoLine; // трасса в ПМ (трасса коннектора и присоединенная, если по ней пошел кабель) CableListToDel: TSCSComponents; // путь следования до точки спуска/подъема Begin if WayList.Count > 0 then begin CableListToDel := TSCSComponents.Create(False); for i := 0 to aConnector.JoinedOrtholinesList.Count - 1 do begin currTrace := TOrthoLine(aConnector.JoinedOrtholinesList[i]); if ATraceList.IndexOf(currTrace) <> -1 then // только для тех трасс, которые будем двигать begin LineCatalog := F_ProjMan.GSCSBase.CurrProject.CurrList.GetCatalogFromReferencesBySCSID(currTrace.ID); if LineCatalog <> nil then begin for j := 0 to LineCatalog.ComponentReferences.Count - 1 do begin SCSCompon := TSCSComponent(LineCatalog.ComponentReferences[j]); if IsCableComponent(SCSCompon) then begin for k := 0 to WayList.Count - 1 do begin JoinedTrace := TOrthoLine(WayList[k]); JoinedLineCatalog := F_ProjMan.GSCSBase.CurrProject.CurrList.GetCatalogFromReferencesBySCSID(JoinedTrace.ID); if JoinedLineCatalog <> nil then begin // предполагаем кабельное соединение 1:1 for l := 0 to JoinedLineCatalog.ComponentReferences.Count - 1 do begin JoinedCompon := TSCSComponent(JoinedLineCatalog.ComponentReferences[l]); if IsCableComponent(JoinedCompon) and (JoinedCompon.Whole_ID = SCSCompon.Whole_ID) then begin CableListToDel.Add(JoinedCompon); break; end; end; end; end; end; end; end; end; end; if CableListToDel.Count > 0 then begin for i := 0 to CableListToDel.Count - 1 do begin SCSCompon := TSCSComponent(CableListToDel[i]); SCSCompon.DisJoinFromAll(true,true).free; end; F_ProjMan.DelComponentsFromList(F_ProjMan.GSCSBase.CurrProject.CurrList, CableListToDel, false); end; FreeAndNil(CableListToDel); end; End; // сбросить подключение кабелей на горизонтальных трассах, если в точках пересечения не все они будут сдвинуты Procedure CheckDisJoinCablesOnConnector; var i, j, k, l: integer; CurrTrace, JoinedTrace : TOrthoLine; LineCatalog, JoinedLineCatalog: TSCSCatalog; CableCompon, JoinedCableCompon: TSCSComponent; DisJoinLineList: TList; PointCatalog: TSCSCatalog; begin { DisJoinLineList := TList.Create; for i := 0 to aObject.JoinedOrthoLinesList.Count - 1 do begin currTrace := TOrthoLine(aObject.JoinedOrtholinesList[i]); if ((ATraceList.IndexOf(currTrace) = -1) and (not CurrTrace.FIsVertical) and (not CurrTrace.FIsRaiseUpDown)) then DisJoinLineList.Add(currTrace); end; if DisJoinLineList.Count > 0 then begin for i := 0 to aObject.JoinedOrthoLinesList.Count - 1 do begin currTrace := TOrthoLine(aObject.JoinedOrthoLinesList[i]); if aTraceList.IndexOf(currTrace) <> -1 then begin LineCatalog := F_ProjMan.GSCSBase.CurrProject.CurrList.GetCatalogFromReferencesBySCSID(currTrace.ID); if LineCatalog <> nil then begin for j := 0 to DisJoinLineList.Count - 1 do begin JoinedTrace := TOrthoLine(DisJoinLineList[j]); JoinedLineCatalog := F_ProjMan.GSCSBase.CurrProject.CurrList.GetCatalogFromReferencesBySCSID(JoinedTrace.ID); if JoinedLineCatalog <> nil then begin for k := 0 to LineCatalog.ComponentReferences.count - 1 do begin CableCompon := TSCSComponent(LineCatalog.ComponentReferences[k]); if IsCableComponent(CableCompon) then begin for l := 0 to JoinedLineCatalog.ComponentReferences.Count - 1 do begin JoinedCableCompon := TSCSComponent(JoinedLineCatalog.ComponentReferences[l]); if (IsCableComponent(JoinedCableCompon) and (CableCompon.JoinedComponents.IndexOf(JoinedCableCompon) <> -1)) then begin while CableCompon.JoinedComponents.IndexOf(JoinedCableCompon) <> -1 do CableCompon.DisJoinFrom(JoinedCableCompon); break; end; end; end; end; end; end; end; end; end; end; FreeAndNil(DisJoinLineList); } end; begin try if ATraceList <> nil then begin // если высота подъема совпадает с высотой коннектора - выход нах if CompareValue(aObject.ActualZOrder[1], aHeight) = 0 then exit; // TempLineList := TList.Create; CanSnapToVertical := False; DirectionUP := False; DirectionDown := False; WayList := TList.Create; HighVConn := nil; LowVConn := Nil; CanSnapToVertical := False; ConnectorToSnap := nil; CreatedConn := Nil; CanDelEmptyLines := True; CanRaiseAllTracesAtOnce := False; // можно ли двинуть все трассы - т.е. сразу передвинуть коннектор aObjectVLinesCount := 0; // направление сдвига от базового положения коннектора (вверх/вниз) if CompareValue(aObject.ActualZOrder[1], aHeight) = -1 then DirectionUP := true else if CompareValue(aObject.ActualZOrder[1], aHeight) = 1 then DirectionDown := True; // приконнекченный НБ, если есть NB_Connector := nil; // -- ищем подходящую вертикаль --- CanLook := True; // стартовый коннектор LastObject := AObject; While CanLook do begin CanLook := False; LookUPDOWN; end; ///**************************************************************************************** // удалить кабели на пути прохождения по вертикали // DeleteCableFromWay(aObject); // отсоединить кабели от трасс, которые не двигаются // CheckDisJoinCablesOnConnector; CanRaiseAllTracesAtOnce := CanRaiseAllTraces(aObject); // сбросить с коннектора те ортолинии, которые не поднимаются RaiseLineToVertical := CheckConvertRaiseToVLine; // if Not CanRaiseAllTracesAtOnce then CreatedConn := ReconnectOnPointbyConn(aObject); // AObject.ActualZOrder[1] := aHeight; if aObject.ConnectorType = ct_Clear then begin j:=0; TempConn := nil; NeedToCreateVLine := False; // проверка на необходимость создания вертикали, если нет коннектора для снапа // и не попадаем на вертикаль if (ConnectorToSnap = nil) and not CanSnapToVertical then // только в этом случае !!! NeedToCreateVLine := CheckNeedToCreateVLine; // RaiseLineToVertical := CheckConvertRaiseToVLine; CanRaiseLine := False; // если объект на коннекторе, то следовало бы оторвать перед тем как двинуть коннектор NB_Connector := nil; for i := 0 to AObject.JoinedConnectorsList.Count - 1 do begin if TConnectorObject(AObject.JoinedConnectorsList[i]).ConnectorType = ct_NB then begin NB_Connector := TConnectorObject(AObject.JoinedConnectorsList[i]); break; end; end; // если есть НБ -- отрываем коннектор if NB_Connector <> nil then begin // оторвать коннектор UnsnapConnectorFromPointObject(AObject, NB_Connector); // присоединить все сдвигаемые трассы к коннектору (чтобы двинуть все сразу и не морочиться потом со снапами) CanDelConnectorsFromPointObject := True; while CanDelConnectorsFromPointObject do begin CanDelConnectorsFromPointObject := False; for i := 0 to NB_Connector.JoinedConnectorsList.Count - 1 do begin JoinedConn := TConnectorObject(NB_Connector.JoinedConnectorsList[i]); if JoinedConn.ID <> aObject.ID then // на всякий, по идее, на анснапе объект должен отвалиться begin for j := 0 to JoinedConn.JoinedOrthoLinesList.Count - 1 do begin JoinedLine := TOrthoLine(JoinedConn.JoinedOrthoLinesList[j]); if (ATraceList.IndexOf(JoinedLine) <> - 1) and (not JoinedLine.FisRaiseUPDown) and (not JoinedLine.FisVertical) then begin CanDelConnectorsFromPointObject := True; JoinedConn.JoinedOrtholinesList.Remove(JoinedLine); if TConnectorObject(JoinedLine.JoinConnector1).ID = JoinedConn.ID then JoinedLine.SetJConnector1(aObject) else if TConnectorObject(JoinedLine.JoinConnector2).ID = JoinedConn.ID then JoinedLine.SetJConnector2(aObject); if aObject.JoinedOrtholinesList.IndexOf(JoinedLine) = -1 then aObject.JoinedOrtholinesList.Add(JoinedLine); //20/04/2017 -- пересчитать длину линии JoinedLine.CalculLength := JoinedLine.LengthCalc; JoinedLine.LineLength := JoinedLine.CalculLength; SetLineFigureLengthInPM(JoinedLine.ID, JoinedLine.LineLength); JoinedLine.UpdateLengthTextBox(True, true); JoinedLine.ReCreateNotesGroup(True); // break; end; end; // пустой коннектор с точечного - нах if (((CreateDConn = nil) and (JoinedConn.JoinedOrtholinesList.Count = 0)) or ((CreateDConn <> nil) and (JoinedConn.ID <> CreatedConn.ID) and (JoinedConn.JoinedOrtholinesList.Count = 0))) then begin NB_Connector.JoinedConnectorsList.Remove(JoinedConn); JoinedConn.JoinedConnectorsList.Remove(NB_Connector); JoinedConn.Delete; break; end; end; end; end; end; begin CheckDisJoinConnectorFromVLines(aObject); // Коннектор на высоту AObject.ActualZOrder[1] := aHeight; // Ортолинии поднять for i := 0 to aObject.JoinedOrtholinesList.Count - 1 do begin JoinedLine := TOrthoLine(aObject.JoinedOrtholinesList[i]); if TConnectorObject(JoinedLine.JoinConnector1).ID = aObject.ID then begin SetLineFigureCoordZInPM(JoinedLine.ID, 1, aObject.ActualZOrder[1]); JoinedLine.ActualZOrder[1] := aObject.ActualZOrder[1]; end else // Tolik 12/11/2020 -- так быстрее будет if TConnectorObject(JoinedLine.JoinConnector2).ID = aObject.ID then begin SetLineFigureCoordZInPM(JoinedLine.ID, 2, aObject.ActualZOrder[1]); JoinedLine.ActualZOrder[2] := aObject.ActualZOrder[1]; end; JoinedLine.CalculLength := JoinedLine.LengthCalc; JoinedLine.LineLength := JoinedLine.CalculLength; SetLineFigureLengthInPM(JoinedLine.ID, JoinedLine.LineLength); JoinedLine.UpdateLengthTextBox(True, true); JoinedLine.ReCreateNotesGroup(True); end; // если попали на коннектор вертикали if ConnectorToSnap <> nil then begin if ((ConnectorToSnap.ConnectorType = ct_Clear) and (ConnectorToSnap.JoinedConnectorsList.Count > 0)) then ConnectorTOSnap := TConnectorObject(ConnectorToSnap.JoinedConnectorsList[0]); if ConnectorToSnap.ConnectorType = ct_NB then // вязать коннекторы без снапа (на всякий, чтобы потом не отсоединять кабеля для выполнения проходящих соединений) begin // SnapConnectorToPointObject(aObject, ConnectorToSnap) if aObject.ConnectorType = ct_clear then begin if aObject.JoinedConnectorsList.IndexOf(ConnectorToSnap) = -1 then aObject.JoinedConnectorsList.Add(ConnectorToSnap); if ConnectorToSnap.JoinedConnectorsList.IndexOf(aObject) = -1 then ConnectorToSnap.JoinedConnectorsList.Add(aObject); // удалить коннектор из ПМ DeleteObjectFromPM(aObject.ID, aObject.Name); end; end else if ConnectorToSnap.ConnectorType = ct_clear then begin // слить коннектора всех поднимаемых трасс в один // CollectConnectors; ConnectorToSnap.ActualZOrder[1] := aHeight; SetConFigureCoordZInPM(ConnectorToSnap.ID, aHeight); for i := 0 to ConnectorToSnap.JoinedOrtholinesList.Count - 1 do begin JoinedLine := TOrthoLine(ConnectorToSnap.JoinedOrtholinesList[i]); if TConnectorObject(JoinedLine.JoinConnector1).ID = ConnectorToSnap.ID then begin SetLineFigureCoordZInPM(JoinedLine.ID, 1, ConnectorToSnap.ActualZOrder[1]); JoinedLine.ActualZOrder[1] := ConnectorToSnap.ActualZOrder[1]; end; if TConnectorObject(JoinedLine.JoinConnector2).ID = ConnectorToSnap.ID then begin SetLineFigureCoordZInPM(JoinedLine.ID, 2, ConnectorToSnap.ActualZOrder[1]); JoinedLine.ActualZOrder[2] := ConnectorToSnap.ActualZOrder[1]; end; JoinedLine.CalculLength := JoinedLine.LengthCalc; JoinedLine.LineLength := JoinedLine.CalculLength; SetLineFigureLengthInPM(JoinedLine.ID, JoinedLine.LineLength); JoinedLine.UpdateLengthTextBox(True, true); JoinedLine.ReCreateNotesGroup(True); end; // переконнектить ортолинии (без снапа коннекторов) for i := (ConnectorToSnap.JoinedOrtholinesList.Count - 1) downto 0 do begin JoinedLine := TOrthoLine(ConnectorToSnap.JoinedOrtholinesList[i]); if TConnectorObject(JoinedLine.JoinConnector1).Id = ConnectorToSnap.Id then //JoinedLine.SetJConnector1(aObject) JoinedLine.JoinConnector1 := aObject else if TConnectorObject(JoinedLine.JoinConnector2).Id = ConnectorToSnap.Id then //JoinedLine.SetJConnector2(aObject); JoinedLine.JoinConnector2 := aObject; if aObject.JoinedOrthoLinesList.IndexOf(JoinedLine) = -1 then aObject.JoinedOrthoLinesList.Add(JoinedLine); //Tolik -- 20/04/2017 -- JoinedLine.CalculLength := JoinedLine.LengthCalc; JoinedLine.LineLength := JoinedLine.CalculLength; SetLineFigureLengthInPM(JoinedLine.ID, JoinedLine.LineLength); JoinedLine.UpdateLengthTextBox(True, true); JoinedLine.ReCreateNotesGroup(True); // // 21/07/2016 -- для райза if JoinedLine.FIsRaiseUpDown then begin if TConnectorObject(JoinedLine.JoinConnector1).Id <> ConnectorToSnap.Id then CreatedConn := TConnectorObject(JoinedLine.JoinConnector1) else if TConnectorObject(JoinedLine.JoinConnector2).ID <> ConnectorToSnap.ID then CreatedConn := TconnectorObject(JoinedLine.JoinConnector2); if (CreateDConn.FObjectFromRaise <> nil) and (CreateDConn.FObjectFromRaise.Id = ConnectorToSnap.Id) then CreatedConn.FObjectFromRaise := aObject; if JoinedLine.FObjectFromRaisedLine = ConnectorToSnap then JoinedLine.FObjectFromRaisedLine := aObject; aObject.FConnRaiseType := ConnectorToSnap.FConnRaiseType; aObject.FObjectFromRaise := ConnectorToSnap.FObjectFromRaise; if ((TConnectorObject(JoinedLine.JoinConnector1).FObjectFromRaise <> nil) and (TConnectorObject(JoinedLine.JoinConnector1).FObjectFromRaise.Id = ConnectorToSnap.Id)) then TConnectorObject(JoinedLine.JoinConnector1).FObjectFromRaise := aObject else if ((TConnectorObject(JoinedLine.JoinConnector2).FObjectFromRaise <> nil) and (TConnectorObject(JoinedLine.JoinConnector2).FObjectFromRaise.Id = ConnectorToSnap.Id)) then TConnectorObject(JoinedLine.JoinConnector2).FObjectFromRaise := aObject; aObject.Name := ConnectorToSnap.Name; DeleteObjectFromPM(ConnectorToSnap.ID, ConnectorToSnap.Name); SetNewObjectNameInPM(aObject.ID, aObject.Name); ConnectorToSnap.FConnRaiseType := crt_None; ConnectorToSnap.FObjectFromRaise := nil; end; end; ConnectorToSnap.JoinedOrtholinesList.Clear; // выравнивание (подтянуть объект/коннектор к точке соединения) // Tolik - -19/04/2017 -- MoveRaiseFlag := GMoveWithRaise; GMoveWithRaise := False; AObject.Move(ConnectorToSnap.ActualPoints[1].x - AObject.ActualPoints[1].x, ConnectorToSnap.ActualPoints[1].y - AObject.ActualPoints[1].y); GMoveWithRaise := MoveRaiseFlag; // ConnectorToSnap.Delete; //SnapConnectorToConnector(AObject, ConnectorTOSnap); end; end else // Если попали на вертикаль if CanSnapToVertical then begin // слить коннектора всех поднимаемых трасс в один // CollectConnectors; {if CanRaiseAllTracesAtOnce then CheckDisJoinConnectorFromVLines(aObject);} if WayList.Count > 0 then begin VertLine := TOrthoLine(WayList[WayList.Count - 1]); // если прыгать с НБ или не все трассы двигать if (((aObject.JoinedOrtholinesList.IndexOf(vertLine) = -1) or (not CanRaiseAllTracesAtOnce)) and (aObjectVLinesCount <> 2)) then SnapConnectorToVertical(aObject, VertLine, true, False); end; end else // Нужно создать вертикаль if NeedToCreateVLine then begin // слить коннектора всех поднимаемых трасс в один // CollectConnectors; CreateVertLineOnHeight; end; end; if not ((aObject.deleted) and (aObject.JoinedConnectorsList.Count = 0)) then SetConFigureCoordZInPM(aObject.ID, aHeight); end // else begin AObject.ActualZOrder[1] := aHeight; if aObject.ConnectorType = ct_Clear then begin for i := 0 to aObject.JoinedOrtholinesList.Count - 1 do begin JoinedLine := aObject.JoinedOrtholinesList[i]; if JoinedLine.JoinConnector1 = aObject then begin SetLineFigureCoordZInPM(JoinedLine.ID, 1, aObject.ActualZOrder[1]); JoinedLine.ActualZOrder[1] := aObject.ActualZOrder[1]; end; if JoinedLine.JoinConnector2 = aObject then begin SetLineFigureCoordZInPM(JoinedLine.ID, 2, aObject.ActualZOrder[1]); JoinedLine.ActualZOrder[2] := aObject.ActualZOrder[1]; end; JoinedLine.CalculLength := JoinedLine.LengthCalc; JoinedLine.LineLength := JoinedLine.CalculLength; SetLineFigureLengthInPM(JoinedLine.ID, JoinedLine.LineLength); JoinedLine.UpdateLengthTextBox(True, true); JoinedLine.ReCreateNotesGroup(True); end; end; end; // удалить ненужные трассы (вертикали, подключенные с одного конца) { for i := 0 to WayList.count - 1 do begin if TempLineList.IndexOf(TOrthoLine(WayList[i])) = -1 then TempLineList.Add(TOrthoLine(WayList[i])); end;} WayList.Clear; FreeAndNil(WayList); {CanLook := True; While CanLook do begin CanLook := False; for i := (TempLineList.Count - 1) downto 0 do begin if CheckDeleteVLine(TOrthoLine(TempLineList[i])) then begin CanLook := True; break; end; end; end;} TempLineList.Clear; FreeAndNil(TempLineList); end else // сюда придем, если просто поднимем коннектор (на райзе) begin // установить новые значения for i := 0 to aObject.JoinedConnectorsList.Count - 1 do begin JoinedConn := aObject.JoinedConnectorsList[i]; JoinedConn.ActualZOrder[1] := aObject.ActualZOrder[1]; for j := 0 to JoinedConn.JoinedOrtholinesList.Count - 1 do begin JoinedLine := JoinedConn.JoinedOrtholinesList[j]; if JoinedLine.JoinConnector1 = JoinedConn then begin SetLineFigureCoordZInPM(JoinedLine.ID, 1, aObject.ActualZOrder[1]); JoinedLine.ActualZOrder[1] := aObject.ActualZOrder[1]; end; if JoinedLine.JoinConnector2 = JoinedConn then begin SetLineFigureCoordZInPM(JoinedLine.ID, 2, aObject.ActualZOrder[1]); JoinedLine.ActualZOrder[2] := aObject.ActualZOrder[1]; end; JoinedLine.CalculLength := JoinedLine.LengthCalc; JoinedLine.LineLength := JoinedLine.CalculLength; SetLineFigureLengthInPM(JoinedLine.ID, JoinedLine.LineLength); JoinedLine.UpdateLengthTextBox(True, true); JoinedLine.ReCreateNotesGroup(True); end; SetConFigureCoordZInPM(JoinedConn.ID, JoinedConn.ActualZOrder[1]); end; SetConFigureCoordZInPM(aObject.ID, aHeight); end; except on E: Exception do AddExceptionToLogEx('U_Common.PutObjectOnHeight', E.Message); end; end; function GetJoinedVerticalObjects(AObject: TFigure; AOnlyConnectorCoordZ: PDouble=nil): TList; var FiguresToFind: TList; NextFiguresToFind: TList; LookedFigures: TList; ConnectedFigures: TList; i: Integer; Figure: TFigure; procedure AddFigureToRes(AFigureToRes: TFigure); begin if (AOnlyConnectorCoordZ = nil) or ((AFigureToRes is TConnectorObject) and (TConnectorObject(AFigureToRes).ActualZOrder[1] = AOnlyConnectorCoordZ^)) then Result.Add(AFigureToRes); end; begin Result := TList.Create; FiguresToFind := TList.Create; NextFiguresToFind := TList.Create; LookedFigures := TList.Create; FiguresToFind.Add(AObject); while FiguresToFind.Count > 0 do begin for i := 0 to FiguresToFind.Count - 1 do begin Figure := TFigure(FiguresToFind[i]); // Если коннектор, или вертикальная трасса if (Figure is TConnectorObject) or ((Figure is TOrthoLine) and (TOrthoLine(Figure).FIsVertical)) then begin AddFigureToRes(Figure); //Result.Add(Figure); // ищем подключенные объекты ConnectedFigures := GetConnectedFigures(Figure, true, LookedFigures); NextFiguresToFind.Assign(ConnectedFigures, laOr); ConnectedFigures.Free; end; LookedFigures.Add(Figure); end; // Следующий набор объектов для поиска FiguresToFind.Assign(NextFiguresToFind, laCopy); NextFiguresToFind.Clear; end; NextFiguresToFind.Free; LookedFigures.Free; FiguresToFind.Free; end; function GetJoinedVerticalConnectorByCoordZ(AStartConnector: TConnectorObject; ACoordZ: Double): TConnectorObject; var Connectors: TList; begin Result := nil; Connectors := GetJoinedVerticalObjects(AStartConnector, @ACoordZ); if Connectors.Count > 0 then if (TObject(Connectors[0]) is TConnectorObject) then Result := TConnectorObject(Connectors[0]); Connectors.Free; end; function GetCADLayerNumByComponIsLine(AIsLine: Integer): Integer; begin Result := lnSCSCommon; if IsArchComponByIsLine(AIsLine) then Result := lnArch; end; procedure DefineCurrLayerByCompon; var Compon: TSCSComponent; begin if (GCadForm <> nil) and (GCadForm.FCreateObjectOnClick = true) then begin Compon := F_NormBase.GetActualSelectedComponent; if Compon <> nil then begin GCadForm.CurrentLayer := GetCADLayerNumByComponIsLine(Compon.IsLine); end; end; end; procedure DropCreateObjectOnClickMode; begin if GCadForm <> nil then // Tolik 11/03/2021 -- GCadform Может и не быть!!! if (GCadForm.FCreateObjectOnClick) then FSCS_Main.aToolSelect.Execute; end; procedure BlockToNormalSize(ABlock: TBlock; AMaxSideSize: Integer); var Bnd: TDoubleRect; w, h: double; PixelsPerMm: Double; PxCount: Double; ZoomOut: Double; CurrMaxSideSize: Double; begin Bnd := ABlock.GetBoundRect; w := abs(Bnd.Right - Bnd.Left); h := abs(Bnd.Bottom - Bnd.Top); // Переводим мм в пиксели w := w * GCadForm.PCad.DotsPerMilOrig; h := h * GCadForm.PCad.DotsPerMilOrig; ////ABlock.ow // // перевести в мм // w := w * GCadForm.PCad.MapScale; // h := h * GCadForm.PCad.MapScale; // // // Переводим мм в пиксели // // PixelsPerInch / 25,4 - количество точек в 1 мм // PixelsPerMm := (GCadForm.PixelsPerInch / 25.4); // w := w * PixelsPerMm; // h := h * PixelsPerMm; // Определяем макс. кол-во пикселей, выходящее за границы CurrMaxSideSize := h; PxCount := h - AMaxSideSize; if PxCount < (w - AMaxSideSize) then begin CurrMaxSideSize := w; PxCount := w - AMaxSideSize; end; if PxCount > 0 then begin // Определяем коэфф. в сколько раз нужно уменьшить ZoomOut := (CurrMaxSideSize - PxCount) / CurrMaxSideSize; //StretchBitmap(ABitmap, Round(ABitmap.Height/ZoomOut), Round(ABitmap.Width/ZoomOut)); ABlock.Scale(ZoomOut, ZoomOut, ABlock.ap1); end; end; procedure Remove3DModelStream; var fFileName: string; //08.09.2011 Buffer: array[0..1023] of Char; TempPath: string; begin try //08.09.2011 SetString(TempPath, Buffer, GetTempPath(Sizeof(Buffer) - 1, Buffer)); //08.09.2011 fFileName := TempPath + '3dmodel.pwd'; fFileName := GetAnsiTempPath + '3dmodel.pwd'; DeleteFile(fFileName); except on E: Exception do AddExceptionToLogEx('U_Common.Remove3DModelStream', E.Message); end; end; // Tolik 06/11/2019 -- //function CreateTraceByPoints(APCAD: TPowerCad; AP1, AP2: TDoublePoint; aPosTraceBetweenPM: boolean = false; aH1: double = 0; aH2: double = 0): TOrtholine; function CreateTraceByPoints(APCAD: TPowerCad; AP1, AP2: TDoublePoint; aPosTraceBetweenPM: boolean = false; aH1: double = 0; aH2: double = 0; aTraceHeight: double = -1): TOrtholine; // var LHandle: Integer; LineHeight: Double; Conn1, Conn2: TConnectorObject; function AddConnector(APoint: PDoublePoint): TConnectorObject; begin Result := TConnectorObject.Create(APoint^.x, APoint^.y, LineHeight, LHandle, mydsNormal, APCAD); Result.ConnectorType := ct_Clear; APCAD.AddCustomFigure(GLN(LHandle), Result, false); //SnapConnectorToOrtholine(Result, Result); SetConnBringToFront(Result); end; begin LHandle := APCAD.GetLayerHandle(lnSCSCommon); // Tolik 06/11/2019 -- // LineHeight := TF_CAD(APCAD.Parent).FLineHeight if aTraceHeight = -1 then LineHeight := TF_CAD(APCAD.Parent).FLineHeight else LineHeight := aTraceHeight; // if aPosTraceBetweenPM then Result := TOrthoLine.Create(AP1.x, AP1.y, aH1, AP2.x, AP2.y, aH2, 1, ord(psSolid), clBlack, 0, LHandle, mydsNormal, APCAD) else Result := TOrthoLine.Create(AP1.x, AP1.y, LineHeight, AP2.x, AP2.y, LineHeight, 1, ord(psSolid), clBlack, 0, LHandle, mydsNormal, APCAD); APCAD.AddCustomFigure(GLN(LHandle), Result, false); APCAD.OrderFigureToFront(TOrtholine(Result).CaptionsGroup); Result.SetJConnector1(AddConnector(@AP1)); Result.SetJConnector2(AddConnector(@AP2)); end; // Tolik 06/11/2019 -- //function CreateTraceByConnectors(aCAD: TF_CAD; aConn1, aConn2: TConnectorObject; aOrthogonally: Boolean=false; aTraceBetweenPM: Boolean = False): TOrtholine; function CreateTraceByConnectors(aCAD: TF_CAD; aConn1, aConn2: TConnectorObject; aOrthogonally: Boolean=false; aTraceBetweenPM: Boolean = False; aOnCadTraceHeight: Boolean = True): TOrtholine; // var ConnIH, ConnH: Double; SelectedList: TList; //MiddlePt: TDoublePoint; MiddleConn: TConnectorObject; Conn1Pt, Conn2Pt: TDoublePoint; // Tolik 07/04/2017 -- SavedFigureSnap: TFigure; // CurListParams: TListParams; // Tolik 06/11/2019 -- begin ConnIH := -100000; ConnH := -100000; if (aConn1.ConnectorType <> ct_Clear) then ConnIH := aConn1.ActualZOrder[1]; if (aConn2.ConnectorType <> ct_Clear) then ConnH := aConn2.ActualZOrder[1]; {if aOrthogonally then begin aOrthogonally := false; // Проверка нужно ли создать ортогональную линию if Not CmpFloatByCP(aConn1.ActualPoints[1].x, aConn2.ActualPoints[1].x) then begin MiddlePt.x := aConn1.ActualPoints[1].x; MiddlePt.y := aConn2.ActualPoints[1].y; aOrthogonally := true; DefinedMiddleX := true; end else if Not CmpFloatByCP(aConn1.ActualPoints[1].y, aConn2.ActualPoints[1].y) then begin MiddlePt.y := aConn1.ActualPoints[1].y; MiddlePt.x := aConn2.ActualPoints[1].x; aOrthogonally := true; end; end;} //if aOrthogonally then //begin // Conn1Pt := aConn1.ActualPoints[1]; // Conn2Pt := aConn2.ActualPoints[1]; //end; // Tolik 06/11/2019 -- { if ((ConnIH = -100000) or (ConnH = -100000)) then Result := CreateTraceByPoints(aCAD.PCad, aConn1.ActualPoints[1], aConn2.ActualPoints[1], False) else Result := CreateTraceByPoints(aCAD.PCad, aConn1.ActualPoints[1], aConn2.ActualPoints[1], True, ConnIH, ConnH); } if aOnCadTraceHeight then begin if ((ConnIH = -100000) or (ConnH = -100000)) then Result := CreateTraceByPoints(aCAD.PCad, aConn1.ActualPoints[1], aConn2.ActualPoints[1], False) else Result := CreateTraceByPoints(aCAD.PCad, aConn1.ActualPoints[1], aConn2.ActualPoints[1], True, ConnIH, ConnH); end else begin if ((ConnIH = -100000) or (ConnH = -100000)) then Result := CreateTraceByPoints(aCAD.PCad, aConn1.ActualPoints[1], aConn2.ActualPoints[1], False, 0, 0, aConn2.ActualZOrder[1]) else Result := CreateTraceByPoints(aCAD.PCad, aConn1.ActualPoints[1], aConn2.ActualPoints[1], True, ConnIH, ConnH, aConn2.ActualZOrder[1]); end; // Tolik 06/11/2019 -- CurListParams := GetListParams(GCadForm.FCADListID); if CurListParams.Settings.CADAutoPosTraceBetweenRM then begin TConnectorObject(Result.JoinConnector1).ActualZOrder[1] := aConn1.ActualZOrder[1]; TConnectorObject(Result.JoinConnector2).ActualZOrder[1] := aConn2.ActualZOrder[1]; end; // // // Tolik -- 20/03/2017 -- тут немножко не так, нужно учесть еще и присоединенные коннекторы // вдруг коннетор прицеплен к точечному объекту, тогда точечный может отторваться { if aConn1.ConnectorType = ct_Clear then // SnapConnectorToConnector(TConnectorObject(Result.JoinConnector1), aConn1) Result.JoinConnector1 := TFigure(SnapConnectorToConnector(TConnectorObject(Result.JoinConnector1), aConn1)) else SnapConnectorToPointObject(TConnectorObject(Result.JoinConnector1), aConn1, False, aTraceBetweenPM); if aConn2.ConnectorType = ct_Clear then // SnapConnectorToConnector(TConnectorObject(Result.JoinConnector2), aConn2) Result.JoinConnector2 := TFigure(SnapConnectorToConnector(TConnectorObject(Result.JoinConnector2), aConn2)) else SnapConnectorToPointObject(TConnectorObject(Result.JoinConnector2), aConn2, False, aTraceBetweenPM); } if aConn1.ConnectorType = ct_Clear then begin if aConn1.JoinedConnectorsList.Count = 0 then // Tolik -- 06/04/2017 -- // Result.JoinConnector1 := TFigure(SnapConnectorToConnector(TConnectorObject(Result.JoinConnector1), aConn1)) begin // Tolik 29/03/2018 -- //aConn1 := SnapConnectorToConnector(TConnectorObject(Result.JoinConnector1), aConn1); // Tolik 06/11/2019 -- CheckingSnapConnectorToConnector(aConn1, TConnectorObject(Result.JoinConnector1)); // //CheckingSnapConnectorToConnector(TConnectorObject(Result.JoinConnector1), aConn1); //Result.JoinConnector2 := TFigure(SnapConnectorToConnector(TConnectorObject(Result.JoinConnector2), aConn2)) //Result.SetJConnector1(TFigure(aConn1)); end else // Tolik -- 11/05/2018 -- //SnapConnectorToPointObject(TConnectorObject(Result.JoinConnector1), TConnectorObject(aConn1.JoinedConnectorsList[0]), False, aTraceBetweenPM); // Tolik 06/11/2019 -- CheckingSnapConnectorToPointObject(TConnectorObject(Result.JoinConnector1), TConnectorObject(aConn1.JoinedConnectorsList[0]), False); //CheckingSnapConnectorToPointObject(TConnectorObject(Result.JoinConnector1), TConnectorObject(aConn1.JoinedConnectorsList[0]), False); // // end else // Tolik -- 11/05/2018 -- // SnapConnectorToPointObject(TConnectorObject(Result.JoinConnector1), aConn1, False, aTraceBetweenPM); CheckingSnapConnectorToPointObject(TConnectorObject(Result.JoinConnector1), aConn1, False); // if aConn2.ConnectorType = ct_Clear then begin if aConn2.JoinedConnectorsList.Count = 0 then // Tolik -- 06/04/2017 -- // Result.JoinConnector2 := TFigure(SnapConnectorToConnector(TConnectorObject(Result.JoinConnector2), aConn2)) begin // Tolik 29/03/2018 -- //aConn2 := SnapConnectorToConnector(TConnectorObject(Result.JoinConnector2), aConn2); // Tolik 06/11/2019 -- CheckingSnapConnectorToConnector(aConn2, TConnectorObject(Result.JoinConnector2)); //CheckingSnapConnectorToConnector(TConnectorObject(Result.JoinConnector2), aConn2); // // //Result.JoinConnector2 := TFigure(SnapConnectorToConnector(TConnectorObject(Result.JoinConnector2), aConn2)) //Result.SetJConnector2(TFigure(aConn2)); end else // Tolik -- 11/05/2018 -- //SnapConnectorToPointObject(TConnectorObject(Result.JoinConnector2), TConnectorObject(aConn2.JoinedConnectorsList[0]), False, aTraceBetweenPM); CheckingSnapConnectorToPointObject(TConnectorObject(Result.JoinConnector2), TConnectorObject(aConn2.JoinedConnectorsList[0]), False); // end else // Tolik -- 11/05/2018 -- //SnapConnectorToPointObject(TConnectorObject(Result.JoinConnector2), aConn2, False, aTraceBetweenPM); CheckingSnapConnectorToPointObject(TConnectorObject(Result.JoinConnector2), aConn2, False); // // NEW FROM OLEG: //06.08.2013 - востановление соединителя после снепа // Олег че то закоментил по итогу {if TConnectorObject(Result.JoinConnector1).JoinedConnectorsList.Count > 0 then if aConn1 <> TConnectorObject(Result.JoinConnector1).JoinedConnectorsList[0] then aConn1 := TConnectorObject(Result.JoinConnector1).JoinedConnectorsList[0]; if TConnectorObject(Result.JoinConnector2).JoinedConnectorsList.Count > 0 then if aConn2 <> TConnectorObject(Result.JoinConnector2).JoinedConnectorsList[0] then aConn2 := TConnectorObject(Result.JoinConnector2).JoinedConnectorsList[0];} //////////// восстановить высоты ИМЕННО объектов к которым прицепили трассу (* Иногда АВ-хи скрытые дает по первому принципу автосоздания трасс *) (* оставим пока так *) //LAST VER - Иногда глючит if Not FileExists(ExeDir + '\NoCorrectZ.ini') then begin // RefreshCAD(GCadForm.PCad); // SetProjectChanged(True); try if (ConnIH <> -100000) and (assigned(aConn1)) then // check //if aConn1.ClassName = 'TConnectorObject' then begin if aConn1.ActualZOrder[1] <> ConnIH then begin ChangeObjZ(aConn1, ConnIH); end; end; except end; try if (ConnH <> -100000) and (assigned(aConn2)) then // check //if aConn2.ClassName = 'TConnectorObject' then begin if aConn2.ActualZOrder[1] <> ConnH then begin ChangeObjZ(aConn2, ConnH); end; end; except end; end; (* пробуем так *) (* так хреново - создает лишние с/п если к примеру уже был с/п if Result.JoinConnector1 <> nil then if TConnectorObject(Result.JoinConnector1).ActualZOrder[1] <> ConnIH then ChangeObjZ(TConnectorObject(Result.JoinConnector1), ConnIH); if Result.JoinConnector2 <> nil then if TConnectorObject(Result.JoinConnector2).ActualZOrder[1] <> ConnH then ChangeObjZ(TConnectorObject(Result.JoinConnector2), ConnH); *) {if (aConn1.ConnectorType <> ct_Clear) and (aConn2.ConnectorType <> ct_Clear) then begin if aConn1.ActualZOrder[1] <> ConnIH then ChangeObjZ(aConn1, ConnIH); if aConn2.ActualZOrder[1] <> ConnH then ChangeObjZ(aConn2, ConnH); end;} //Tolik // Tolik 06/11/2019 -- //if ((not aTraceBetweenPM) or (ConnIH = -100000) or (ConnH = -100000))then if ((not aTraceBetweenPM) and ((ConnIH = -100000) or (ConnH = -100000)))then // begin // if (aCAD.FLineHeight <> Result.ActualZOrder[1]) or (aCAD.FLineHeight <> Result.ActualZOrder[2]) then begin SelectedList := TList.Create; SelectedList.Add(Result); RaiseLineOnHeight(Result, aCAD.FLineHeight, SelectedList); if not GProjectChanged then // Tolik 28/08/2019 -- SetProjectChanged(True); SelectedList.Free; end; end; if aOrthogonally then begin // При автосоздании м-э чаще aConn1=Шк, aConn2=Соед. из м-э Conn1Pt := Result.JoinConnector1.Ap1; Conn2Pt := Result.JoinConnector2.Ap1; if Not CmpFloatByCP(Conn1Pt.x, Conn2Pt.x) and Not CmpFloatByCP(Conn1Pt.y, Conn2Pt.y) then begin MiddleConn := DivideLineSimple(Result); if MiddleConn <> nil then begin //MiddleConn.Move(Conn2Pt.x-MiddleConn.ActualPoints[1].x, Conn1Pt.y-MiddleConn.ActualPoints[1].y); // Tolik -- 07/04/2017 -- Если не сбросить фигуру для снапа, то при передвижении коннектор // автоматически к ней прицепится (например, к шкафу) и будет потом хуйня полная SavedFigureSnap := GFigureSnap; GFigureSnap := nil; // MiddleConn.Move(Conn1Pt.x-MiddleConn.ActualPoints[1].x, Conn2Pt.y-MiddleConn.ActualPoints[1].y); GFigureSnap := SavedFigureSnap; end; end; end; end; function DivTraceOnPt(ATrace: TOrtholine; APt: TDoublePoint; ATraceList: TList): TConnectorObject; var i: Integer; NewConn: TConnectorObject; currTrace: TOrthoLine; begin Result := nil; //29.07.2013 if Not (PointNear(ATrace.ActualPoints[1], APt) or PointNear(ATrace.ActualPoints[2], APt)) then if Not (PointNear(ATrace.ActualPoints[1], APt, 0.3) or PointNear(ATrace.ActualPoints[2], APt, 0.3)) then //if Not (EQDP(ATrace.ActualPoints[1], APt) or EQDP(ATrace.ActualPoints[2], APt)) then begin NewConn := DivideLineSimple(ATrace, @APt); if ATraceList <> nil then begin for i := 0 to NewConn.JoinedOrtholinesList.Count - 1 do begin if TOrtholine(NewConn.JoinedOrtholinesList[i]) <> ATrace then ATraceList.Add(TOrtholine(NewConn.JoinedOrtholinesList[i])); end; end; { for i := ATraceList.Count - 1 downto 0 do begin currTrace := TOrthoLine(aTraceList[i]); if ((not currTrace.FisRaiseUpDown) and (not currTrace.FisVertical)) then begin if CompareValue(currTrace.ActualZOrder[1], currTrace.ActualZOrder[2]) <> 0 then ATraceList.delete(i); end; end; } if aTraceList.Count > 0 then Result := NewConn else Result := nil; end; end; function GetMinConnector(AConn1, AConn2: TConnectorObject): TConnectorObject; var dist1, dist2: Double; begin Result := AConn1; dist1 := GetLineLenght(AConn1.ActualPoints[1], DoublePoint(0,0)); dist2 := GetLineLenght(AConn2.ActualPoints[1], DoublePoint(0,0)); if dist2 < dist1 then Result := AConn2; end; procedure ChangeObjZ(aObject: TConnectorObject; aZ: Double); var i, j: integer; JoinedLine: TOrthoLine; JoinedConn: TConnectorObject; ObjFromRaise: TConnectorObject; ZCoord: Double; mess: string; begin try ZCoord := aZ; // Соединитель ----------------------------------------------------- if aObject.ConnectorType = ct_Clear then begin // Он не с-п и на нем нет с-п if (aObject.FConnRaiseType = crt_None) and (GetRaiseConn(aObject) = nil) then CreateRaiseOnConnector(aObject, ZCoord) else // на нем есть с-п if GetRaiseConn(aObject) <> nil then begin ChangeRaiseOnConnector(aObject, ZCoord); // SP !!! // CheckDeleteAllRaises(GCadForm.PCad); end else // это с-п if (aObject.FConnRaiseType = crt_OnFloor) then begin ObjFromRaise := aObject.FObjectFromRaise; if ZCoord = ObjFromRaise.ActualZOrder[1] then begin mess := cSCSObjectProp_Mes1; //if MessageBoxA(FSCS_Main.Handle, PAnsiChar(mess), cSCSObjectProp_Mes2, MB_YESNO) = IDYes then if MessageBox(FSCS_Main.Handle, PChar(mess), PChar(cSCSObjectProp_Mes2), MB_YESNO) = IDYes then begin if ObjFromRaise.ConnectorType = ct_Clear then DestroyRaiseOnConnector(ObjFromRaise) else DestroyRaiseOnPointObject(ObjFromRaise); end else begin aObject.ActualZOrder[1] := ZCoord; SetConFigureCoordZInPM(aObject.ID, aObject.ActualZOrder[1]);//24.10.2012 end; end else begin aObject.ActualZOrder[1] := ZCoord; SetConFigureCoordZInPM(aObject.ID, aObject.ActualZOrder[1]);//24.10.2012 end; end end else // Объект ---------------------------------------------------------- begin // Он не с-п и на нем нет с-п if (aObject.FConnRaiseType = crt_None) and (GetRaiseConn(aObject) = nil) then begin if aObject.JoinedConnectorsList.Count = 0 then begin aObject.ActualZOrder[1] := ZCoord; SetConFigureCoordZInPM(aObject.ID, ZCoord); end else CreateRaiseOnPointObject(aObject, ZCoord); end else // на нем есть с-п if GetRaiseConn(aObject) <> nil then begin // только подъем-спуск begin if aObject.JoinedConnectorsList.Count = 0 then begin aObject.ActualZOrder[1] := ZCoord; SetConFigureCoordZInPM(aObject.ID, ZCoord); end else begin ChangeRaiseOnPointObject(aObject, ZCoord); // SP !!! // CheckDeleteAllRaises(GCadForm.PCad); end; end; end else // это с-п if (aObject.FConnRaiseType = crt_OnFloor) then begin ObjFromRaise := aObject.FObjectFromRaise; if ZCoord = ObjFromRaise.ActualZOrder[1] then begin mess := cSCSObjectProp_Mes1; //if MessageBoxA(FSCS_Main.Handle, PAnsiChar(mess), cSCSObjectProp_Mes2, MB_YESNO) = IDYes then if MessageBox(FSCS_Main.Handle, PChar(mess), PChar(cSCSObjectProp_Mes2), MB_YESNO) = IDYes then begin if ObjFromRaise.ConnectorType = ct_Clear then DestroyRaiseOnConnector(ObjFromRaise) else DestroyRaiseOnPointObject(ObjFromRaise); end else begin aObject.ActualZOrder[1] := ZCoord; SetConFigureCoordZInPM(aObject.ID, aObject.ActualZOrder[1]);//24.10.2012 end; end else begin aObject.ActualZOrder[1] := ZCoord; SetConFigureCoordZInPM(aObject.ID, aObject.ActualZOrder[1]);//24.10.2012 end; end; end; except on E: Exception do AddExceptionToLogEx('U_Common.ChangeConnZ', E.Message); end; end; function AutoCreateTraces(aSimulate: Boolean=false; aSimulateForAllObj:Boolean=false; aSimulateForAnyTrace: Boolean=false): Integer; var CAD: TF_CAD; Figures: TList; FFigure: TFigure; //ConnI, ConnJ, Conn: TConnectorObject; Conn, ConnTmp: TConnectorObject; Conn1, Conn2: TConnectorObject; //24.06.2013 ConnIH, ConnH: Double; i, j, k: Integer; Traces: TList; Trace: TOrtholine; CanWhile: Boolean; ConnectorsCount: Integer; TraceExsistFromTo: TStringList; idFrom, idTo: string; TestConn: TConnectorObject; NoNearObjectList: TIntList; ProgressCount: integer; // Tolik -- 28/02/2017 -- UserQuotaReached_Message: string; ObjCount: Integer; OldCadFigCount: Integer; OldQuota_Message_Count: Integer; // //24.06.2013 SelectedList: TList; function FindNearObject(AObj: TConnectorObject): TConnectorObject; var CurrConDist, ConnDist: Double; Conn: TConnectorObject; j: Integer; begin Result := nil; ConnDist := 0; // Ищем самый ближний т.о. for j := 0 to Figures.Count - 1 do begin Conn := TConnectorObject(Figures[j]); if Conn <> AObj then begin CurrConDist := GetLineLenght(Conn.ActualPoints[1], AObj.ActualPoints[1]); if (CurrConDist > 0) and ((ConnDist = 0) or (CurrConDist < ConnDist)) then begin //if Conn.Handle > AObj.Handle then //begin // idFrom := inttostr(AObj.Handle); // idTo := inttostr(Conn.Handle); //end //else //begin // idFrom := inttostr(Conn.Handle); // idTo := inttostr(AObj.Handle); //end; //if TraceExsistFromTo.IndexOf(idFrom + '_to_' + idTo) = -1 then begin Traces := GetAllTraceInCAD(Conn, AObj); // Если нету подключения трассами if Traces = nil then begin Result := Conn; ConnDist := CurrConDist; end else begin //TraceExsistFromTo.Values[idFrom + '_to_' + idTo] := '1'; //TraceExsistFromTo.Add(idFrom + '_to_' + idTo); end; FreeAndNil(Traces); end; end; end; end; end; function FiguresCompare(Item1, Item2: Pointer): Integer; var dist1, dist2: Double; begin dist1 := GetLineLenght(TConnectorObject(Item1).ActualPoints[1], DoublePoint(0,0)); dist2 := GetLineLenght(TConnectorObject(Item2).ActualPoints[1], DoublePoint(0,0)); Result := 0; if dist1 < dist2 then Result := -1 else if dist1 > dist2 then Result := 1; end; begin // Tolik 08/11/2019 -- FSCS_Main.Act_ConnectSelectedPointsExecute(nil); exit; // // Tolik -- 08/02/2017 -- Figures := Nil; // Result := 0; // если уже были сообщения о квоте - выход нах if GUserOBjectsQuotaLimit_Message_Counter > 2 then Exit; UserQuotaReached_Message := ''; UserQuotaReached_Message := GetQuotaMessage(CheckUserObjQuotaReached(1),cMess_Quota); if UserQuotaReached_Message <> '' then begin Showmessage(UserQuotaReached_Message); Exit; end; ObjCount := 0; OldCadFigCount := GCadForm.FSCSFigures.Count; OldQuota_Message_Count := GUserOBjectsQuotaLimit_Message_Counter; CAD := GCadForm; if Not aSimulate then begin CAD.SaveForUndo(uat_None, true, False); BeginProgress; end; try {//29.07.2013 Figures := TList.Create; // Формируем список точ. объектов for i := 0 to CAD.PCad.FigureCount - 1 do begin FFigure := TFigure(CAD.PCad.Figures[i]); if CheckFigureByClassName(FFigure, cTConnectorObject) then begin Conn := TConnectorObject(FFigure); if (Conn.ConnectorType = ct_NB) and (Conn.FTrunkName = '') then begin if Conn.Selected or (aSimulate and aSimulateForAllObj) then Figures.Add(FFigure); end; end; end;} Figures := GetConnFiguresForAutoCreateTraces(CAD, aSimulate, aSimulateForAllObj, aSimulateForAnyTrace); Figures.Sort(@FiguresCompare); finally if Not aSimulate then EndProgress; end; try if Figures.Count > 0 then begin TraceExsistFromTo := TStringList.Create; NoNearObjectList := TIntList.Create; if Not aSimulate then // Tolik -- 29/10/2016 -- //BeginProgress('', Figures.Count); begin BeginProgress(cProgress_Mes1, Figures.Count, true); F_Progress.BringToFront; end; // ProgressCount := Figures.Count; try i := 0; while i < Figures.Count do begin Conn := TConnectorObject(Figures[i]); ConnectorsCount := 0; CanWhile := true; while CanWhile do begin Conn1 := Conn; //if NoNearObjectList.IndexOf(Conn.Handle) = -1 then //begin Conn2 := FindNearObject(Conn); // if Conn2 = nil then // NoNearObjectList.Add(Conn.Handle); //end //else // Conn2 := nil; if Conn2 <> nil then begin // Если у найденного ближнего объекта есть более ближний объект, то ничего не соединяем //if NoNearObjectList.IndexOf(Conn2.Handle) = -1 then //begin ConnTmp := FindNearObject(Conn2); // if (ConnTmp = nil) then // NoNearObjectList.Add(Conn2.Handle); //end //else // ConnTmp := nil; //if (ConnTmp <> nil) and (ConnTmp <> Conn2) then if (ConnTmp <> nil) and (ConnTmp <> Conn2) and (ConnTmp <> Conn1) then if GetLineLenght(Conn2.ActualPoints[1], ConnTmp.ActualPoints[1]) < GetLineLenght(Conn2.ActualPoints[1], Conn1.ActualPoints[1]) then begin Conn2 := nil; //Conn1 := ConnTmp; // Перемещаем объект Conn в конец списка Figures.Delete(i); Figures.Add(Conn); i := i - 1; Break; //// BREAK //// end; end; if Conn2 <> nil then begin Result := Result + 1; if Not aSimulate then begin {//24.06.2013 - moved to CreateTraceByConnectors ConnIH := Conn1.ActualZOrder[1]; ConnH := Conn2.ActualZOrder[1]; Trace := CreateTraceByPoints(CAD.PCad, Conn1.ActualPoints[1], Conn2.ActualPoints[1]); SnapConnectorToPointObject(TConnectorObject(Trace.JoinConnector1), Conn1); SnapConnectorToPointObject(TConnectorObject(Trace.JoinConnector2), Conn2); // 19.06.2013 IGOR // так кривовато //if CAD.FLineHeight <> ConnIH then // CreateRaiseOnPointObject(Conn1, CAD.FLineHeight, TConnectorObject(Trace.JoinConnector1)); //if CAD.FLineHeight <> ConnH then // CreateRaiseOnPointObject(Conn2, CAD.FLineHeight, TConnectorObject(Trace.JoinConnector2)); // 19.06.2013 IGOR // Лучше сделаем так if Conn1.ActualZOrder[1] <> ConnIH then ChangeObjZ(Conn1, ConnIH); if Conn2.ActualZOrder[1] <> ConnH then ChangeObjZ(Conn2, ConnH); if (CAD.FLineHeight <> Trace.ActualZOrder[1]) or (CAD.FLineHeight <> Trace.ActualZOrder[2]) then begin SelectedList := TList.Create; SelectedList.Add(Trace); RaiseLineOnHeight(Trace, CAD.FLineHeight, SelectedList); SetProjectChanged(True); SelectedList.Free; end; // 19.06.2013 IGOR} Trace := CreateTraceByConnectors(CAD, Conn1, Conn2); //24.06.2013 ConnectorsCount := ConnectorsCount + 1; // Tolik -- 28/02/2017 -- проверка на превышение квоты USER Objects ObjCount := Cad.FSCSFigures.Count - OldCadFigCount; if ObjCount > 49 then begin UserQuotaReached_Message := ''; UserQuotaReached_Message := GetQuotaMessage(CheckUserObjQuotaReached(1),cMess_Quota); if UserQuotaReached_Message <> '' then begin PauseProgress(True); Showmessage(UserQuotaReached_Message); PauseProgress(False); Break; //// BREAK ////; end else OldCadFigCount := Cad.FSCSFigures.Count; end; // { if Conn1.Handle > Conn2.Handle then begin idFrom := inttostr(Conn2.Handle); idTo := inttostr(Conn1.Handle); end else begin idFrom := inttostr(Conn1.Handle); idTo := inttostr(Conn2.Handle); end; if TraceExsistFromTo.IndexOf(idFrom + '_to_' + idTo) = -1 then TraceExsistFromTo.Add(idFrom + '_to_' + idTo); //Добавить все имеющиеся подключения с обеих коннекторов... for k := 0 to Figures.Count - 1 do begin TestConn := TConnectorObject(Figures[k]); // найти в списке другие подключения от коннектора Conn2 if TestConn <> Conn2 then begin if TestConn.Handle > Conn2.Handle then begin idFrom := inttostr(Conn2.Handle); idTo := inttostr(TestConn.Handle); end else begin idFrom := inttostr(TestConn.Handle); idTo := inttostr(Conn2.Handle); end; if TraceExsistFromTo.IndexOf(idFrom + '_to_' + idTo) <> -1 then begin if TestConn.Handle > Conn1.Handle then begin idFrom := inttostr(Conn1.Handle); idTo := inttostr(TestConn.Handle); end else begin idFrom := inttostr(TestConn.Handle); idTo := inttostr(Conn1.Handle); end; if TraceExsistFromTo.IndexOf(idFrom + '_to_' + idTo) = -1 then TraceExsistFromTo.Add(idFrom + '_to_' + idTo); end; end; // найти в списке другие подключения от коннектора Conn1 if TestConn <> Conn1 then begin if TestConn.Handle > Conn1.Handle then begin idFrom := inttostr(Conn1.Handle); idTo := inttostr(TestConn.Handle); end else begin idFrom := inttostr(TestConn.Handle); idTo := inttostr(Conn1.Handle); end; if TraceExsistFromTo.IndexOf(idFrom + '_to_' + idTo) <> -1 then begin if TestConn.Handle > Conn2.Handle then begin idFrom := inttostr(Conn2.Handle); idTo := inttostr(TestConn.Handle); end else begin idFrom := inttostr(TestConn.Handle); idTo := inttostr(Conn2.Handle); end; if TraceExsistFromTo.IndexOf(idFrom + '_to_' + idTo) = -1 then TraceExsistFromTo.Add(idFrom + '_to_' + idTo); end; end; end; } end else begin if aSimulateForAnyTrace then //Tolik 16/11/2020 -- begin TraceExsistFromTo.Free; NoNearObjectList.Free; Exit ///// EXIT ///// /// end else begin Figures.Delete(i); Figures.Add(Conn); i := i - 1; Break; //// BREAK //// end; end; end else begin //Application.ProcessMessages; // Tolik 07/11/2019 -- закомментил, потому, что, во-первых, это - ужасный тормоз (здесь), //а во-вторых, если оставить, то на дебаге вообще виснет намертво... и дальше не идет. CanWhile := false; if Not aSimulate then begin if (i mod 2) = 0 then begin Dec(ProgressCount); if ProgressCount > 0 then // Tolik 29/10/2016 -- //StepProgress; StepProgressRE; end; end; end; end; // Tolik -- 28/02/2017 -- превышение квоты if OldQuota_Message_Count <> GUserOBjectsQuotaLimit_Message_Counter then Break; //// BREAK ////; if ConnectorsCount > 0 then if Not aSimulate then begin Dec(ProgressCount); if ProgressCount > 0 then // Tolik 29/10/2016 -- // StepProgress; StepProgressRE; // end; i := i + 1; end; finally if Not aSimulate then EndProgress; end; FreeAndNil(TraceExsistFromTo); FreeAndNil(NoNearObjectList); end; finally // Tolik -- 08/02/2017 -- if Figures <> nil then Figures.Free; end; end; // каждый объект своей трассой function AutoCreateTracesParallel(aSrcFigure: TFigure; aSimulate: Boolean=false; aSimulateForAllObj:Boolean=false; aSimulateForAnyTrace: Boolean=false): Integer; var CAD: TF_CAD; Figures: TList; FFigure: TFigure; Conn: TConnectorObject; i: Integer; Trace: TOrtholine; // Tolik -- 28/02/2017 -- UserQuotaReached_Message: string; ObjCount: Integer; OldCadFigCount: Integer; // ObjectToTrace: TConnectorObject;// Tolik 07/11/2019 -- CantConnectObjectToTrace, CantConnectConn: Boolean; Catalog1, Catalog2: TSCSCatalog; TraceList: TList; function FiguresCompare(Item1, Item2: Pointer): Integer; var dist1, dist2: Double; begin dist1 := GetLineLenght(TConnectorObject(Item1).ActualPoints[1], DoublePoint(0,0)); dist2 := GetLineLenght(TConnectorObject(Item2).ActualPoints[1], DoublePoint(0,0)); Result := 0; if dist1 < dist2 then Result := -1 else if dist1 > dist2 then Result := 1; end; function GetObjFromSelection(aSName: String): TConnectorObject; var i, j: integer; SCSList: TSCSList; SCSCatalog: TSCSCatalog; SCSCompon: TSCSComponent; begin Result := nil; for i := 0 to GCadForm.PCad.Selection.Count - 1 do begin if TFigure(GCadForm.PCad.Selection[i]) is TConnectorObject then begin if TConnectorObject(GCadForm.PCad.Selection[i]).ConnectorType = ct_NB then begin SCSCatalog := F_ProjMan.GSCSBase.CurrProject.CurrList.GetCatalogFromReferencesBySCSID(TConnectorObject(GCadForm.PCad.Selection[i]).ID); if SCSCatalog <> nil then begin SCSCompon := SCSCatalog.GetFirstComponent; if SCSCompon <> nil then begin if SCSCompon.ComponentType.SysName = aSName then Result := TConnectorObject(GCadForm.PCad.Selection[i]); if GisDrop then begin if SCScompon.IDNetType <> GDropComponent.IDNetType then Result := nil; end; end; end; end; end; if Result <> nil then break; end; end; begin Result := 0; // если уже были сообщения о квоте - выход нах if GUserOBjectsQuotaLimit_Message_Counter > 2 then Exit; UserQuotaReached_Message := ''; UserQuotaReached_Message := GetQuotaMessage(CheckUserObjQuotaReached(1),cMess_Quota); if UserQuotaReached_Message <> '' then begin Showmessage(UserQuotaReached_Message); Exit; end; OldCadFigCount := GCadForm.FSCSFigures.Count; //Tolik 07/11/2019 -- ObjectToTrace := nil; if aSrcFigure <> nil then if checkFigureByClassName(aSrcFigure, cTConnectorObject) then if not TConnectorObject(aSrcFigure).deleted then if TConnectorObject(aSrcFigure).ConnectorType = ct_NB then // не пропустить пустой коннектор ObjectToTrace := TConnectorObject(aSrcFigure); //Tolik 18/02/2022 -- здесь, если нет фигуры, к которой нужно трассировать, тогда попытаемся или к конечному // объекту (что было бы логично) или к первому попавшемуся шкафу, чтобы не было создания трасс, // например, к первой попавшейся розетке от шкафа в том числе ... if ObjectToTrace = nil then // если есть конечный объект begin if GListWithEndPoint = GCadForm then begin if GEndPoint <> nil then begin if CheckFigureByClassName(GEndPoint, cTConnectorObject) then ObjectToTrace := TConnectorObject(GEndPoint); end; end; end; //если нет конечного, но есть шкаф (или, на крайний случай, щиток) if ObjectToTrace = nil then begin // если кидаем кабель - нужно понять какой тип сети... если электрика - будем искать щиток, // если комп сеть - будем искать шкаф if (GisDrop = true) and (GDropComponent <> nil) and (isCableComponent(GDropComponent) = true) then begin if GDropComponent.IDNetType = 3 then ObjectToTrace := GetObjFromSelection(ctsnShield) else ObjectToTrace := GetObjFromSelection(ctsnCupboard); end else // если хз, то все равно шкаф... begin ObjectToTrace := GetObjFromSelection(ctsnCupboard); end; end; // { if GListWithEndPoint = GCadForm then if GEndPoint <> nil then if CheckFigureByClassName(GEndPoint, cTConnectorObject) then ObjectToTrace := TConnectorObject(GEndPoint); } //if aSrcFigure <> nil then //if objectToTrace <> nil then // if CheckFigureByClassName(aSrcFigure, cTConnectorObject) then // begin CAD := GCadForm; if Not aSimulate then begin CAD.SaveForUndo(uat_None, true, False); BeginProgress; end; try Figures := TList.Create; // Формируем список точ. объектов // Tolik -- 28/06/2016 -- //for i := 0 to CAD.PCad.FigureCount - 1 do for i := 0 to CAD.FSCSFigures.Count - 1 do // begin FFigure := TFigure(CAD.FSCSFigures[i]); // Tolik 07/11/2019 -- //if (FFigure <> aSrcFigure) and CheckFigureByClassName(FFigure, cTConnectorObject) then if (FFigure <> TFigure(ObjectToTrace)) and CheckFigureByClassName(FFigure, cTConnectorObject) then // begin Conn := TConnectorObject(FFigure); if (Conn.ConnectorType = ct_NB) and (Conn.FTrunkName = '') then begin if Conn.Selected or (aSimulate and aSimulateForAllObj) then Figures.Add(FFigure); end; end; end; // Tolik -- 12/11/2019 -- здесь так: если есть конечный объект на листе и он выбран, то трассируем к нему, // если не выбран конечный объект, даже если он есть на листе -- трассировать к тому, на котором кликнули if GListWithEndPoint = GCadForm then if GEndPoint <> nil then if CheckFigureByClassName(GEndPoint, cTConnectorObject) then if TConnectorObject(GEndPoint).Selected then begin ObjectToTrace := TConnectorObject(GEndPoint); // не потерять фигуру с клика if CheckFigureByClassName(aSrcFigure, cTConnectorObject) then if TConnectorObject(aSrcFigure).ConnectorType = ct_NB then // не пропустить пустой коннектор if aSrcFigure <> ObjectToTrace then if Figures.IndexOf(aSrcFigure) = -1 then Figures.Add(aSrcFigure); end; // Figures.Sort(@FiguresCompare); if Figures.Count > 0 then if ObjectToTrace = nil then // если клик произошел на пустом коннекторе и нет конечного объекта в выбранных // определяем первый объект из списка для трассировки к нему begin ObjectToTrace := TConnectorObject(Figures[0]); Figures.delete(0); end; finally if Not aSimulate then EndProgress; end; if Figures.Count > 0 then begin if Not aSimulate then //Tolik -- 29/10/2016 -- //BeginProgress('', Figures.Count); begin BeginProgress(cProgress_Mes1, Figures.Count, true); F_Progress.BringToFront; end; // try // Tolik 08/11/2019 -- if GUseVerticalTraces = False then CantConnectObjectToTrace := CheckCanDrawOneTrace(ObjectToTrace); Catalog1 := F_ProjMan.GSCSBase.CurrProject.CurrList.GetCatalogFromReferencesBySCSID(ObjectToTrace.ID); // for i := 0 to Figures.Count - 1 do begin Conn := TConnectorObject(Figures[i]); // Tolik 08/11/2019 -- //Trace := CreateTraceByConnectors(CAD, TConnectorObject(aSrcFigure), Conn); if GUseVerticalTraces = False then begin CantConnectConn := CheckCanDrawOneTrace(Conn); if (CantConnectConn or CantConnectObjectToTrace) then begin Catalog2 := F_ProjMan.GSCSBase.CurrProject.CurrList.GetCatalogFromReferencesBySCSID(Conn.ID); if Catalog1 <> nil then if Catalog2 <> nil then GCadForm.mProtocol.Lines.Add(CantConnMess1 + Catalog1.GetNameForVisible(false) + CantConnMess2 + Catalog2.GetNameForVisible(false) + CantConnMess4); Trace := Nil; end else begin // проверить на наличие трасс между объектами TraceList := GetAllTraceInCAD(TFigure(ObjectToTrace), TFigure(Conn)); if TraceList = nil then Trace := CreateTraceByConnectors(CAD, ObjectToTrace, Conn) else begin Catalog2 := F_ProjMan.GSCSBase.CurrProject.CurrList.GetCatalogFromReferencesBySCSID(Conn.ID); if Catalog1 <> nil then if Catalog2 <> nil then GCadForm.mProtocol.Lines.Add(CantConnMess1 + Catalog1.GetNameForVisible(false) + CantConnMess2 + Catalog2.GetNameForVisible(false) + CantConnMess3); Trace := nil; FreeAndNil(TraceList); end; end; end else begin // проверить на наличие трасс между объектами TraceList := GetAllTraceInCAD(TFigure(ObjectToTrace), TFigure(Conn)); if TraceList = nil then Trace := CreateTraceByConnectors(CAD, ObjectToTrace, Conn) else begin Catalog2 := F_ProjMan.GSCSBase.CurrProject.CurrList.GetCatalogFromReferencesBySCSID(Conn.ID); if Catalog1 <> nil then if Catalog2 <> nil then GCadForm.mProtocol.Lines.Add(CantConnMess1 + Catalog1.GetNameForVisible(false) + CantConnMess2 + Catalog2.GetNameForVisible(false) + CantConnMess3); Trace := nil; TraceList.Clear; FreeAndNil(TraceList); end; end; // if Trace <> nil then begin Inc(Result); // Tolik -- 28/02/2017 -- проверка на превышение квоты USER Objects ObjCount := Cad.FSCSFigures.Count - OldCadFigCount; if ObjCount > 49 then begin UserQuotaReached_Message := ''; UserQuotaReached_Message := GetQuotaMessage(CheckUserObjQuotaReached(1),cMess_Quota); if UserQuotaReached_Message <> '' then begin PauseProgress(True); Showmessage(UserQuotaReached_Message); PauseProgress(False); Break; //// BREAK ////; end else OldCadFigCount := Cad.FSCSFigures.Count; end; // end; // Tolik -- 29/10/2016-- if Not aSimulate then StepProgressRE else StepProgress; end; finally Figures.Free; if Not aSimulate then EndProgress; end; end; end; end; function AutoCreateTracesToTraceList(aTraces: TList; aSimulate: Boolean=false; aSimulateForAllObj:Boolean=false; aSimulateForAnyTrace: Boolean=false): Integer; const ptDelta = 0.3; var TraceList: TList; CAD: TF_CAD; ConnFigures: TList; Conn1, Conn2: TConnectorObject; i, j, k: Integer; IsOrthoTrace: Boolean; // Tolik 26/10/2016 -- CreatedTrace: TOrthoLine; TempLine: TOrthoLine; BetweenConnectorsTraceList: TList; ConnectionPoint: TConnectorObject; // точка подключения шкафа к трассе (нужна для проверки наличия предполагаемого соединения) CheckedTraceList: TList; SavedProgressState: Boolean; SavedProgressCount: integer; // Tolik -- 28/02/2017 -- для проверки превышения квоты USER Objects UserQuotaReached_Message: string; ObjCount: Integer; OldCadFigCount: Integer; RaiseConnector: TConnectorObject; connDist1, connDist2: Double; CadRefreshFlag: Boolean; TempConn: TConnectorObject; BeforeTracingSCSFiguresCount: Integer; // 19/04/2017 -- Tolik CurListParams: TListParams; // Tolik 06/11/2019 -- // // function getNextRaiseConnFromPointObj(aObj: TConnectorObject): TConnectorObject; var i, j: Integer; RaiseLine: TOrthoLine; JoinedConn: TConnectorObject; begin Result := nil; RaiseLine := nil; for i := 0 to aObj.JoinedConnectorsList.Count - 1 do begin JoinedConn := TConnectorObject(aObj.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]); if TConnectorObject(RaiseLine.JoinConnector1).ID = JoinedConn.ID then Result := TConnectorObject(RaiseLine.JoinConnector2) else if TConnectorObject(RaiseLine.JoinConnector2).ID = JoinedConn.ID then Result := TConnectorObject(RaiseLine.JoinConnector1); Break; //// BREAK ////; end; end; if Result <> nil then Break; //// BREAK ////; end; end; function IsNearPt(aPt1, aPt2: TDoublePoint; var aNearDist, aCurrDist: Double): Boolean; begin Result := false; aCurrDist := GetLineLenght(aPt1, aPt2); // Tolik -- 17/03/2017 -- // if (aCurrDist > 0) and ((aNearDist = 0) or (aCurrDist < aNearDist)) then // если расстояние = 0 то, объект может быть точно над/под трассой !!! if ((aCurrDist > 0) and ((aNearDist = 0) or (aCurrDist < aNearDist))) or (aCurrDist = 0) then //if CompareValue(aCurrDist, aNearDist) = 1 then // begin aNearDist := aCurrDist; Result := true; end; end; // Tolik 26/10/2016 -- function FindNearObject(AObj: TConnectorObject; aServerTrace: TOrthoLine = nil): TConnectorObject; // var CurrConDist, ConnDist: Double; CrossPtTrace: TOrtholine; CrossPt, CurrCrossPt: TDoublePoint; Trace: TOrtholine; NewTraces: TList; //Conn: TConnectorObject; i: Integer; currTraceList: TList; // Tolik distToCrossLine: Double; PathList: TList; // //Tolik 08/02/2022 -- выкинуть лишние боъекты из трассировки (т.е., шкаф, если к нему есть трасса, // чтобы он сам не коннектился хер знает куда, а также те объекты, которые уже имеют подключение к шкафу -- ибо нех...) function CheckObjToConnect: Boolean; var traceList: TList; i: integer; begin Result := True; if GEndPoint <> nil then begin if aObj.AsEndPoint then begin for i := 0 to aObj.JoinedConnectorsList.Count - 1 do begin if TConnectorObject(aObj.JoinedConnectorsList[i]).JoinedOrtholinesList.Count > 0 then begin Result := False; break; end; end; end else begin TraceList := GetAllTraceInCad(GEndPoint, aObj); if TraceList <> nil then begin Result := False; TraceList.Free; end; end; end; end; // Tolik -- 26/10/2016 -- function CheckCanConnectToServer(aTrace: TOrthoLine): Boolean; var TraceList: TList; begin // Tolik 07/02/2017 -- TraceList := nil; // Result := False; if (aTrace.Id = aServerTrace.Id) or (CheckedTraceList.IndexOf(aTrace) <> -1) then Result := True else begin if (aServerTrace.JoinConnector1 <> nil) and (not TConnectorObject(aServerTrace.JoinConnector1).deleted) then begin if (aTrace.JoinConnector1 <> nil) then begin TraceList := GetAllTraceInCAD(TConnectorObject(aServerTrace.JoinConnector1), TConnectorObject(aTrace.JoinConnector1)); if TraceList <> nil then begin Result := True; CheckedTraceList.Add(aTrace); FreeAndNil(TraceList); end; end else if (aTrace.JoinConnector2 <> nil) then begin TraceList := GetAllTraceInCAD(TConnectorObject(aServerTrace.JoinConnector1), TConnectorObject(aTrace.JoinConnector2)); if TraceList <> nil then begin Result := True; CheckedTraceList.Add(aTrace); FreeAndNil(TraceList); end; end; end else if (aServerTrace.JoinConnector2 <> nil) and (not TConnectorObject(aServerTrace.JoinConnector2).deleted) then begin if (aTrace.JoinConnector1 <> nil) then begin TraceList := GetAllTraceInCAD(TConnectorObject(aServerTrace.JoinConnector2), TConnectorObject(aTrace.JoinConnector1)); if TraceList <> nil then begin Result := True; CheckedTraceList.Add(aTrace); FreeAndNil(TraceList); end; end else if (aTrace.JoinConnector2 <> nil) then begin TraceList := GetAllTraceInCAD(TConnectorObject(aServerTrace.JoinConnector2), TConnectorObject(aTrace.JoinConnector2)); if TraceList <> nil then begin Result := True; CheckedTraceList.Add(aTrace); FreeAndNil(TraceList); end; end; end end; // Tolik 07/02/2017 -- if TraceList <> nil then FreeAndNil(TraceList); // end; // function CheckNoPath(aTrace: TOrthoLine): Boolean; var PathList: TList; begin Result := True; PathList := GetAllTraceInCad(TFigure(aObj), aTrace.JoinConnector1); if PathList <> nil then begin FreeAndNil(PathList); Result := False; end else begin PathList := GetAllTraceInCad(TFigure(aObj), aTrace.JoinConnector2); if PathList <> nil then begin FreeAndNil(PathList); Result := False; end; end; end; begin Result := nil; if CheckObjToConnect then begin ConnDist := 0; CrossPtTrace := nil; CurrTraceList := TList.Create; distToCrossLine := 0; for i := 0 to TraceList.Count - 1 do //Tolik -- 06/12/2016 -- вот така вот бывает наебка.... if checkFigureByClassNAme(TFigure(TraceList[i]), cTOrthoLine) then CurrTraceList.Add(TraceList[i]); //Tolik 01/02/2022 -- Это сбрасываем, на шкафу трасса может присутствовать { for i := CurrTraceList.Count - 1 downto 0 do begin Trace := TOrthoLine(CurrTraceList[i]); if (aServerTrace <> nil) and (not CheckCanConnectToServer(Trace)) then currTraceList.remove(Trace); end; } // Ищем самую ближнюю часть трассы i := 0; While (Result = nil) and (CrossPtTrace = nil) do begin while i < CurrTraceList.Count do begin Trace := TOrtholine(CurrTraceList[i]); //Tolik 01/02/2022 -- if CheckNoPath(Trace) then begin if Trace.JoinConnector1 <> nil then if IsNearPt(Trace.JoinConnector1.ActualPoints[1], AObj.ActualPoints[1], ConnDist, CurrConDist) then begin // Tolik 18/03/2017 -- //Result := TConnectorObject(Trace.JoinConnector1); //CrossPtTrace := nil; if CrossPtTrace = nil then Result := TConnectorObject(Trace.JoinConnector1) else if CompareValue(distToCrossLine, ConnDist) > -1 then begin Result := TConnectorObject(Trace.JoinConnector1); CrossPtTrace := nil; end; // end; if Trace.JoinConnector2 <> nil then if IsNearPt(Trace.JoinConnector2.ActualPoints[1], AObj.ActualPoints[1], ConnDist, CurrConDist) then begin // Tolik 18/03/2017 -- //Result := TConnectorObject(Trace.JoinConnector1); //CrossPtTrace := nil; if CrossPtTrace = nil then Result := TConnectorObject(Trace.JoinConnector2) else if CompareValue(distToCrossLine, ConnDist) > -1 then begin Result := TConnectorObject(Trace.JoinConnector2); CrossPtTrace := nil; end; // end; CurrCrossPt := AObj.ActualPoints[1]; PointToLineByAngle(Trace.ActualPoints[1], Trace.ActualPoints[2], CurrCrossPt); // Если точка пересечения не рядом, тогда расматриваем ее для создания трассы if isPointinLine(Trace.ActualPoints[1], Trace.ActualPoints[2], CurrCrossPt, 0, 0.1) then if (GetLineLength(Trace.ActualPoints[1], CurrCrossPt) >= ptDelta) and (GetLineLength(Trace.ActualPoints[2], CurrCrossPt) >= ptDelta) then if IsNearPt(CurrCrossPt, AObj.ActualPoints[1], ConnDist, CurrConDist) then begin Result := nil; CrossPtTrace := Trace; CrossPt := CurrCrossPt; distToCrossLine := ConnDist; end; end; Inc(i); end; if (Result = nil) and (CrossPtTrace <> nil) then begin NewTraces := TList.Create; Result := DivTraceOnPt(CrossPtTrace, CrossPt, NewTraces); TraceList.Assign(NewTraces, laOr); NewTraces.Free; end; // на всякмй, чтоб не зациклилось if currTraceList.Count = 0 then break; if i = currTraceList.Count then break; end; FreeAndNil(currTraceList); end; end; { function FindNearObject(AObj: TConnectorObject): TConnectorObject; var CurrConDist, ConnDist: Double; CrossPtTrace: TOrtholine; CrossPt, CurrCrossPt: TDoublePoint; Trace: TOrtholine; NewTraces: TList; //Conn: TConnectorObject; i: Integer; begin Result := nil; ConnDist := 0; CrossPtTrace := nil; // Ищем самую ближнюю часть трассы i := 0; while i < TraceList.Count do begin Trace := TOrtholine(TraceList[i]); if Trace.JoinConnector1 <> nil then if IsNearPt(Trace.JoinConnector1.ActualPoints[1], AObj.ActualPoints[1], ConnDist, CurrConDist) then begin Result := TConnectorObject(Trace.JoinConnector1); CrossPtTrace := nil; end; if Trace.JoinConnector2 <> nil then if IsNearPt(Trace.JoinConnector2.ActualPoints[1], AObj.ActualPoints[1], ConnDist, CurrConDist) then begin Result := TConnectorObject(Trace.JoinConnector2); CrossPtTrace := nil; end; CurrCrossPt := AObj.ActualPoints[1]; PointToLineByAngle(Trace.ActualPoints[1], Trace.ActualPoints[2], CurrCrossPt); // Если точка пересечения не рядом, тогда расматриваем ее для создания трассы if isPointinLine(Trace.ActualPoints[1], Trace.ActualPoints[2], CurrCrossPt, 0, 0.1) then if (GetLineLength(Trace.ActualPoints[1], CurrCrossPt) >= ptDelta) and (GetLineLength(Trace.ActualPoints[2], CurrCrossPt) >= ptDelta) then if IsNearPt(CurrCrossPt, AObj.ActualPoints[1], ConnDist, CurrConDist) then begin Result := nil; CrossPtTrace := Trace; CrossPt := CurrCrossPt; end; Inc(i); end; if (Result = nil) and (CrossPtTrace <> nil) then begin NewTraces := TList.Create; Result := DivTraceOnPt(CrossPtTrace, CrossPt, NewTraces); TraceList.Assign(NewTraces, laOr); NewTraces.Free; end; end; } // Tolik -- 06/12/2016 -- Function CheckCanDelConnFromList(aConn: TConnectorObject): Boolean; var PointCatalog, LineCatalog: TSCSCatalog; i, j, k, l: Integer; JoinedLine: TOrthoLine; begin Result := False; if (AConn <> nil) and (not AConn.Deleted) then begin // пустой коннекор, по идее, сюда не попадет совсем, но на всякий if aConn.ConnectorType = ct_Clear then begin Result := True; Exit; end; PointCatalog := F_ProjMan.GSCSBase.CurrProject.CurrList.GetCatalogFromReferencesBySCSID(aConn.ID); if PointCatalog <> nil then begin for i := 0 to aConn.JoinedConnectorsList.Count - 1 do begin for j := 0 to TConnectorObject(aConn.JoinedConnectorsList[i]).JoinedOrtholinesList.Count - 1 do begin JoinedLine := TOrthoLine(TConnectorObject(aConn.JoinedConnectorsList[i]).JoinedOrtholinesList[j]); if (JoinedLine <> nil) and (not JoinedLine.deleted) then begin LineCatalog := F_ProjMan.GSCSBase.CurrProject.CurrList.GetCatalogFromReferencesBySCSID(JoinedLine.ID); if LineCatalog <> nil then begin for k := 0 to LineCatalog.ComponentReferences.Count - 1 do begin if IsCableComponent(TSCSComponent(LineCatalog.ComponentReferences[k])) then begin for l := 0 to TSCSComponent(LineCatalog.ComponentReferences[k]).JoinedComponents.Count - 1 do begin if PointCatalog.ComponentReferences.IndexOf((TSCSComponent(LineCatalog.ComponentReferences[k]).JoinedComponents[l])) <> -1 then begin Result := True; Exit; end; end; end; end; end; end; end; end; end else begin Result := True; Exit; end; end else Result := True; end; //Tolik 01/02/2022 -- function CheckNoIsRackOrEndObject(aConn: TConnectorObject): Boolean; var i: integer; SCSCatalog: TSCSCatalog; SCSCompon: TSCSComponent; SCSList: TSCSList; begin Result := True; Result := not aConn.AsEndPoint; if Result then begin SCSList := F_ProjMan.GSCSBase.CurrProject.GetListByID(TF_Cad(aConn.Owner.Owner).FCADListID); if SCSList <> nil then begin SCSCatalog := SCSList.GetCatalogFromReferencesBySCSID(aConn.ID); if SCSCatalog <> nil then begin SCSCompon := SCSCatalog.GetFirstComponent; if SCSCompon <> nil then Result := ((SCSCompon.ComponentType.SysName <> ctsnCupBoard) and (SCSCompon.ComponentType.SysName <> ctsnSHIELD)); end; end; end; end; Procedure ConnectToEndObject; var i: integer; CanProceed: Boolean; EmptyConnList: TList; TraceList: TList; currConn, NB_Conn: TConnectorObject; Dist, currDist: Double; begin if ConnFigures.Count > 0 then begin CanProceed := true; while CanProceed do begin CanProceed := False; NB_Conn := TConnectorObject(Connfigures[0]); EmptyConnList := TList.Create; for i := 0 to GCadForm.FSCSFigures.Count - 1 do begin if CheckFigureByClassName(TFigure(GCadForm.FSCSFigures[i]), cTConnectorObject) then begin if TConnectorObject(GCadForm.FSCSFigures[i]).ConnectorType = ct_Clear then begin currConn := TConnectorObject(GCadForm.FSCSFigures[i]); if not currConn.Deleted then begin TraceList := GetAllTraceInCad(NB_Conn, currConn); if TraceList <> nil then begin FreeAndNil(TraceList); EmptyConnList.Add(currConn); end; end; end; end; end; currConn := nil; dist := 100000000; if EmptyConnList.Count > 0 then begin for i := 0 to EmptyConnList.Count - 1 do begin currDist := sqrt(sqr(TConnectorObject(EmptyConnList[i]).ap1.x - GEndPoint.ap1.x) + sqr(TConnectorObject(EmptyConnList[i]).ap1.y - GEndPoint.ap1.y)); if CompareValue(dist, currDist) = 1 then begin dist := currDist; currConn := TConnectorObject(EmptyConnList[i]); end; end; CreatedTrace := CreateTraceByConnectors(GCADForm, currConn, TConnectorObject(GEndPoint), false, false, true); Connfigures.Delete(0); end; for i := ConnFigures.Count - 1 downto 0 do begin TraceList := GetAllTraceInCAD(GEndPoint, TFigure(ConnFigures[i])); if TraceList <> nil then begin FreeAndNil(TraceList); ConnFigures.Delete(i); end; end; EmptyConnList.Free; if ConnFigures.Count > 0 then CanProceed := True; end; end; end; begin // Tolik 28/02/2017 -- проверка на превышение квоты USER Objects Result := 0; if GUserOBjectsQuotaLimit_Message_Counter > 2 then Exit; UserQuotaReached_Message := ''; UserQuotaReached_Message := GetQuotaMessage(CheckUserObjQuotaReached(1),cMess_Quota); if UserQuotaReached_Message <> '' then begin Showmessage(UserQuotaReached_Message); Exit; end; // CurListParams := GetListParams(GCadForm.FCADListID); // Tolik 06/11/2019 -- //Tolik ConnectionPoint := Nil; CreatedTrace := Nil; CheckedTraceList := TList.Create; BetweenConnectorsTraceList := nil; ObjCount := 0; OldCadFigCount := GCadForm.FSCSFigures.Count; // Tolik -- 06/04/2017 -- CadRefreshFlag := GCanRefreshCad; GCanRefreshCad := False; BeforeTracingSCSFiguresCount := GCadForm.FSCSFigures.Count - 1; // количество СКС фигур на Каде до автотрассировки, // чтобы меньше проверять потом // try TraceList := TList.Create; TraceList.Assign(aTraces); CAD := GCadForm; if Not aSimulate then begin CAD.SaveForUndo(uat_None, true, False); BeginProgress; end; try ConnFigures := GetConnFiguresForAutoCreateTraces(CAD, aSimulate, aSimulateForAllObj, aSimulateForAnyTrace); // Tolik -- 06/12/2016 -- for i := ConnFigures.Count - 1 downto 0 do begin //Tolik 01/02/2022 -- здесь не дать исключить шкаф(ы) из списка, даже если к ним проведена трасса if CheckNoIsRackOrEndObject(TConnectorObject(ConnFigures[i])) then // begin for j := 0 to TConnectorObject(ConnFigures[i]).JoinedConnectorsList.Count - 1 do begin if CheckCanDelConnFromList(TConnectorObject(TConnectorObject(ConnFigures[i]).JoinedConnectorsList[j])) then begin ConnFigures.Delete(i); Break; //// BREAK ////; end; end; end; end; // finally if Not aSimulate then EndProgress; end; // Tolik -- 06/12/2016 -- if ConnFigures.Count > 0 then //if ConnFigures.Count > 1 then begin ConnectionPoint := Nil; if Not aSimulate then // Tolik 27/10/2016-- // BeginProgress('', ConnFigures.Count); begin //Tolik 09/02/2022 -- //BeginProgress(cProgress_Mes1, ConnFigures.Count, true); BeginProgress(cProgress_Mes2, ConnFigures.Count, true); F_Progress.Width := 450; //231 // F_Progress.BringToFront; end; // try for i := 0 to ConnFigures.Count - 1 do begin Conn1 := TConnectorObject(ConnFigures[i]); // Tolik 26/10/2016 -- // Conn2 := FindNearObject(Conn1); Conn2 := FindNearObject(Conn1, CreatedTrace); // if Conn2 <> nil then begin Result := Result + 1; if Not aSimulate then begin //Trace := CreateTraceByConnectors(CAD, Conn1, Conn2); IsOrthoTrace := (Abs(Conn1.ActualPoints[1].x - Conn2.ActualPoints[1].x) > ptDelta) and (Abs(Conn1.ActualPoints[1].y - Conn2.ActualPoints[1].y) > ptDelta); // Tolik 26/10/2016-- если есть трасса между этими коннекторами, то нех рисовать новую BetweenConnectorsTraceList := GetAllTraceInCad(Conn1, Conn2); // if BetweenConnectorsTraceList = nil then // begin //CreateTraceByConnectors(CAD, Conn1, Conn2, IsOrthoTrace); if i = 0 then // Tolik 17/03/2017 -- // CreatedTrace := CreateTraceByConnectors(CAD, Conn1, Conn2, IsOrthoTrace) begin if (not IsOrthoTrace) or ((Conn2.ActualZOrder[1] - Conn1.ActualZOrder[1]) <> 0) then begin if (Conn2.ActualZOrder[1] - Conn1.ActualZOrder[1]) <> 0 then begin if CurListParams.Settings.CADAutoPosTraceBetweenRM then //Tolik 08/08/2021 -- тут, если трасса наклонная, то разбивать ее ортогонально не нужно, // потому что будет хрень по виду... // CreatedTrace := CreateTraceByConnectors(CAD, Conn1, Conn2, IsOrthoTrace, true, false) CreatedTrace := CreateTraceByConnectors(CAD, Conn1, Conn2, false, true, false) // else begin // Tolik 06/11/2019 -- CreateRaiseOnPointObjectNew(Conn1, Conn2.ActualZOrder[1]); //CreateRaiseOnPointObjectNew(Conn1, Conn2.ActualZOrder[1] - Conn1.ActualZOrder[1]); // RaiseConnector := getNextRaiseConnFromPointObj(Conn1); connDist1 := GetLineLenght(RaiseConnector.ActualPoints[1], Conn2.ActualPoints[1]); connDist2 := 0; if IsNearPt(RaiseConnector.ActualPoints[1], Conn2.ActualPoints[1], connDist1, connDist2) then // Tolik --29/03/2018 -- //Conn2 := SnapConnectorToConnector(RaiseConnector, conn2) CheckingSnapConnectorToConnector(RaiseConnector, conn2) // else CreatedTrace := CreateTraceByConnectors(CAD, RaiseConnector, Conn2, IsOrthoTrace, true, False); end; end else begin if GetLineLenght(Conn1.ActualPoints[1], conn2.ActualPoints[1]) <> 0 then CreatedTrace := CreateTraceByConnectors(CAD, Conn1, Conn2, IsOrthoTrace, true, true) else begin Conn2.JoinedConnectorsList.Insert(0, Conn1); Conn1.JoinedConnectorsList.Add(Conn2); // Tolik 19/11/2019 -- if Conn2.ConnectorType = ct_Clear then DeleteObjectFromPM(Conn2.ID, Conn2.Name) else if Conn1.ConnectorType = ct_Clear then DeleteObjectFromPM(Conn1.ID, Conn1.Name); // {if Conn2.ConnectorType = ct_clear then SnapConnectorToPointObject(conn2, conn1);} end; end; { for j := 0 to conn1.JoinedConnectorsList.Count - 1 do begin for k := 0 to TConnectorObject(conn1.JoinedConnectorsList[j]).JoinedOrthoLinesList.Count - 1 do begin if TOrthoLine(TConnectorObject(conn1.JoinedConnectorsList[j]).JoinedOrthoLinesList[k]).FIsRaiseUpDown then CreatedTrace := TOrthoLine(TConnectorObject(conn1.JoinedConnectorsList[j]).JoinedOrthoLinesList[k]) end; end;} end else CreatedTrace := CreateTraceByConnectors(CAD, Conn1, Conn2, IsOrthoTrace, true) end // else // Tolik 17/03/2017 -- // CreateTraceByConnectors(CAD, Conn1, Conn2, IsOrthoTrace); begin if (not IsOrthoTrace) or ((Conn2.ActualZOrder[1] - Conn1.ActualZOrder[1]) <> 0) then begin if (Conn2.ActualZOrder[1] - Conn1.ActualZOrder[1]) <> 0 then begin // Tolik 06/11/2019 -- //CreateRaiseOnPointObjectNew(Conn1, Conn2.ActualZOrder[1] - Conn1.ActualZOrder[1]); if CurListParams.Settings.CADAutoPosTraceBetweenRM then CreatedTrace := CreateTraceByConnectors(CAD, Conn1, Conn2, IsOrthoTrace, true, false) else begin // CreateRaiseOnPointObjectNew(Conn1, Conn2.ActualZOrder[1]); // RaiseConnector := getNextRaiseConnFromPointObj(Conn1); connDist1 := GetLineLenght(RaiseConnector.ActualPoints[1], Conn2.ActualPoints[1]); connDist2 := 0; if IsNearPt(RaiseConnector.ActualPoints[1],Conn2.ActualPoints[1],connDist1, connDist2) then // Tolik -- 29/03/2018 -- //Conn2 := SnapConnectorToConnector(RaiseConnector, conn2) CheckingSnapConnectorToConnector(RaiseConnector, conn2) // else CreatedTrace := CreateTraceByConnectors(CAD, RaiseConnector, Conn2, IsOrthoTrace, true, False); end; end else begin if GetLineLenght(Conn1.ActualPoints[1], conn2.ActualPoints[1]) <> 0 then CreatedTrace := CreateTraceByConnectors(CAD, Conn1, Conn2, IsOrthoTrace, true) else begin Conn2.JoinedConnectorsList.Insert(0, Conn1); Conn1.JoinedConnectorsList.Add(Conn2); // Tolik 19/11/2019 -- if Conn2.ConnectorType = ct_Clear then DeleteObjectFromPM(Conn2.ID, Conn2.Name) else if Conn1.ConnectorType = ct_Clear then DeleteObjectFromPM(Conn1.ID, Conn1.Name); {if Conn2.ConnectorType = ct_clear then SnapConnectorToPointObject(conn2, conn1);} end; end; end else begin if GetLineLenght(Conn1.ActualPoints[1], conn2.ActualPoints[1]) <> 0 then CreatedTrace := CreateTraceByConnectors(CAD, Conn1, Conn2, IsOrthoTrace, true) else begin Conn2.JoinedConnectorsList.Insert(0, Conn1); Conn1.JoinedConnectorsList.Add(Conn2); // Tolik 19/11/2019 -- if Conn2.ConnectorType = ct_Clear then DeleteObjectFromPM(Conn2.ID, Conn2.Name) else if Conn1.ConnectorType = ct_Clear then DeleteObjectFromPM(Conn1.ID, Conn1.Name); {if Conn2.ConnectorType = ct_clear then SnapConnectorToPointObject(conn2, conn1);} end; end; end; // end else begin if i = 0 then begin for j := BetweenConnectorsTraceList.Count - 1 downto 0 do begin if not CheckFigureByClassName(TFigure(BetweenConnectorsTraceList[j]), cTOrthoLine) then BetweenConnectorsTraceList.delete(j); end; CreatedTrace := TOrthoLine(BetweenConnectorsTraceList[0]); end; FreeAndNil(BetweenConnectorsTraceList); end; // end else begin if aSimulateForAnyTrace then Break; //// BREAK //// end; end; if Not aSimulate then StepProgressRE; // Tolik --27/10/2016-- //for j := 0 to GCadForm.FSCSFigures.Count - 1 do //19/04/2017-- if GTraceToPoint then // Tolik 26/01/2022 -- begin for j := BeforeTracingSCSFiguresCount to GCadForm.FSCSFigures.Count - 1 do begin if CheckFigureByClassName(TFigure(GCadForm.FSCSFigures[j]), cTOrthoLine) then begin TempLine := TOrthoLine(GCadForm.FSCSFigures[j]); //if not TempLine.FIsRaiseUpDown then //19/04/2017-- if ((not TempLine.FIsRaiseUpDown) and (not TempLine.FisVertical)) then if TraceList.IndexOf(TempLine) = -1 then TraceList.Add(TempLine); end; end; end; // // Tolik -- 28/02/2017 -- проверка на превышение квоты USER Objects ObjCount := Cad.FSCSFigures.Count - OldCadFigCount; if ObjCount > 49 then begin UserQuotaReached_Message := ''; UserQuotaReached_Message := GetQuotaMessage(CheckUserObjQuotaReached(1),cMess_Quota); if UserQuotaReached_Message <> '' then begin PauseProgress(True); Showmessage(UserQuotaReached_Message); PauseProgress(False); Break; //// BREAK ////; end else begin OldCadFigCount := Cad.FSCSFigures.Count; end; end; // end; //Tolik 01/02/2022 -- подконнектить, то, что получится, чтобы была связь со шкафом, если получатся объекты, //от которых пути к шкафу нет если он на текущем листе if Assigned(GCadForm) then begin if GEndPoint <> nil then begin if TF_Cad(GEndPoint.Owner.Owner) = GCadForm then begin FreeAndNil(TraceList); ConnFigures.Remove(GEndPoint); for i := ConnFigures.Count - 1 downto 0 do begin TraceList := GetAllTraceInCAD(GEndPoint, TFigure(ConnFigures[i])); if TraceList <> nil then begin FreeAndNil(TraceList); ConnFigures.Delete(i); end; end; ConnectToEndObject; end; end; end; // finally if Not aSimulate then // Tolik 27/10/2016-- //EndProgress; begin EndProgress; F_Progress.Width := 231; end; // end; end; ConnFigures.Free; FreeAndNil(TraceList); except on E: Exception do addExceptionToLogEx('U_Common.AutoCreateTracesToTraceList', E.Message); end; FreeAndNil(CheckedTraceList); // Tolik GCanRefreshCad := CadRefreshFlag; // end; //Tolik 09/08/2021 -- procedure CheckTraceCableOnSelected(aSelList: TList; ExclRack: boolean = false); var i, j: integer; CanTrace, CanDeselect: Boolean; workList: TList; SCSCatalog: TSCSCatalog; SCSCompon: TSCSComponent; Connector: TConnectorObject; RackObject : TConnectorObject; // шкаф, если пришел, и конечный объект, чтобы сохранить и потом вернуть обратно SavedRackObject: TFigure; s: string; begin if aSelList = nil then exit; if aSelList.Count > 0 then begin CanTrace := False; WorkList := TList.Create; RackObject := nil; SavedRackObject := nil; for i := 0 to aSelList.Count - 1 do begin Connector := TConnectorObject(aSelList[i]); SCSCatalog := F_ProjMan.GSCSBase.CurrProject.CurrList.GetCatalogFromReferencesBySCSID(Connector.Id); CanDeselect := True; if SCSCatalog <> nil then begin for j := 0 to SCSCatalog.ComponentReferences.Count - 1 do begin if (j = 0) and ExclRack then begin SCSCompon := SCSCatalog.GetFirstComponent; if SCSCompon <> nil then begin if SCSCompon.IDNetType = 1 then begin if SCSCompon.ComponentType.SysName = ctsnCupboard then begin CanDeselect := True; break; end; end; end; end; SCSCompon := SCSCatalog.ComponentReferences[j]; //Tolik 27/01/2022 -- Здесь добавим виртуальные компоненты, чтобы не сбрасывалась трассировка //if (SCSCompon.IDNetType = 1) or (SCSCompon.IDNetType = 3) then if (SCSCompon.IDNetType = 1) or (SCSCompon.IDNetType = 3) or (SCSCompon.IsTemplate = biTrue) then // begin CanDeselect := False; break; end; end; end; if CanDeselect then Connector.Deselect else begin WorkList.Add(Connector); Connector.Select; end; end; GCadForm.PCad.RefreshSelection; GCadForm.PCad.Refresh; //if WorkList.Count > 1 then if WorkList.Count > 0 then begin CanDeselect := True; //Tolik 04/02/2022 -- //if (F_NormBase.GSCSBase.SCSComponent <> nil) then if (F_NormBase.GSCSBase.SCSComponent <> nil) and (F_NormBase.GSCSBase.SCSComponent.Name <> '') then // begin if isCableComponent(F_NormBase.GSCSBase.SCSComponent) then begin if GRackToRack then // 20/09/2021 -- begin if F_NormBase.GSCSBase.SCSComponent.IDNetType = 1 then if F_NormBase.GSCSBase.SCSComponent.ComponentType.SysName <> ctsnOFCable then CanDeselect := False; end else CanDeselect := False; // 20/09/2021 -- end; end; if Candeselect then begin //Tolik -- если активна закладка виртуальных компонент - искать виртуальный кабель -- if F_Normbase.pcObjects.ActivePageIndex = 0 then s := '{F36C14C9-29AF-4410-9142-CC629BBFCA07}' else begin // //s := '90000-0001-0001-028'; s := '{4896C54B-7C6C-4E04-8E05-1B7146E42E2F}'; {$if defined(SCS_PE)} s := '{082F23D0-512E-4694-844E-C71A698C0A9D}'; {$ifEnd} end; GSelNodeColor := clRed; try if F_Normbase.pcObjects.ActivePageIndex = 0 then F_NormBase.SelectComponInPCObjectsByGUID(s) else F_NormBase.FindComponentByGUIDWithBlink(s); Except on E: Exception do showmessage(E.Message); end; GSelNodeColor := -1; end; if F_NormBase.GSCSBase.SCSComponent <> nil then begin if isCableComponent(F_NormBase.GSCSBase.SCSComponent) then begin // Tolik 20/09/2021 -- //if F_NormBase.GSCSBase.SCSComponent.IDNetType = 1 then // Tolik 27/01/2022 -- Здесь кабель может быть и шаблоном ... //if (F_NormBase.GSCSBase.SCSComponent.IDNetType = 1) or (F_NormBase.GSCSBase.SCSComponent.IDNetType = 3) then if (F_NormBase.GSCSBase.SCSComponent.IDNetType = 1) or (F_NormBase.GSCSBase.SCSComponent.IDNetType = 3) or (F_NormBase.GSCSBase.SCSComponent.isTemplate = bitrue) then CanTrace := True; end; end; if CanTrace then begin //Tolik 01/02/2022 -- GCallEndPoint //if not GEndPointSelected then if ((GEndPointSelected = false) and (GCallEndPoint = true)) then // begin if GEndPoint <> nil then begin SavedRackObject := GEndPoint; TConnectorObject(GEndPoint).AsEndPoint := False; GEndPoint := nil; end; GCadForm.PCad.Refresh; end; //Tolik 27/01/2022 -- здесь тоже, если кабель - виртуальный, то трассировать как компьтерную сеть //if F_NormBase.GSCSBase.SCSComponent.IDNetType = 1 then if (F_NormBase.GSCSBase.SCSComponent.IDNetType = 1) or (F_NormBase.GSCSBase.SCSComponent.isTemplate = biTrue) then // TF_Main(F_NormBase).Act_AutoTraceCable.Execute else begin if GEndPoint <> nil then begin GCadForm.PCad.Selection.Remove(GEndPoint); GCadForm.PCad.Selection.Add(GEndPoint); TF_MAIN(F_NormBase).Act_AutoTraceByRayModeExecute(nil); end; end; end; end; if SavedRackObject <> nil then begin if GEndPoint <> nil then begin TConnectorObject(GEndPoint).AsEndPoint := False; GEndPoint := nil; end; TConnectorObject(SavedRackObject).AsEndPoint := True; GEndPoint := SavedRackObject; end; WorkList.Free; end; end; // // //function AutoCreateTracesMaster(aSrcFigure: TFigure): Boolean; //function AutoCreateTracesMaster(aSrcFigure: TFigure; FoCable: Boolean = False): Boolean; function AutoCreateTracesMaster(aSrcFigure: TFigure; aFromNB: Boolean = false; FoCable: Boolean = False): Boolean; // var SaveFAutoTraceBySelected: boolean; Values: TStringList; ValIdx: Integer; viToMain: Integer; viParallel: Integer; viTree: Integer; Traces, SelList: TList; aDisableItem1: boolean; //Tolik 09/08/2021 -- Conn: TConnectorObject; i: integer; ExclRack: boolean; PausedProgress: Boolean; // Tolik 27/09/2021 -- SavedEndPoint: TConnectorObject;//Tolik 01/02/2022 -- TraceHeight: Double;// Tolik 04/02/2022 -- SToGrid, SToGuid, SToNear: Boolean;// Tolik 10/02/2022 -- //Tolik 04/08/2021 -- Procedure SelectAllPointObjectsOnCad; var i: integer; begin for i := 0 to GCadForm.FSCSFigures.Count - 1 do begin if CheckFigureByClassName(TFigure(GCadForm.FSCSFigures[i]), cTConnectorObject) then begin if TConnectorObject(GCadForm.FSCSFigures[i]).ConnectorType = ct_NB then if not TConnectorObject(GCadForm.FSCSFigures[i]).Selected then begin TConnectorObject(GCadForm.FSCSFigures[i]).select; //if GCadForm.PCad.Selection.IndexOf(TConnectorObject(GCadForm.FSCSFigures[i])) = -1 then // GCadForm.PCad.Selection.Add(GCadForm.PCad.Selection); end; end; end; GCadForm.PCad.RefreshSelection; end; begin GTraceToPoint := True; SavedEndPoint := nil; GAutoTraceCreationOrder := -1; // Tolik 30/09/2021 -- Result := false; PausedProgress := false; SelList := Nil; Traces := GetAllNoConnectedTraces(GCadForm); Values := TStringList.Create; viToMain := -1; aDisableItem1 := True; if Traces.Count > 0 then begin //viToMain := Values.Add(cCommon_Mes27_4); // Прокладка трасс к магистрали (основной трассе) aDisableItem1 := False; end; viToMain := Values.Add(cCommon_Mes27_4); // Прокладка трасс к магистрали (основной трассе) viParallel := Values.Add(cCommon_Mes27_3); // прокладка по типу звезда (параллельная) viTree := Values.Add(cCommon_Mes27_2); // обычная прокладка //Tolik 27/09/2021-- //PauseProgressByMode(true); if GIsProgress then begin if Assigned(F_Progress) then begin if F_Progress.FPauseCount = 0 then begin PauseProgressByMode(true); PausedProgress := True; end; end; end; // try ValIdx := InputRadio(ApplicationName, cCommon_Mes27_1, nil{Values}, 0, aDisableItem1); finally PauseProgressByMode(false); end; if ValIdx <> -1 then begin //Tolik 10/02/2022 -- SToGrid := GCadForm.PCad.SnapToGrids; SToGuid := GCadForm.PCad.SnapToGuides; SToNear := GCadForm.PCad.SnapToNearPoint; GCadForm.PCad.SnapToGrids := False; GCadForm.PCad.SnapToGuides := False; GCadForm.PCad.SnapToNearPoint := False; // // 04/02/2022 -- Tolik -- слямзить высоту размещения трасс, вдруг пользователь задал другую // и запиздючить ее по умолчанию в настройки када и текущего листа try TraceHeight := StrToFloat_My(F_InputRadio.Edit1.text); except on E: Exception do TraceHeight := -300; end; if TraceHeight <> -300 then begin F_ProjMan.GSCSBase.CurrProject.Setting.FirstTraceCreated := False; if TraceHeight <> GCadForm.FLineHeight then begin if CompareValue(MetreToUom(GCadForm.FRoomHeight), TraceHeight) = -1 then begin F_ProjMan.GSCSBase.CurrProject.CurrList.Setting.HeightCorob := GCadForm.FRoomHeight; GCadForm.FLineHeight := GCadForm.FRoomHeight; end else begin F_ProjMan.GSCSBase.CurrProject.CurrList.Setting.HeightCorob := UOMToMetre(TraceHeight); GCadForm.FLineHeight := UOMToMetre(TraceHeight); end; end; end; GTraceToPoint := (F_InputRadio.RzRadioGroup2.ItemIndex = 1); // Tolik 26/01/2022 -- //Tolik 30/09/2021 -- if aFromNB then begin if GDropComponent <> nil then begin if isCableComponent(GDropComponent) then begin if GDropComponent.IDNetType = 3 then begin if ValIdx = viParallel then GAutoTraceCreationOrder := 2; end; end; end; end; // Result := true; //Tolik 04/08/2021 -- if assigned(F_InputRadio) and (F_InputRadio.RzRadioGroup1.ItemIndex = 1) then SelectAllPointObjectsOnCad; ExclRack := false; if assigned(F_InputRadio) and (F_InputRadio.chbExcludeRack.Checked) and (F_InputRadio.RzRadioGroup1.ItemIndex = 1) then ExclRack := true; if GAutoRouteCableAfterTraceCreation then begin SelList := TList.Create; for i := 0 to GCadForm.FSCSFigures.Count - 1 do begin //подъебка однако //if not TFigure(GCadForm.FSCSFigures).deleted then if not TFigure(GCadForm.FSCSFigures[i]).deleted then begin if CheckFigureByClassName(TFigure(GCadForm.FSCSFigures[i]),cTConnectorObject) then begin if (F_InputRadio.RzRadioGroup1.ItemIndex = 1) or TConnectorObject(GCadForm.FSCSFigures[i]).Selected then begin if SelList.IndexOf(GCadForm.FSCSFigures[i]) = -1 then SelList.Add(GCadForm.FSCSFigures[i]); end; end; end; end; end; try if F_ProjMan.GSCSBase.CurrProject.Setting.FirstTraceCreated then SetUserLineHeightForAllProj; if ValIdx = viToMain then //Tolik 01/02/2022 -- begin AutoCreateTracesToTraceList(Traces); (* if GEndPoint <> nil then begin SavedEndPoint := TConnectorObject(GEndPoint); SavedEndPoint.AsEndPoint := False; GEndPoint := nil; GListWithEndPoint := Nil; end; GCallEndPoint := False; F_EndPoints.Execute; if GEndPoint <> nil then begin AutoCreateTracesToTraceList(Traces); { TConnectorObject(GEndPoint).AsEndPoint := False; GEndPoint := nil; GEndPointSelected := True; } end; *) end else if ValIdx = viParallel then AutoCreateTracesParallel(aSrcFigure) else if ValIdx = viTree then AutoCreateTraces; Except on E: Exception do showmessage('Before ' + E.Message); end; //Tolik 10/02/2022 -- GCadForm.PCad.SnapToGrids := SToGrid; GCadForm.PCad.SnapToGuides := SToGuid; GCadForm.PCad.SnapToNearPoint := SToNear; // end; if GAutoRouteCableAfterTraceCreation then begin Try GAfterAutoCr := True; SaveFAutoTraceBySelected := GCadForm.FAutoTraceBySelected; GCadForm.FAutoTraceBySelected := True; CheckTraceCableOnSelected(SelList, ExclRack); Except on E: Exception do showmessage('After ' + E.Message); end; if GCallEndPoint = false then begin GCallEndPoint := true; GEndPointSelected := False; if SavedEndPoint <> nil then begin TConnectorObject(GEndPoint).AsEndPoint := False; GEndPoint := nil; GEndPointSelected := False; SavedEndPoint.asEndPoint := True; GEndPoint := TFigure(SavedEndPoint); end; end; GAfterAutoCr := False; GCadForm.FAutoTraceBySelected := SaveFAutoTraceBySelected; SelList.free; end; GCadForm.PCad.Refresh; // Tolik 23/08/2021 -- Values.Free; Traces.Free; //CheckDeleteAllRaises(GCadForm.Pcad); // Tolik 06/08/2021 -- end; function GetConnFiguresForAutoCreateTraces(aCad: TF_CAD; aSimulate: Boolean=false; aSimulateForAllObj:Boolean=false; aSimulateForAnyTrace: Boolean=false): TList; var i: Integer; FFigure: TFigure; Conn: TConnectorObject; begin Result := TList.Create; // Формируем список точ. объектов // Tolik -- 28/06/2016 -- // for i := 0 to aCAD.PCad.FigureCount - 1 do for i := 0 to aCAD.FSCSFigures.Count - 1 do begin // Tolik -- 28/06/2016 -- // FFigure := TFigure(aCAD.PCad.Figures[i]); FFigure := TFigure(aCAD.FSCSFigures[i]); // if CheckFigureByClassName(FFigure, cTConnectorObject) then begin Conn := TConnectorObject(FFigure); if (Conn.ConnectorType = ct_NB) and (Conn.FTrunkName = '') then begin if Conn.Selected or (aSimulate and aSimulateForAllObj) then Result.Add(FFigure); end; end; end; end; // Tolik 08/11/2019 -- юзать при проверке возможности прокладки автоматически созданной трассы // если выключена настройка использования вертикальных трасс и если // выключена настройка расположения трассы на высоте рабочих мест в настройках листа // (тогда трасса автоматически создается на высоте расположения трасс из настроек листа/Када) // ВНИМАНИЕ! Работает "наоборот": False - можно поключать автоматически созданную трассу к объекту, True - нет Function CheckCanDrawOneTrace(aConn: TConnectorObject): Boolean; var RaiseOnPoint, vLine1, vLine2: TOrtholine; Procedure GetLinesFromPoint(aPoint: TConnectorObject; var aRaise, aVLine1, aVLine2: TOrthoLine); var i, j: Integer; JoinedConn: TConnectorObject; begin if aPoint = nil then exit; if aPoint.ConnectorType = ct_Nb then begin for i := 0 to aPoint.JoinedConnectorsList.Count - 1 do begin JoinedConn := TConnectorObject(aPoint.JoinedConnectorsList[i]); for j := 0 to JoinedConn.JoinedOrthoLinesList.Count - 1 do begin if TOrthoLine(JoinedConn.JoinedOrthoLinesList[j]).FIsRaiseUpDown then begin aRaise := TOrthoLine(JoinedConn.JoinedOrthoLinesList[j]); break; end else begin if TOrthoLine(JoinedConn.JoinedOrthoLinesList[j]).FIsVertical then begin if aVLine1 = nil then aVLine1 := TOrthoLine(JoinedConn.JoinedOrthoLinesList[j]) else begin aVLine2 := TOrthoLine(JoinedConn.JoinedOrthoLinesList[j]); break; end; end; end; end; if aRaise <> nil then // есть, райз -- дальше не ищем break; if aVLine2 <> nil then // нашли обе вертикали -- дальше не ищем break; end; end else if aPoint.Connectortype = ct_Clear then begin for j := 0 to aPoint.JoinedOrthoLinesList.Count - 1 do begin if TOrthoLine(aPoint.JoinedOrthoLinesList[j]).FIsRaiseUpDown then begin aRaise := TOrthoLine(aPoint.JoinedOrthoLinesList[j]); break; end else begin if TOrthoLine(aPoint.JoinedOrthoLinesList[j]).FIsVertical then begin if aVLine1 = nil then aVLine1 := TOrthoLine(aPoint.JoinedOrthoLinesList[j]) else begin aVLine2 := TOrthoLine(aPoint.JoinedOrthoLinesList[j]); break; end; end; end; end; end; end; Function CheckResult(aLine: TOrthoLine): Boolean; var JoinConn: TConnectorObject; begin Result := True; // Низзя подключать // Если есть райз и попадем хоть на один коннектор райза по высоте // расположения трасс - можно строить трассу к этому объекту if (aLine.JoinConnector1 <> nil) then begin JoinConn := TConnectorObject(aLine.JoinConnector1); if JoinConn.JoinedConnectorsList <> nil then if JoinConn.JoinedConnectorsList.Count > 0 then JoinConn := TConnectorObject(JoinConn.JoinedConnectorsList[0]); if CompareValue(JoinConn.ActualZOrder[1], GCadForm.FLineHeight) = 0 then Result := False; end; if (aLine.JoinConnector2 <> nil) then begin JoinConn := TConnectorObject(aLine.JoinConnector1); if JoinConn.JoinedConnectorsList <> nil then if JoinConn.JoinedConnectorsList.Count > 0 then JoinConn := TConnectorObject(JoinConn.JoinedConnectorsList[0]); if CompareValue(JoinConn.ActualZOrder[1], GCadForm.FLineHeight) = 0 then Result := False; end; end; begin Result := False; // можно подключать // если включено расположение трассы на высоте рабочих мест, можно однозначно -- сразу выходим if F_ProjMan.GSCSBase.CurrProject.CurrList.Setting.CADAutoPosTraceBetweenRM then exit; if (Comparevalue(aConn.ActualZOrder[1], GCadForm.FLineHeight) <> 0) then begin RaiseOnPoint := nil; vLine1 := nil; vLine2 := nil; GetLinesFromPoint(aConn, RaiseOnPoint, vLine1, vLine2); // если есть райз или вертикали на поинте if RaiseOnPoint <> nil then begin Result := CheckResult(RaiseOnPoint); end else begin if vLine1 <> nil then begin Result := CheckResult(vLine1); if Result then exit; end; if vLine2 <> nil then Result := CheckResult(vLine2); end; end; end; // procedure DivideTracesOnRoowWalls(aCad: TF_CAD); var Figures: TList; Cabinets: TList; FFigure: TFigure; Obj: TObject; Trace: TOrtholine; Cabinet: TCabinet; CabinetExt: TCabinetExt; Seg: TPLSegment; PointCnt: Integer; p1,p2: TDoublePoint; i, j, k, SegNbr: Integer; pArr: TDoublePointArr; // Tolik CreatedTraceCount: integer; UserQuotaReached_Message: string; // {procedure DivTraceOnPt(ATrace: TOrtholine; APt: TDoublePoint); var i: Integer; NewConn: TConnectorObject; begin if Not (PointNear(ATrace.ActualPoints[1], APt) or PointNear(ATrace.ActualPoints[2], APt)) then begin NewConn := DivideLineSimple(ATrace, @APt); for i := 0 to NewConn.JoinedOrtholinesList.Count - 1 do begin if TOrtholine(NewConn.JoinedOrtholinesList[i]) <> ATrace then Figures.Add(TOrtholine(NewConn.JoinedOrtholinesList[i])); end; end; end;} procedure DivTraceOnCross(ATrace: TOrtholine; AP1, AP2: TDoublePoint); var p: TDoublePoint; begin if GetIntersectionPoint(ATrace.ActualPoints[1], ATrace.ActualPoints[2], AP1,AP2, p,false) then DivTraceOnPt(ATrace, p, Figures); //if Not (PointNear(ATrace.ActualPoints[1], p) or PointNear(ATrace.ActualPoints[2], p)) then //begin // NewConn := DivideLineSimple(ATrace, @p); // AddTraceFromNewConn(NewConn, ATrace); //end; end; procedure DivTraceOnArcCross(ATrace: TOrthoLine; ACenterPt, AP1: TDoublePoint; APolyLine: TPolyLine; ASeg: TPLSegment; ASegNbr: Integer); var rad: Double; icnt: Integer; np1,np2: TDoublePoint; begin rad := GetLineLenght(AP1, ACenterPt); if GetLineCircleIntersection(ATrace.ActualPoints[1], ATrace.ActualPoints[2], ACenterPt, rad, np1,np2, icnt,false) then begin if iCnt > 0 then begin if APolyLine.isPointInSegment(ASegNbr,np1.x,np1.y) then begin DivTraceOnPt(ATrace, np1, Figures); inc(CreatedTraceCount); end; end; if iCnt > 1 then begin if APolyLine.isPointInSegment(ASegNbr,np2.x,np2.y) then begin DivTraceOnPt(ATrace, np2, Figures); inc(CreatedTraceCount); end; end; end; end; begin UserQuotaReached_Message:= ''; UserQuotaReached_Message := GetQuotaMessage(CheckUserObjQuotaReached(1), cMess_Quota); if UserQuotaReached_Message = '' then begin Figures := TList.Create; Cabinets := TList.Create; for i := 0 to aCAD.PCad.FigureCount - 1 do begin FFigure := TFigure(aCAD.PCad.Figures[i]); //Tolik 30/07/2021 -- if ((not FFigure.Deleted) and (FFigure.Id <> -1)) then begin // if CheckFigureByClassName(FFigure, cTOrtholine) then begin if FFigure.Selected then Figures.Add(FFigure); end else if CheckFigureByClassName(FFigure, cTCabinet) then begin // Tolik 30/07/2021 -*- //if TCabinet(Obj).FType <> ct_Virtual then if TCabinet(FFigure).FType <> ct_Virtual then // Cabinets.Add(FFigure); end else if CheckFigureByClassName(FFigure, cTCabinetExt) then Cabinets.Add(FFigure); end; end; aCAD.SaveForUndo(uat_None, true, False); if Cabinets.Count > 0 then begin BeginProgress; try i := 0; while i < Figures.Count do begin // Tolik -- 28/02/2017 -- превышение квоты объектов USER (на каждую сотню) if CreatedTraceCount > 49 then begin UserQuotaReached_Message:= ''; UserQuotaReached_Message := GetQuotaMessage(CheckUserObjQuotaReached(1), cMess_Quota); if UserQuotaReached_Message <> '' then begin PauseProgress(True); Showmessage(UserQuotaReached_Message); PauseProgress(False); Figures.Free; Cabinets.Free; EndProgress; exit; end else CreatedTraceCount := 0; end; Trace := TOrtholine(Figures[i]); for j := 0 to Cabinets.Count - 1 do begin Obj := TObject(Cabinets[j]); if Obj is TCabinet then begin Cabinet := TCabinet(Obj); DivTraceOnCross(Trace, Cabinet.ap1, Cabinet.ap2); DivTraceOnCross(Trace, Cabinet.ap2, Cabinet.ap3); DivTraceOnCross(Trace, Cabinet.ap3, Cabinet.ap4); DivTraceOnCross(Trace, Cabinet.ap4, Cabinet.ap1); end else if Obj is TCabinetExt then begin CabinetExt := TCabinetExt(Obj); SetLength(pArr, 0); CabinetExt.GetLinearInterSections(Trace.ActualPoints[1], Trace.ActualPoints[2], pArr); for k := 0 to Length(pArr) - 1 do begin if IsPointInLine(Trace.ActualPoints[1], Trace.ActualPoints[2], pArr[k], 1) then begin DivTraceOnPt(Trace, pArr[k], Figures); inc(CreatedTraceCount); end; end; SetLength(pArr, 0); {PointCnt := CabinetExt.PointCount; if Not CabinetExt.Closed then PointCnt := CabinetExt.PointCount - 1; for SegNbr := 1 to PointCnt do begin Seg := TPLSegment(CabinetExt.Segments[SegNbr-1]); p1 := CabinetExt.actualpoints[SegNbr]; if SegNbr = PointCnt then p2 := CabinetExt.actualpoints[1] else p2 := CabinetExt.actualpoints[SegNbr+1]; if Seg.SType = sLine then DivTraceOnCross(Trace, p1, p2) else if Seg.SType = sArc then DivTraceOnArcCross(Trace, Seg.CPoint1, p1, CabinetExt, Seg, SegNbr); end;} end; end; i := i + 1; end; finally EndProgress; end; end; Cabinets.Free; Figures.Free; end else begin Showmessage(UserQuotaReached_Message); end; end; procedure ApplySectionSideForTraces(aCad: TF_CAD); var Figures: TList; FFigure: TFigure; SCSList: TSCSList; SCSObj: TSCSCatalog; SCSCompon: TSCSComponent; Trace: TOrtholine; i, j: Integer; SectSize, CompSectSize: Double; begin Figures := TList.Create; for i := 0 to aCAD.PCad.FigureCount - 1 do begin FFigure := TFigure(aCAD.PCad.Figures[i]); if CheckFigureByClassName(FFigure, cTOrtholine) then if FFigure.Selected then Figures.Add(FFigure); end; if Figures.Count > 0 then begin aCAD.SaveForUndo(uat_None, true, False); BeginProgress; try SCSList := GetSCSListByCAD(aCad); for i := 0 to Figures.Count - 1 do begin Trace := TOrtholine(Figures[i]); SCSObj := SCSList.GetCatalogFromReferencesBySCSID(Trace.ID); if SCSObj <> nil then begin SectSize := 0; for j := 0 to SCSObj.ComponentReferences.Count - 1 do begin SCSCompon := SCSObj.ComponentReferences[j]; if CheckSysNameIsCableChannel(SCSCompon.ComponentType.SysName) then begin CompSectSize := SCSCompon.GetPropertyValueAsFloat(pnSectionSize); if CompSectSize > 0 then if (SectSize = 0) OR (CompSectSize < SectSize) then SectSize := CompSectSize; end; end; if SectSize > 0 then aCad.AutoDivideTraceOnAppendCable(Trace, SectSize); end; end; finally EndProgress; end; end; Figures.Free; end; // procedure SetConnComponToTraces(aCad: TF_CAD; ACompon: TSCSComponent; AStep: Double; ASetToConnectors: Boolean); var Figures: TList; // AccessibleTraces: TList; FFigure: TFigure; StepPC: Double; i: Integer; Trace: TOrthoLine; StartConn: TConnectorObject; StepFigures: TList; LookedFigures: TList; // Tolik SnapToGridsValue: boolean; SnapToGuidesValue: boolean; ComponID, ConnComponID: Integer; DropFigure: TFigure; SCSCatalog: TSCSCatalog; NBComponent: TSCSComponent; StateType: TCompStateType; // 28/02/2017 -- UserQuotaCounter: Integer; UserQuotaReached_Message: string; // // Сравнение трасс какая ближе к началу координат function TracesCompare(Item1, Item2: Pointer): Integer; var dist11, dist12, dist21, dist22: Double; dist1, dist2: Double; begin dist11 := GetLineLenght(TOrthoLine(Item1).ActualPoints[1], DoublePoint(0,0)); dist12 := GetLineLenght(TOrthoLine(Item1).ActualPoints[2], DoublePoint(0,0)); dist21 := GetLineLenght(TOrthoLine(Item2).ActualPoints[1], DoublePoint(0,0)); dist22 := GetLineLenght(TOrthoLine(Item2).ActualPoints[2], DoublePoint(0,0)); dist1 := Min(dist11, dist12); dist2 := Min(dist21, dist22); Result := 0; if dist1 < dist2 then Result := -1 else if dist1 > dist2 then Result := 1; end; // Tolik -- 12/03/2016 -- Procedure GetConnectorsList; var i: Integer; aConn: TConnectorObject; Procedure AddConnectorToList; var i: Integer; CanAddConnector: Boolean; nbConn: TConnectorObject; LineCount: Integer; begin if LookedFigures.IndexOf(aConn) = -1 then begin // если не добавлять крайние коннекторы трасс //пустой коннектор if (aConn.JoinedConnectorsList.Count = 0) then begin if (aConn.JoinedOrtholinesList.Count > 1) and (LookedFigures.IndexOf(aConn) = -1) then LookedFigures.Add(aConn); end else // коннектор с компонентой begin NbConn := TConnectorObject(aConn.JoinedConnectorsList[0]); if NbConn <> nil then begin LineCount := 0; for i := 0 to nbConn.JoinedConnectorsList.Count - 1 do begin LineCount := LineCount + TConnectorObject(nbConn.JoinedConnectorsList[i]).JoinedOrtholinesList.Count; end; end; if LineCount > 1 then LookedFigures.Add(aConn); end; end; end; begin for i := 0 to Figures.Count - 1 do begin Trace := TOrthoLine(Figures[i]); if ASetToConnectors then begin aConn := TConnectorObject(Trace.JoinConnector1); if LookedFigures.IndexOf(aConn) = -1 then LookedFigures.Add(aConn); aConn := TConnectorObject(Trace.JoinConnector2); if LookedFigures.IndexOf(aConn) = -1 then LookedFigures.Add(aConn); end else begin aConn := TConnectorObject(Trace.JoinConnector1); if ((aConn.JoinedConnectorsList.Count > 0) or (aConn.JoinedOrtholinesList.Count > 1)) then AddConnectorToList; aConn := TConnectorObject(Trace.JoinConnector2); if ((aConn.JoinedConnectorsList.Count > 0) or (aConn.JoinedOrtholinesList.Count > 1)) then AddConnectorToList; end; end; end; // разбить трассы из списка на куски procedure DivideTraceList(aTraceList: TList; aLength: Double); var i, j, k: 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; aTrace, CurTrace: TOrthoLine; DivCount: integer; GetPointObject: TConnectorObject; LastLineLen: Double; isUserLength: Boolean; begin try for k := 0 to aTraceList.Count - 1 do begin aTrace := TOrthoLine(aTraceList[k]); LastLineLen := 0; // если установлена длина трассы для расчетов, нужно сразу высчитать длину // последнего куска, если будет разделение if aTrace.UserLength <> -1 then begin isUserLength := True; LastLineLen := aTrace.UserLength; while LastLineLen > aLength do LastLineLen := LastLineLen - aLength; // ОСТАТОК end else begin isUserLength := False; LastLineLen := aTrace.CalculLength; while LastLineLen > aLength do LastLineLen := LastLineLen - aLength; // ОСТАТОК end; // -- учесть установку длины трассы для расчетов if isUserLength then begin // TraceLength := aTrace.LineLength * 1000 / PCad.MapScale; // длину берем из расчетной RealDelta := ((aLength*aTrace.CalculLength)/aTrace.userLength) * 1000 / aCad.PCad.MapScale; // длину блока масштабируем end else Realdelta := aLength * 1000 / aCad.PCad.MapScale; 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; Z2 := aTrace.ActualZOrder[1]; 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)); ang := aTrace.GetAngleInRad(x1, y1, x2, y2); DivCount := Trunc(TraceLength / Realdelta); if Frac(TraceLength / Realdelta) <= 0.01 then DivCount := DivCount - 1; CurTrace := aTrace; if StepFigures.IndexOf(curTrace) = -1 then StepFigures.Add(curTrace); aCad.FAllowSuppliesKind := False; {if StepFigures.IndexOf(curTrace) = -1 then StepFigures.Add(curTrace);} // Tolik -- 28/02/2017 -- UserQuotaCounter := UserQuotaCounter + DivCount; if UserQuotaCounter > 49 then begin UserQuotaReached_Message := ''; UserQuotaReached_Message := GetQuotaMessage(CheckUserObjQuotaReached(UserQuotaCounter),cMess_Quota ); if UserQuotaReached_Message <> '' then begin PauseProgress(True); Showmessage(UserQuotaReached_Message); PauseProgress(False); Figures.Free; LookedFigures.Free; StepFigures.Free; Exit; end; end; // for i := 1 to DivCount do begin nextx := x1 + i * Realdelta * Cos(ang); nexty := y1 + i * Realdelta * Sin(ang); //nextx := currX + Realdelta * Cos(ang); //nexty := currY + Realdelta * Sin(ang); Conn := TConnectorObject.Create(nextx, nexty, CurTrace.ActualZOrder[1], CurTrace.LayerHandle, PCTypesUtils.mydsNormal, aCad.PCad); Conn.ConnectorType := ct_Clear; aCad.PCad.AddCustomFigure(GLN(aTrace.LayerHandle), Conn, false); SnapConnectorToOrtholine(Conn, CurTrace); 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 begin CurTrace := TOrthoLine(Conn.JoinedOrtholinesList[j]); if StepFigures.IndexOf(curTrace) = -1 then StepFigures.Add(curTrace); end; end; // последний кусок трассы (выставить длину, что останется) 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; aCad.FAllowSuppliesKind := True; end; // RefreshCAD(aCad.PCad); except on E: Exception do addExceptionToLogEx('U_Common.DivideTraceList', E.Message); end; end; // begin if GUserOBjectsQuotaLimit_Message_Counter >= 3 then Exit; UserQuotaReached_Message := ''; UserQuotaCounter := 0; Figures := TList.Create; // Tolik -- 11/03/2016 -- тут немножко исправим совсем... у КАДа cелекшн есть, // нех по всем фигурам бегать -- будет ощутимо тормозить на больших проектах, но // aCAD.PCad.Selection - может немножко обмануть, поэтому : { for i := 0 to aCAD.PCad.FigureCount - 1 do begin FFigure := TFigure(aCAD.PCad.Figures[i]); if CheckFigureByClassName(FFigure, cTOrtholine) then begin if FFigure.Selected then Figures.Add(FFigure); end; end; } // побежим только по СКС фигурам, без учета остальных фигур - все равно быстрее будет for i := 0 to aCAD.FSCSFigures.Count - 1 do begin FFigure := TFigure(aCAD.FSCSFigures[i]); if CheckFigureByClassName(FFigure, cTOrtholine) then begin if FFigure.Selected then Figures.Add(FFigure); end; end; // // *UNDO* if GCadForm.FCanSaveForUndo then begin GCadForm.SaveForUndo(uat_None, True, False); GCadForm.FCanSaveForUndo := False; end; if Figures.Count > 0 then begin BeginProgress; try // сохраняем привязки КАДа и сбрасываем их SnapToGridsValue := aCad.PCad.SnapToGrids; SnapToGuidesValue := aCad.PCad.SnapToGuides; aCad.PCad.SnapToGrids := False; aCad.PCad.SnapToGuides := False; // LookedFigures := TList.Create; StepFigures := TList.Create; // Сортируем трассы Figures.Sort(@TracesCompare); if (AStep <> 0) then begin // разделение трасс на заданные отрезки DivideTraceList(Figures, aStep); // Tolik -- 28/02/2017 -- превышение квоты -- выход нах if UserQuotaReached_Message <> '' then begin Figures.Free; StepFigures.Free; LookedFigures.Free; // восстанавливаем настройки привязок на КАДе aCad.PCad.SnapToGrids := SnapToGridsValue; aCad.PCad.SnapToGuides := SnapToGuidesValue; // EndProgress; Exit; end; Figures.Assign(StepFigures); end; GetConnectorsList; StateType := stProjectible; // Tolik -- 28/02/2017 -- превышение квоты объектов USER UserQuotaReached_Message := ''; UserQuotaReached_Message := GetQuotaMessage(CheckUserObjQuotaReached(LookedFigures.Count),cMess_Quota ); if UserQuotaReached_Message <> '' then begin PauseProgress(True); Showmessage(UserQuotaReached_Message); PauseProgress(False); end; if UserQuotaReached_Message = '' then begin // // раскладка точечных по коннекторам for i := 0 to LookedFigures.Count - 1 do begin GListNode := Nil; ComponID := 0; ConnComponID := 0; NBComponent := F_NormBase.GSCSBase.SCSComponent; // создать фигуру на CAD DropFigure := GetComponentFromNormBase(TConnectorObject(LookedFigures[i]).ap1.x, TConnectorObject(LookedFigures[i]).ap1.y, NBComponent, TConnectorObject(LookedFigures[i]), StateType); // копирование компонент NormBase -> ProjectManager if DropFigure <> nil then begin // копирование ComponID := CopyComponentToPrjManager(GListNode, DropFigure.ID, GCadForm.FCADListID, NBComponent, True, True); // накладка коннекторов один на другой CheckingSnapPointObjectToConnector(TConnectorObject(DropFigure), TConnectorObject(LookedFigures[i])); SetConnObjectSelectHightPriority(TConnectorObject(DropFigure)); end; end; end; // finally StepFigures.Free; LookedFigures.Free; // восстанавливаем настройки привязок на КАДе aCad.PCad.SnapToGrids := SnapToGridsValue; aCad.PCad.SnapToGuides := SnapToGuidesValue; // EndProgress; end; end; Figures.Free; end; procedure MirrorFigure(AFigure: TFigure); begin AFigure.Mirror(AFigure.CenterPoint, AFigure.CenterPoint); end; procedure MoveFigures(AFigures: TList; x, y: Double); var i: integer; Figure: TFigure; SavedMoveAllPoints: Boolean; Path: TNetPath; begin for i := 0 to AFigures.Count - 1 do begin Figure := TFigure(AFigures[i]); if Figure is TNet then begin if ssCtrl in GGlobalShiftState then begin Path := TNet(Figure).SelPath; if Path <> nil then begin Path.FPointsOffset := Path.FPointsOffset + (x+y); TNet(Figure).RefreshPaths; end; Continue; //// CONTINUE //// end; SavedMoveAllPoints := TNet(Figure).FMoveAllPoints; TNet(Figure).FMoveAllPoints := true; end; Figure.Move(x, y); if Figure is TNet then TNet(Figure).FMoveAllPoints := SavedMoveAllPoints; end; end; procedure RotateFigure(AFigure: TFigure; Angle: Double); var AngleRad: Double; AngleDeg: Double; Bnd: TDoubleRect; pt: TDoublePoint; begin AngleRad := Angle / 180 * pi; //if Not (AFigure is TNet) then // pt := AFigure.ActualPoints[1] //else if TNet(AFigure).Points.Count > 0 then // pt := PDoublePoint(TNet(AFigure).Points[0])^ //else // pt := DoublePoint(0, 0); Bnd := AFigure.GetBoundRect; //pt := DoublePoint((figMaxX+figMinX)/2,(figMaxY+figMinY)/2); pt := DoublePoint((Bnd.Left + Bnd.Right)/2, (Bnd.Top + Bnd.Bottom)/2); AFigure.Rotate(AngleRad, pt); //AFigure.DrawFigure.Rotate(AngleRad, AFigure.CenterPoint); //AFigure.FDrawFigureAngle := AFigure.FDrawFigureAngle + AngleRad; //if AFigure.FDrawFigureAngle >= 2 * pi then // AFigure.FDrawFigureAngle := AFigure.FDrawFigureAngle - 2 * pi; //Bnd := AFigure.DrawFigure.GetBoundRect; //AFigure.GrpSizeX := Bnd.Right - Bnd.Left; //AFigure.GrpSizeY := Bnd.Bottom - Bnd.Top; RefreshCAD(GCadForm.PCad); end; procedure RotateBitmap(Bitmap: TBitmap; aAngle: Double; BackColor: TColor); type TRGB = record B, G, R: Byte; end; pRGB = ^TRGB; pByteArray = ^TByteArray; TByteArray = array[0..32767] of Byte; TRectList = array[1..4] of TPoint; var x, y, W, H, v1, v2: Integer; Dest, Src: pRGB; VertArray: array of pByteArray; Bmp: TBitmap; procedure SinCos(AngleRad: Double; var ASin, ACos: Double); begin ASin := Sin(AngleRad); ACos := Cos(AngleRad); end; function RotateRect(const Rect: TRect; const Center: TPoint; aaAngle: Double): TRectList; var DX, DY: Integer; SinAng, CosAng: Double; function RotPoint(PX, PY: Integer): TPoint; begin DX := PX - Center.x; DY := PY - Center.y; Result.x := Center.x + Round(DX * CosAng - DY * SinAng); Result.y := Center.y + Round(DX * SinAng + DY * CosAng); end; begin SinCos(aaAngle * (Pi / 180), SinAng, CosAng); Result[1] := RotPoint(Rect.Left, Rect.Top); Result[2] := RotPoint(Rect.Right, Rect.Top); Result[3] := RotPoint(Rect.Right, Rect.Bottom); Result[4] := RotPoint(Rect.Left, Rect.Bottom); end; function Min(A, B: Integer): Integer; begin if A < B then Result := A else Result := B; end; function Max(A, B: Integer): Integer; begin if A > B then Result := A else Result := B; end; function GetRLLimit(const RL: TRectList): TRect; begin Result.Left := Min(Min(RL[1].x, RL[2].x), Min(RL[3].x, RL[4].x)); Result.Top := Min(Min(RL[1].y, RL[2].y), Min(RL[3].y, RL[4].y)); Result.Right := Max(Max(RL[1].x, RL[2].x), Max(RL[3].x, RL[4].x)); Result.Bottom := Max(Max(RL[1].y, RL[2].y), Max(RL[3].y, RL[4].y)); end; procedure Rotate; var x, y, xr, yr, yp: Integer; ACos, ASin: Double; Lim: TRect; begin W := Bmp.Width; H := Bmp.Height; SinCos(-aAngle * Pi / 180, ASin, ACos); Lim := GetRLLimit(RotateRect(Rect(0, 0, Bmp.Width, Bmp.Height), Point(0, 0), aAngle)); Bitmap.Width := Lim.Right - Lim.Left; Bitmap.Height := Lim.Bottom - Lim.Top; Bitmap.Canvas.Brush.Color := BackColor; Bitmap.Canvas.FillRect(Rect(0, 0, Bitmap.Width, Bitmap.Height)); for y := 0 to Bitmap.Height - 1 do begin Dest := Bitmap.ScanLine[y]; yp := y + Lim.Top; for x := 0 to Bitmap.Width - 1 do begin xr := Round(((x + Lim.Left) * ACos) - (yp * ASin)); yr := Round(((x + Lim.Left) * ASin) + (yp * ACos)); if (xr > -1) and (xr < W) and (yr > -1) and (yr < H) then begin Src := Bmp.ScanLine[yr]; Inc(Src, xr); Dest^ := Src^; end; Inc(Dest); end; end; end; begin // С версии 2.0.0 было зачем то сделано pf16Bit //Bitmap.PixelFormat := pf16Bit; // НО нельзя так битность опускать так как затем плохо вращает изображение совсем и если на входе // было Bitmap.PixelFormat pfDevice - то кусками вращает и белый цвет стает голубым // а если было pf32Bit то вообще выпадает в осадок Bitmap.PixelFormat := pf24Bit; Bmp := TBitmap.Create; try Bmp.Assign(Bitmap); W := Bitmap.Width - 1; H := Bitmap.Height - 1; if Frac(aAngle) <> 0.0 then Rotate else case Trunc(aAngle) of -360, 0, 360, 720: Exit; 90, 270: begin Bitmap.Width := H + 1; Bitmap.Height := W + 1; SetLength(VertArray, H + 1); v1 := 0; v2 := 0; if aAngle = 90.0 then v1 := H else v2 := W; for y := 0 to H do VertArray[y] := Bmp.ScanLine[Abs(v1 - y)]; for x := 0 to W do begin Dest := Bitmap.ScanLine[x]; for y := 0 to H do begin v1 := Abs(v2 - x) * 3; with Dest^ do begin B := VertArray[y, v1]; G := VertArray[y, v1 + 1]; R := VertArray[y, v1 + 2]; end; Inc(Dest); end; end end; 180: begin for y := 0 to H do begin Dest := Bitmap.ScanLine[y]; Src := Bmp.ScanLine[H - y]; Inc(Src, W); for x := 0 to W do begin Dest^ := Src^; Dec(Src); Inc(Dest); end; end; end; else Rotate; end; finally Bmp.Free; end; end; function GetArcLen(Radius, RadAngle: Double): Double; begin // Длина дуги радиуса R с радианной мерой a, равна R*a // Через градусную меру n длина дуги выражается формулой (pi * R * n)/180 Result := Radius * RadAngle; end; function GetArcLen(CenterPoint, LinePoint: TDoublePoint; RadAngle: Double): Double; begin Result := GetLineLenght(CenterPoint, LinePoint) * RadAngle; end; function GetArcLenByPoints(p1, p2, ArcCenter: TDoublePoint; AInverted: Boolean): Double; var PointsAng: Double; begin PointsAng := 0; if AInverted then PointsAng := GetRadOf2Lines(p1, ArcCenter, p2) else PointsAng := GetRadOf2Lines(p2, ArcCenter, p1); if PointsAng = 0 then PointsAng := 2 * pi else if PointsAng < 0 then PointsAng := (2 * pi) + PointsAng; Result := GetArcLen(ArcCenter, p1, PointsAng); end; function GetPolylineFromArc(ACornerCount: Integer; cp:TdoublePoint; radius, ArcAng: Double; p1, p2: PDoublePoint): TDoublePointArr; var AngleStep: Double; pt, StartPt: TDoublePoint; i: Integer; {function ChoicePtByAngle(Ang: Double): Boolean; begin Result := false; pt := p1^; TempPt := GetRelativePointbyAngleFloat(ArcAng, cp, pt); if EQDP(pt, p2^) then pt := p1^ else pt := p2^; end;} begin SetLength(Result, 0); AngleStep := ArcAng / ACornerCount; for i := 0 to ACornerCount - 1 do begin if i = 0 then begin if (p1 <> nil) or (p2 <> nil) then begin if (p1 <> nil) and (p2 <> nil) then begin {if Not AInverted then begin if GetRadOfLine(cp, p1^) > GetRadOfLine(cp, p2^) then pt := p2^ else pt := p1^; end else begin if GetRadOfLine(cp, p1^) < GetRadOfLine(cp, p2^) then pt := p2^ else pt := p1^; end;} pt := p1^; pt := GetRelativePointbyAngleFloat(ArcAng, cp, pt); if PointNear(pt, p2^, 1) then //if EQDP(pt, p2^) then pt := p1^ else pt := p2^; end else if (p1 <> nil) and (ArcAng = 360) then pt := p1^; StartPt := pt; end else begin pt := cp; pt.y := pt.y - radius; end; end else //15.09.2011 pt := GetRelativePointbyAngleFloat(AngleStep, cp, pt); pt := GetRelativePointbyAngleFloat(AngleStep * i, cp, StartPt); SetLength(Result, Length(Result)+1); Result[i] := pt; end; end; function GetLinesAngle(AP1, AP2, AP3, AP4: TDoublePoint): Double; begin // Координаты отрезков заданы точками (x1,y1)-(x2,y2) (x3,y3)-(x4,y4) // a = arctg[(y2 - y1)/(x2 - x1)] - arctg[(y4 - y3)/(x4 - x3)] Result := ArcTanh((AP2.y - AP1.y)/(AP2.x - AP1.x)) - ArcTanh((AP4.y - AP3.y)/(AP4.x - AP3.x)); end; function GetAreaFromPolygon3D(APoints: PDoublePointArr): Double; var IsResult: Boolean; begin Result := 0; IsResult := false; if Length(APoints^) > 2 then begin if EQDP(APoints^[0], APoints^[Length(APoints^)-1]) then begin // Треугольник if Length(APoints^) = 4 then begin Result := Result + GetTriangleArea3D(APoints^[0], APoints^[1], APoints^[2]); IsResult := true; end else // Трапеция if Length(APoints^) = 5 then begin Result := Result + GetTriangleArea3D(APoints^[0], APoints^[1], APoints^[2])+ GetTriangleArea3D(APoints^[2], APoints^[3], APoints^[0]); IsResult := true; end else // 5-ти угольник if Length(APoints^) = 6 then begin Result := Result + GetTriangleArea3D(APoints^[0], APoints^[1], APoints^[2])+ GetTriangleArea3D(APoints^[2], APoints^[3], APoints^[4])+ GetTriangleArea3D(APoints^[2], APoints^[4], APoints^[0]); IsResult := true; end else // 6-ти угольник if Length(APoints^) = 7 then begin Result := Result + GetTriangleArea3D(APoints^[0], APoints^[1], APoints^[2])+ GetTriangleArea3D(APoints^[2], APoints^[3], APoints^[4])+ GetTriangleArea3D(APoints^[4], APoints^[5], APoints^[0])+ // внутр-триугольник GetTriangleArea3D(APoints^[0], APoints^[2], APoints^[4]); IsResult := true; end else // 7-ти угольник if Length(APoints^) = 8 then begin Result := Result + GetTriangleArea3D(APoints^[0], APoints^[1], APoints^[2])+ GetTriangleArea3D(APoints^[2], APoints^[3], APoints^[4])+ GetTriangleArea3D(APoints^[4], APoints^[5], APoints^[6])+ GetTriangleArea3D(APoints^[6], APoints^[7], APoints^[0])+ // внутр-триугольник GetTriangleArea3D(APoints^[0], APoints^[2], APoints^[4])+ GetTriangleArea3D(APoints^[4], APoints^[6], APoints^[0]); IsResult := true; end; end; end; if Not IsResult then Result := GetAreaFromPolygon(APoints^); end; function GetPerimetrFromPolygon(APoints: PDoublePointArr): Double; var i: Integer; p1, p2: PDoublePoint; begin Result := 0; for i := 1 to Length(APoints^) do Result := Result + GetLineLenght(APoints^[i-1], APoints^[i]); end; procedure GetLinesNearPoints(ap1, ap2, bp1, bp2: PDoublePoint; var ap, bp: TDoublePoint); var APoints, BPoints: TList; i, j: Integer; LastDist, Dist: Double; begin ap := Doublepoint(0,0,0); bp := Doublepoint(0,0,0); APoints := TList.Create; APoints.Add(ap1); APoints.Add(ap2); BPoints := TList.Create; BPoints.Add(bp1); BPoints.Add(bp2); LastDist := -1; for i := 0 to APoints.Count - 1 do begin for j := 0 to BPoints.Count - 1 do begin Dist := GetLineLength(PDoublePoint(APoints[i])^, PDoublePoint(BPoints[j])^); if (LastDist = -1) or (Dist < LastDist) then begin LastDist := Dist; ap := PDoublePoint(APoints[i])^; bp := PDoublePoint(BPoints[j])^; end; end; end; APoints.Free; BPoints.Free; end; function IsConvexPolygon(APoints: PDoublePointArr; ALastPtInFirst: Boolean): Integer; // http://algolist.manual.ru/maths/geom/polygon/convex_or.php // Для выпуклого многоугольника все векторные произведения смежных сторон будут одинакового знака, // а если это не так, то будет присутствовать и произведение противоположного знака. var i,j,k: Integer; flag: Integer; z: Double; PtCount: Integer; begin Result := pltNone; PtCount := Length(APoints^); if ALastPtInFirst then PtCount := PtCount - 1; if PtCount > 2 then begin flag := 0; for i := 0 to PtCount - 1 do begin j := (i + 1) mod PtCount; k := (i + 2) mod PtCount; z := (APoints^[j].x - APoints^[i].x) * (APoints^[k].y - APoints^[j].y); z := z - (APoints^[j].y - APoints^[i].y) * (APoints^[k].x - APoints^[j].x); if z < 0 then flag := flag or 1 else if z > 0 then flag := flag or 2; if flag = 3 then begin Result := pltConcave; // вогнутый Exit; ///// EXIT ///// //Break; //// BREAK //// end; end; if flag <> 0 then Result := pltConvex // выпуклый else Result := pltNone; end; end; function OverlapDoubleRects(const R1, R2: TDoubleRect): Boolean; begin try Result := False; // Если R1.Left или R1.Right между R2.Left и R2.Right (Проверка по горизонтали) if ((R1.Left >= R2.Left) and (R1.Left <= R2.Right)) or ((R1.Right >= R2.Left) and (R1.Right <= R2.Right)) then begin // Если R1.Top или R1.Bottom между R2.Top и R2.Bottom (Проверка по Вертикали) if ((R1.Top >= R2.Top) and (R1.Top <= R2.Bottom)) or ((R1.Bottom >= R2.Top) and (R1.Bottom <= R2.Bottom)) then Result := True else // Если R2.Top или R2.Bottom между R1.Top и R1.Bottom (Проверка по Вертикали) if ((R2.Top >= R1.Top) and (R2.Top <= R1.Bottom)) or ((R2.Bottom >= R1.Top) and (R2.Bottom <= R1.Bottom)) then Result := True; end else // Если R2.Left или R2.Right между R1.Left и R1.Right (Проверка по горизонтали) if ((R2.Left >= R1.Left) and (R2.Left <= R1.Right)) or ((R2.Right >= R1.Left) and (R2.Right <= R1.Right)) then begin // Если R1.Top или R1.Bottom между R2.Top и R2.Bottom (Проверка по Вертикали) if ((R1.Top >= R2.Top) and (R1.Top <= R2.Bottom)) or ((R1.Bottom >= R2.Top) and (R1.Bottom <= R2.Bottom)) then Result := True else // Если R2.Top или R2.Bottom между R1.Top и R1.Bottom (Проверка по Вертикали) if ((R2.Top >= R1.Top) and (R2.Top <= R1.Bottom)) or ((R2.Bottom >= R1.Top) and (R2.Bottom <= R1.Bottom)) then Result := True; end; Except on E: Exception do Showmessage('R1.Top = ' + FloatTostr(R1.Top)); end; end; function CorrectAngle(aAngle: Double; AStep: Integer=360): Double; begin Result := aAngle; while Result > AStep do Result := Result - AStep; while Result < 0 do Result := Result + AStep; end; function GetTextHeight(FontHandle: HWND; AFont: TFont): Double; var DC: HDC; {SaveFont: HFONT; TTM: TTextMetric; StrHgt:integer;} mRes: Boolean; LogFnt : TLogFont; oldFont,newFont : HFont; IsTrueTypeFont : Boolean; fFontStyle : TFontStyles; fFontName : TFontName; fFontColor : TColor; Metrics: TTextMetric; begin Result := 0; {DC := GetDC(0); if (DC <> 0) then begin SaveFont := SelectObject(DC, FontHandle); mRes := GetTextMetrics(DC,TTM); if (mRes) then StrHgt:=TTM.tmHeight+TTM.tmExternalLeading; SelectObject(DC, SaveFont); ReleaseDC(0,DC); Result := StrHgt; end;} LogFnt.lfHeight := AFont.Height; //10; LogFnt.lfWidth := 10; LogFnt.lfEscapement := 0; LogFnt.lfWeight := FW_REGULAR; LogFnt.lfItalic := 0; LogFnt.lfUnderline := 0; LogFnt.lfStrikeOut := 0; LogFnt.lfCharSet := DEFAULT_CHARSET; LogFnt.lfOutPrecision := OUT_DEFAULT_PRECIS; LogFnt.lfClipPrecision := CLIP_DEFAULT_PRECIS; LogFnt.lfQuality := DEFAULT_QUALITY; LogFnt.lfPitchAndFamily := DEFAULT_PITCH or FF_DONTCARE; StrPCopy(LogFnt.lfFaceName, AFont.Name); //StrPCopy(LogFnt.lfFaceName, 'Arial'); newFont := CreateFontIndirect(LogFnt); DC := GetDC(0); if DC <> 0 then begin oldFont := SelectObject(DC,newFont); ZeroMemory(@Metrics, SizeOf(Metrics)); mRes := GetTextMetrics(DC, Metrics); if mRes then Result := Metrics.tmHeight; SelectObject(DC,oldFont); ReleaseDC(0,DC); end; end; procedure GetTextSize(AFontSize: Integer; AStyles: TFontStyles; const AFontName, AText: String; AStrings: TStrings; var h, w: Double; AStrH: Pointer=nil); var tmpCanvas: TCanvas; i: Integer; Str: String; DefinedH: Boolean; tw: Integer; Strings: TStrings; begin h := 0; w := 0; if AStrH <> nil then Integer(AStrH^) := 0; Strings := TStringList.Create; if (AStrings = nil) and (AText <> '') then begin Strings.Text := AText; end else if (assigned(AStrings)) then Strings.Text := AStrings.Text; if Strings <> nil then begin tmpCanvas := TCanvas.Create; tmpCanvas.Handle := GetDC(0); if tmpCanvas.Handle <> 0 then begin tmpCanvas.Font.Name := AFontName; tmpCanvas.Font.Size := AFontSize; tmpCanvas.Font.Style := AStyles; //h := tmpCanvas.TextHeight('W'); //w := tmpCanvas.TextWidth('W'); DefinedH := false; for i := 0 to Strings.Count - 1 do begin Str := Strings[i]; if Not DefinedH and (Str <> '') then begin h := tmpCanvas.TextHeight(Str); // Если не удалось определить высоту с этим шрифтом, то пробуем для Arial if h = 0 then begin tmpCanvas.Font.Name := 'Arial'; h := tmpCanvas.TextHeight(Str); end; DefinedH := true; if AStrH <> nil then Integer(AStrH^) := Trunc(h); end; tw := tmpCanvas.TextWidth(Str); if tw > w then w := tw; end; ReleaseDC(0,tmpCanvas.Handle); end; tmpCanvas.Free; h := h / 4 * Strings.Count + 1; w := (w + 3) / 4; if Strings <> nil then Strings.Free; end; end; // Tolik -- 25/11/2015 // Специально сделана копия для определения высоты CaptionsGroup ортолинии (на 1 меньше, чем в старой), // чтобы правильно спозиционировать надписи на линии procedure GetTextSizeCapt(AFontSize: Integer; AStyles: TFontStyles; const AFontName, AText: String; AStrings: TStrings; var h, w: Double; AStrH: Pointer = nil; CenterPoint: Boolean = False); //нужно при позиционировании надписи по центру, если будет несколько каб каналов на трассе function GetLineCountForCenterAlign(AList: TStrings): Integer; var i: Integer; begin Result := 1; if AList.Count > 1 then begin for i := 1 to AList.Count - 1 do begin Inc(Result); if AList[i] <> '' then break; end; end; end; var tmpCanvas: TCanvas; i, j: Integer; Str: String; DefinedH: Boolean; tw: Integer; Strings: TStrings; // Tolik --07/12/2015 Counter: Integer; // begin h := 0; w := 0; if AStrH <> nil then Integer(AStrH^) := 0; Strings := TStringList.Create; if (AStrings = nil) and (AText <> '') then begin Strings.Text := AText; end else if (assigned(AStrings)) then Strings.Text := AStrings.Text; if Strings <> nil then begin if (CenterPoint and (Strings.Count > 1)) then Counter := GetLineCountForCenterAlign(Strings) else Counter := Strings.Count; tmpCanvas := TCanvas.Create; tmpCanvas.Handle := GetDC(0); if tmpCanvas.Handle <> 0 then begin tmpCanvas.Font.Name := AFontName; tmpCanvas.Font.Size := AFontSize; tmpCanvas.Font.Style := AStyles; //h := tmpCanvas.TextHeight('W'); //w := tmpCanvas.TextWidth('W'); DefinedH := false; // for i := 0 to Strings.Count - 1 do for i := 0 to Counter - 1 do begin Str := Strings[i]; tw := 0; if Not DefinedH and (Str <> '') then begin h := tmpCanvas.TextHeight(Str); // Если не удалось определить высоту с этим шрифтом, то пробуем для Arial if h = 0 then begin tmpCanvas.Font.Name := 'Arial'; h := tmpCanvas.TextHeight(Str); end; DefinedH := true; if AStrH <> nil then Integer(AStrH^) := Trunc(h); end; tw := tmpCanvas.TextWidth(Str); if tw > w then w := tw; end; ReleaseDC(0,tmpCanvas.Handle); end; tmpCanvas.Free; if Counter > 1 then h := (h / 4 ) * Counter + 1 else h := h / 4 + 0.25; // для одной строки 1 не добавляем w := (w + 3) / 4; if Strings <> nil then Strings.Free; end; end; // 23/12/2015 -- вернет высоту function GetOneStringSize(AFontSize: Integer; AStyles: TFontStyles; const AFontName: String; MayZero: boolean): Double; var tmpCanvas: TCanvas; h: double; begin Result := 0; h := 0; tmpCanvas := TCanvas.Create; tmpCanvas.Handle := GetDC(0); if tmpCanvas.Handle <> 0 then begin tmpCanvas.Font.Name := AFontName; tmpCanvas.Font.Size := AFontSize; tmpCanvas.Font.Style := AStyles; h := tmpCanvas.TextHeight('W'); if (h = 0) and not MayZero then begin tmpCanvas.Font.Name := 'Arial'; h := tmpCanvas.TextHeight('W'); end; end; ReleaseDC(0,tmpCanvas.Handle); tmpCanvas.Free; if h <> 0 then Result := h / 4 + 0.25; end; // вернет количество пустых строк для Captions ортолинии function GetEmptyLinesCount(aLine: TOrthoLine): Integer; var i: Integer; FontStyles: TFontStyles; tmpCanvas: TCanvas; h: Double; begin Result := 1; try if aLine <> nil then begin if (aLine.CaptionsGroup <> nil) and (aLine.CaptionsGroup.InFigures.Count = 2) then begin FontStyles := []; if aLine.FCaptionsFontBold then FontStyles := [fsBold]; tmpCanvas := TCanvas.Create; tmpCanvas.Handle := GetDC(0); if tmpCanvas.Handle <> 0 then begin tmpCanvas.Font.Name := aLine.FCaptionsFontName; tmpCanvas.Font.Size := aLine.FCaptionsFontSize; tmpCanvas.Font.Style := FontStyles; h := tmpCanvas.TextHeight('W'); if h = 0 then begin tmpCanvas.Font.Name := 'Arial'; h := tmpCanvas.TextHeight('W'); end; end; ReleaseDC(0,tmpCanvas.Handle); tmpCanvas.Free; if h <> 0 then h := h / 4; while (Result*h) < aLine.GrpSizeY do Inc(Result); end; end; except on E: Exception do addExceptionToLogEx('U_Common.GetEmptyLinesCount', E.Message); end; end; // function DefineFrameByPrinter(aRect: TDoubleRect): TDoubleRect; var PSD: TPrinterSetupDialog; DPIX: double; DPIY: double; OFFX: double; OFFY: double; OFFMMX: double; OFFMMY: double; begin Result := aRect; PSD := TPrinterSetupDialog.Create(nil); try if PSD.Execute then begin if (Printer <> nil) then begin DPIX := GetDeviceCaps(Printer.Handle, LOGPIXELSX); DPIY := GetDeviceCaps(Printer.Handle, LOGPIXELSY); OFFX := GetDeviceCaps(Printer.Handle, PHYSICALOFFSETX); OFFY := GetDeviceCaps(Printer.Handle, PHYSICALOFFSETY); OFFMMX := (OFFX / DPIX) * 25.4; OFFMMY := (OFFY / DPIY) * 25.4; Result.Top := Round3(aRect.Top - OFFMMY); if Result.Top < 0 then Result.Top := 1; // Учитываем что слева смещение не сделано // OFFMMX * 2 = под край печатаемой области справа Result.Right := Round3(OFFMMX * 2 + (aRect.Right - OFFMMX)); if Result.Right < 0 then Result.Right := 1; Result.Bottom := Round3(OFFMMY * 2 + (aRect.Bottom - OFFMMY)); if Result.Bottom < 0 then Result.Bottom := 1; end; end; finally PSD.Free; end; end; function GetMultipleFromNB:Boolean; //From Dimon ;) var Side1,Side2: String; CurrDat: PObjectData; SCSComponInNormBase: TSCSComponent; j: integer; begin Result := false; SCSComponInNormBase := nil; CurrDat := F_NormBase.Tree_Catalog.selected.data; if CurrDat <> nil then if (CurrDat.ItemType in [itComponLine, itComponCon, itArhRoofSeg, itArhRoofHip, itArhRoofHipCorner]) then begin if SCSComponInNormBase = nil then begin SCSComponInNormBase := TSCSComponent.Create(F_NormBase); //Создание нового компона end; SCSComponInNormBase.Clear; begin SCSComponInNormBase.Clear; SCSComponInNormBase.LoadComponentByID(CurrDat.ObjectID, true, true, false);//Загружаем его интерфейсы.А больше ничего и не нужно end; end; for j := 0 to SCSComponInNormBase.Interfaces.Count - 1 do begin if TSCSInterface(SCSComponInNormBase.Interfaces[j]).TypeI = itFunctional then begin //Так как у функциональных онтерфейсов SideSection одинаковый запоминаем первый попавшийся Result := Boolean(TSCSInterface(SCSComponInNormBase.Interfaces[j]).Multiple); break; end; end; SCSComponInNormBase.Clear; FreeAndNil(SCSComponInNormBase); end; //Функция сравнивает параметры выбранного компонента из дерева с тем, что уже имеется на каде Function CheckComponentsForSideSection(CurrCompon: TSCSComponent):Boolean; //From Dimon ;) var Side1,Side2: String; CurrDat: PObjectData; SCSComponInNormBase: TSCSComponent; j: integer; begin Result := false; // Tolik 01/10/2021-- if GDropComponent <> nil then begin Result := True; exit; end; // SCSComponInNormBase := nil; // Tolik -- 22/05/2017 -*- if F_NormBase.Tree_Catalog.selected = nil then exit; // CurrDat := F_NormBase.Tree_Catalog.selected.data; if CurrDat <> nil then if (CurrDat.ItemType in [itComponLine, itComponCon, itArhRoofSeg, itArhRoofHip, itArhRoofHipCorner]) then begin if SCSComponInNormBase = nil then begin SCSComponInNormBase := TSCSComponent.Create(F_NormBase); //Создание нового компона end; SCSComponInNormBase.Clear; begin SCSComponInNormBase.Clear; SCSComponInNormBase.LoadComponentByID(CurrDat.ObjectID, true, true, false);//Загружаем его интерфейсы.А больше ничего и не нужно end; end; for j := 0 to SCSComponInNormBase.Interfaces.Count - 1 do begin if TSCSInterface(SCSComponInNormBase.Interfaces[j]).TypeI = itFunctional then begin //Так как у функциональных онтерфейсов SideSection одинаковый запоминаем первый попавшийся Side1 := TSCSInterface(SCSComponInNormBase.Interfaces[j]).SideSection; break; end; end; for j := 0 to CurrCompon.Interfaces.Count - 1 do begin //То же самое с проверяемым компоном if TSCSInterface(CurrCompon.Interfaces[j]).TypeI = itFunctional then begin Side2 := TSCSInterface(CurrCompon.Interfaces[j]).SideSection; break; end; end; SCSComponInNormBase.Clear; FreeAndNil(SCSComponInNormBase); //Сверяем если одинаковые, можно делать различные махинации if Side1 = Side2 then result := true; end; { THashedStringListMy } procedure THashedStringListMy.Changed; begin inherited; FValueHashValid := False; FNameHashValid := False; end; destructor THashedStringListMy.Destroy; begin FValueHash.Free; FNameHash.Free; inherited; end; function THashedStringListMy.IndexOf(const S: string): Integer; begin UpdateValueHash; if not CaseSensitive then Result := FValueHash.ValueOf(AnsiUpperCase(S)) else Result := FValueHash.ValueOf(S); end; function THashedStringListMy.IndexOfName(const Name: string): Integer; begin UpdateNameHash; if not CaseSensitive then Result := FNameHash.ValueOf(AnsiUpperCase(Name)) else Result := FNameHash.ValueOf(Name); end; procedure THashedStringListMy.UpdateNameHash; var I: Integer; P: Integer; Key: string; begin if FNameHashValid then Exit; if FNameHash = nil then FNameHash := TStringHash.Create(1024) else FNameHash.Clear; for I := 0 to Count - 1 do begin Key := Get(I); P := AnsiPos('=', Key); if P <> 0 then begin if not CaseSensitive then Key := AnsiUpperCase(Copy(Key, 1, P - 1)) else Key := Copy(Key, 1, P - 1); FNameHash.Add(Key, I); end; end; FNameHashValid := True; end; procedure THashedStringListMy.UpdateValueHash; var I: Integer; begin if FValueHashValid then Exit; if FValueHash = nil then FValueHash := TStringHash.Create(1024) else FValueHash.Clear; for I := 0 to Count - 1 do if not CaseSensitive then FValueHash.Add(AnsiUpperCase(Self[I]), I) else FValueHash.Add(Self[I], I); FValueHashValid := True; end; // Tolik 07/11/2018 -- function GetFigureParams(AIDFigure: Integer; AObjectCatalog: TSCSCatalog = nil): TObjectParams; var SCSCatalog: TSCSCatalog; begin ZeroMemory(@Result, SizeOf(TObjectParams)); if AObjectCatalog = nil then begin SCSCatalog := nil; SCSCatalog := F_ProjMan.GSCSBase.CurrProject.GetCatalogFromReferencesBySCSID(AIDFigure); if Assigned(SCSCatalog) then begin Result := SCSCatalog.GetObjectParams; end; end else Result := AObjectCatalog.GetObjectParams; end; // Tolik 30/08/2019 -- function CheckCanDelLayer(aLayer: TLayer): Boolean; var Figure: TFigure; i: Integer; function CheckGRPFigures(aFigure: TFigureGrp): Boolean; var i: Integer; FFigure: TFigure; begin Result := True; for i := 0 to aFigure.InFigures.Count - 1 do begin FFigure := TFigure(aFigure.InFigures[i]); if not FFigure.deleted then begin Result := (FFigure.LayerHandle <> LongInt(aLayer)); if Result then begin if (FFigure is TFigureGrp) then Result := CheckGRPFigures(TFigureGrp(FFigure)) else if CheckFigureByClassName(FFigure, 'TBlock') then Result := CheckGrpFigures(TBlock(FFigure)); end; end; if not Result then break; end; end; begin Result := True; try for i := 0 to GCadForm.PCad.Figures.Count - 1 do begin Figure := TFigure(GCadForm.PCad.Figures[i]); if not Figure.deleted then begin if (Figure.LayerHandle <> LongInt(aLayer)) then begin if (Figure is TFigureGrp) then Result := CheckGRPFigures(TFigureGrp(Figure)) else if CheckFigureByClassName(Figure, 'TBlock') then Result := CheckGrpFigures(TBlock(Figure)); end; end; if not Result then break; end; except on E: Exception do; end; end; //Проверяет версию проекта, возвращает TRUE, если версия проекта меньше 26 // тут подразумевается, что все версии до 26-й созданы в Делфи_6 // и для них при загрузке быдем выдавать сообшения после проверки // о необходимости перезагрузки растровых чертежей function CheckProjForOptimizedRasterImageLoad: Boolean;// Tolik 31/01/2020 var i, j: Integer; currList: TSCSList; CurrCad: TF_CAD; Figure: TFigure; begin Result := False; Try if F_ProjMan.GSCSBase.CurrProject <> nil then if F_ProjMan.GSCSBase.CurrProject.CurrBuildID < ProjBuildIDWithOptimizedRasterImageLoad then begin if F_ProjMan.GSCSBase.CurrProject.ProjectLists.Count > 0 then begin for i := F_ProjMan.GSCSBase.CurrProject.ProjectLists.Count - 1 downto 0 do begin currList := F_ProjMan.GSCSBase.CurrProject.ProjectLists[i]; if currList <> nil then begin CurrCad := GetListByID(currList.SCSID); if currCad <> nil then begin for j := 0 to CurrCad.PCad.Figures.Count - 1 do begin if TFigure(CurrCad.PCad.Figures[j]) is TBMPObject then begin Result := True; exit; end; end; end; end; end; end; end; Except On E: Exception do Result := False; End; end; procedure RestoreCadGridStatus; // Tolik 04/03/2021 -- begin if GCadForm <> nil then begin if GCadForm.PCad <> nil then begin if GSavedSnapGridStatus <> -1 then begin if GCadForm.PCad.SnapToGrids <> boolean(GSavedSnapGridStatus) then GCadForm.tbSnapGrid.Click; GSavedSnapGridStatus := -1; end; end; end; end; Function GetPropValFromFigure(aFigureID: Integer; aCad: TF_Cad; aPropValSysName: String): string; // Tolik 09/03/2021 -- var Figure: TFigure; SCSList: TSCSList; SCSCatalog: TSCSCatalog; SCSCompon: TSCScomponent; Prop: PProperty; begin Result := 'no result'; Prop := nil; Figure := GetFigureByID(aCad, aFigureID); if Figure <> nil then if not Figure.deleted then begin SCSList := F_ProjMan.GSCSBase.CurrProject.GetListBySCSID(aCad.FCADListID); if SCSList <> nil then begin SCSCatalog := SCSList.GetCatalogFromReferencesBySCSID(aFigureID); if SCSCatalog <> nil then begin SCSCompon := SCSCatalog.GetFirstComponent; if SCSCompon <> nil then Prop := SCSCompon.GetPropertyBySysName(aPropValSysName); if Prop <> nil then Result := Prop.Value; end; end; end; end; function CheckConnectorUseUGOBounds(aConnector: TConnectorObject): integer; // Tolik 09/03/2021 -- var PropVal: string; begin //Result := biFalse; Result := biTrue; if Assigned(aConnector) then if not aConnector.deleted then begin if Assigned(aConnector.Owner) then if Assigned(aConnector.Owner.Owner) then begin PropVal := GetPropValFromFigure(aConnector.ID, TF_Cad(aConnector.Owner.Owner), pnNotUseUgoBounds); if PropVal = 'no result' then //Result := biFalse Result := biTrue else begin if PropVal = '1' then //Result := biTrue Result := biFalse else //Result := biFalse; Result := biTrue; end; end; end; end; Procedure ClearCADsInProgress(var aCadList: TList); // Tolik 24/03/2021 -- var i: integer; begin try for i := aCadList.Count - 1 downto 0 do begin if Assigned(TF_CAD(aCadList[i])) then begin if Assigned(TF_CAD(aCadList[i]).PCad) then begin if TF_CAD(aCadList[i]).PCad.UpdateCount = 0 then aCadList.delete(i); end else aCadList.delete(i); end else aCadList.delete(i); end; Except aCadList.Clear; end; end; function CheckNeedDrawGuides(aPortCount: integer): Boolean; // Tolik 26/03/2021 -- begin if GDropComponent <> nil then begin Result := ((aPortCount < 10) and (aPortCount > 0)) or (GDropComponent.ComponentType.Sysname = ctsnLAMP) or (GDropComponent.ComponentType.Sysname = ctsnSocket) or (GDropComponent.ComponentType.Sysname = ctsnPlugSwitch) or (GDropComponent.ComponentType.Sysname = ctsnTerminalBox); end else Result := ((aPortCount < 10) and (aPortCount > 0)); end; Function CreateTextObject(x,y: Double; aCaption: TStringList; aisBold: Boolean = False): TRichText;// Tolik var i, j, k: Integer; LHandle: Integer; BlockX, BlockY: double; TM: TTextMetric; xCanvas: TMetafileCanvas; h, w: double; Canvas: TCanvas; TextW, TextH: Double; function GetMaxTextW: Double; var i: integer; currW, MaxW: Double; Canvas: TMetafileCanvas; tt: TMetafile; begin Result := -1; TextH := -1; if aCaption.Count > 0 then begin tt := TMetaFile.Create; tt.Enhanced := True; Canvas := TMetafileCanvas.Create(tt, 0); Canvas.Font.Name := GCadForm.PCad.Font.Name; Canvas.Font.Size := GCadForm.PCad.Font.Size; if aisBold then begin Canvas.Font.Style := Canvas.Font.Style - [fsBold]; // на всякий Canvas.Font.Style := Canvas.Font.Style + [fsBold]; end; MaxW := -1; for i := 0 to aCaption.Count - 1 do begin currW := Canvas.TextWidth(aCaption[i]); if MaxW = -1 then MaxW := currW else MaxW := Max(maxW, currW); end; GetTextMetrics(Canvas.Handle, TM); TextH := TM.tmHeight / 4; if aCaption.Count > 1 then TextH := TextH * aCaption.Count + 1; end; if MaxW <> -1 then Result := MaxW; Canvas.Free; tt.Free; end; begin Result := nil; LHandle := GCadForm.PCad.GetLayerHandle(1); if aCaption <> nil then begin TextW := GetMaxTextW; TextW := (TextW + 3)/4; //Result := TRichText.create(-100, -100, -100, -100, 1, ord(psSolid), clBlue, ord(bsClear), clBlack, GCadForm.PCad.GetLayerHandle(0), mydsNormal, GCadForm.PCad); Result := TRichText.create(-100, -100, -100 + TextW, -100, 1, ord(psSolid), clBlue, ord(bsClear), clBlack, GCadForm.PCad.GetLayerHandle(0), mydsNormal, GCadForm.PCad); Result.re.Font := GCadForm.PCad.Font; //Result.re.Font.Size := 12; Result.RE.Lines.Clear; for i := 0 to aCaption.Count - 1 do begin Result.re.Lines.Add(aCaption.Strings[i]); end; if aisBold then begin Result.re.Font.Style := Result.re.Font.Style - [fsBold]; // на всякий Result.re.Font.Style := Result.re.Font.Style + [fsBold]; end; GCadForm.PCad.AddCustomFigure(1, Result, False); //RefreshCAD(GCadForm.PCad); // получить свойства // Tolik Result.ttMetaFile:= TMetaFile.Create; Result.ttMetafile.Enhanced := True; xCanvas := TMetafileCanvas.Create(Result.ttMetafile, 0); xCanvas.Font.Name := Result.re.Font.Name; xCanvas.Font.Size := Result.re.Font.Size; if aisBold then begin xCanvas.Font.Style := Result.re.Font.Style - [fsBold]; // на всякий xCanvas.Font.Style := Result.re.Font.Style + [fsBold]; end; GetTextMetrics(xCanvas.Handle, TM); if TextH = -1 then h := TM.tmHeight / 4 * Result.re.Lines.Count + 1 else h := TextH; w := 0; if TextW = -1 then begin for i := 0 to Result.re.Lines.Count - 1 do begin if w < xCanvas.TextWidth(Result.Re.Lines[i]) then w := xCanvas.TextWidth(Result.Re.Lines[i]); end; w := (w + 3) / 4 ; end else w := TextW; FreeAndNil(xCanvas); GCadForm.PCad.Figures.Remove(Result); Result.Free; Result := TRichText.create(-100, -100, -100 + w, -100 + h, 1, ord(psSolid), clBlue, ord(bsClear), clBlack, GCadForm.PCad.GetLayerHandle(0), mydsNormal, GCadForm.PCad); //Result.re.Font.Size := ; Result.re.Font := GCadForm.PCad.Font; Result.RE.Font.Size := GCadForm.PCad.Font.Size; //Result.RE.Font.Size := 12; if aisBold then begin Result.re.Font.Style := Result.re.Font.Style - [fsBold]; // на всякий Result.re.Font.Style := Result.re.Font.Style + [fsBold]; end; Result.RE.Lines.Clear; for i := 0 to aCaption.Count - 1 do begin Result.re.Lines.Add(aCaption.Strings[i]); end; GCadForm.PCad.AddCustomFigure(1, Result, False); Result.Move(x + 100, y + 100); RefreshCAD(GCadForm.PCad); { Result.ttMetaFile.Free; // пересоздать с новыми свойствами if Result <> nil then begin aList.PCad.Figures.Remove(Result); FreeAndNil(Result); end; } end; end; Procedure DeSelectSCSFigureInPM(aID: Integer); // Tolik 28/04/2021 -- var i: integer; FNode, ChildNode: TTreeNode; SelList: TList; ChangeEvent: TTVChangedEvent; NodeSelected: Boolean; // Tolik 11/06/2021 -- Procedure deselectNode(aNode: TTreeNode); var i: integer; ChildNode: TtreeNode; begin if aNode <> nil then begin if ANode.Selected then begin aNode.Selected := False; //F_ProjMan.Tree_Catalog.Deselect(aNode); SelList.Remove(aNode); end; if aNode.Count > 0 then // childs begin ChildNode := aNode.getFirstChild; While ChildNode <> nil do begin deselectNode(ChildNode); ChildNode := aNode.GetNextChild(ChildNode); end; end; end; end; // Toik 11/06/2021 -- function CheckSelectedNode(ANode: TTreeNode): Boolean; var ChildNode: TTreeNode; begin Result := aNode.Selected; if Not Result then begin ChildNode := aNode.getFirstChild; While ChildNode <> nil do begin Result := CheckSelectedNode(ChildNode); if Result then exit; ChildNode := aNode.GetNextChild(ChildNode); end; end; end; // begin Nodeselected := False; FNode := F_ProjMan.FindComponOrDirInTree(AId, false); if FNode <> nil then NodeSelected := CheckSelectedNode(FNode); { if FNode <> nil then F_ProjMan.Tree_Catalog.Deselect(FNode);} if NodeSelected then begin SelList := nil; SelList := TList.Create; F_ProjMan.Tree_Catalog.GetSelections(SelList); Try FNode := F_ProjMan.FindComponOrDirInTree(AId, false); if FNode <> nil then begin begin deselectNode(FNode); F_ProjMan.Tree_Catalog.ClearSelection(false); if SelList.Count > 0 then for i := 0 to SelList.Count - 1 do TTreeNode(SelList[i]).Selected := True; end; end; Except on E: Exception do; End; if SelList <> nil then SelList.free; end; end; (* Procedure BuildElectricianChemeList(aAVR_Compon: TSCSComponent; aBoxList: TSCSComponents; aSwitchList, aConnectedList: TList; aCableList: TSCSComponents); var i, j, k, l, m: integer; Line_x1, Line_x2,Line_y1,Line_y2: Double; //Phaze_Line, NullLine, GroundLine: TOrthoLine; // Земля, фаза, ноль... Phaze_Line, NullLine, GroundLine, SLine: TLine; // Земля, фаза, ноль... ListParams: TListParams; OldGCadForm: TF_Cad; TextFigList: TList; Line_Count: Integer; Switches, Connections: TSCSComponents; ConnectedCompon: TSCSComponent; CurrText: TRichText; GuidIconList, TextList: TStringList; IconFigList: TList; ParentCatalog: TSCSCatalog; ComponFigure: TFigure; ComponCad, currCad: TF_Cad; ComponList: TSCSList; DrawFigureStream: TMemoryStream; ComponDrawFigure: TFigureGrpMod; ObjImage: TBMPObject; Stream: Classes.TStream; DownObjectList, ColObjList: TList; LineCounter: Integer; ConnectedSwitchCompon: TSCSComponent; SwitchNames: TStringList; MaxTableHeightArray, MaxTableWidthArray: array of double; // AllChemeFiguresList: TList; // все фигуры, из которых нарисована схема function GetComponNamesCounted(aList: TSCSComponents): TStringList; var i: integer; CanProceed: Boolean; currCount: integer; ComponName: string; LocalList: TSCSComponents; begin Result := TStringList.Create; if aList <> nil then begin if aList.Count > 0 then begin if aList.Count = 1 then begin Result.Add(aList[0].Name + ' 1' + cMasterCompl_Msg5); end else begin LocalList := TSCSComponents.Create(false); for i := 0 to aList.Count - 1 do LocalList.Add(aList[i]); while LocalList.Count > 0 do begin currCount := 0; ComponName := LocalList[0].Name; for i := LocalList.Count - 1 downto 0 do begin if LocalList[i].Name = ComponName then begin inc(currCount); LocalList.Delete(i); end; end; if currCount > 1 then begin for i := 0 to aList.Count - 1 do begin if aList[i].Name = ComponName then begin ComponName := aList[i].ComponentType.NamePlural; break; end; end; end; Result.Add(ComponName + ' ' + inttostr(currCount) + cMasterCompl_Msg5) end; LocalList.Free; end; end; end; end; Procedure CountMaxValues(aList: TList); var i, j: integer; ObjList: tList; Fig: TFigure; ML, MW: integer; MaxWVal, MaxHVal: Double; maxx, maxy, minx, miny: Double; TableHeightArray, TableWidthArray: array of array of double; MaxWidth, MaxHeight: Double; begin SetLength(TableHeightArray, 6); SetLength(TableWidthArray, 6); SetLength(MaxTableHeightArray, 6); // высота каждой строчки SetLength(MaxTableWidthArray, aList.Count); // ширина каждого столбика for i := 0 to 5 do SetLength(TableHeightArray[i], aList.Count); for i := 0 to 5 do SetLength(TableWidthArray[i], aList.Count); ML := 0; MW := 0; for i := 0 to aList.Count - 1 do begin ObjList := TList(aList[0]); for j := 0 to ObjList.Count - 1 do begin Fig := TFigure(ObjList[j]); if fig is TRichText then TRichText(Fig).GetBounds(maxx, maxy, minx, miny) else if fig is TFigureGrpMod then TFigureGrpMod(Fig).GetBounds(maxx, maxy, minx, miny) else Fig.GetBounds(maxx, maxy, minx, miny); TableHeightArray[j, i] := maxy - miny; TableWidthArray[j, i] := maxx - minx; end; end; // ширина каждого столбика for i := 0 to aList.Count - 1 do begin MaxWidth := TableWidthArray[i, 0]; for j := 0 to Length(TableWidthArray[i]) - 1 do begin if CompareValue(MaxWidth, TableWidthArray[j,i]) = -1 then MaxWidth := TableWidthArray[j, i]; end; MaxTableWidthArray[i] := Maxwidth; end; // высота каждой строчки for j := 0 to 5 do begin MaxHeight := TableHeightArray[j, 0]; for i := 0 to aList.Count - 1 do begin if CompareValue(MaxHeight, TableHeightArray[j, i]) = -1 then MaxHeight := TableHeightArray[j, i]; end; MaxTableHeightArray[j] := MaxHeight; end; SetLength(TableHeightArray, 0); SetLength(TableWidthArray, 0); end; Procedure DrawPoint(ax, ay: Double; aColor: TColor); var Circle: TCircle; begin // Circle := TCircle.Create(ax, ay, 1, 1, ord(psSolid), aColor, ord(bsClear), clBlack, // GCadForm.PCad.GetLayerHandle(0), mydsNormal, GCadForm.PCad); Circle := TCircle.Create(ax, ay, 1, 1, ord(psSolid), aColor, ord(bsSolid), clBlack, GCadForm.PCad.GetLayerHandle(0), mydsNormal, GCadForm.PCad); GCadForm.PCad.AddCustomFigure(1, TFigure(Circle), false); end; Procedure DrawConnectionLine(ax,ay: Double); var i: integer; dist: Double; begin Dist := ay - GroundLine.ap1.y; DrawPoint(ax, ay, clBlack); DrawPoint(ax, Phaze_Line.ap1.y, clBlack);//фаза SLine := TLine.create(ax, Phaze_Line.ap1.y, ax, GroundLine.ap1.y + 10, 2, ord(psSolid), clBlack, 0, GCadForm.PCad.GetLayerHandle(0), mydsNormal, GCadForm.PCad); GCadForm.PCad.AddCustomFigure(1, TFigure(SLine), false); //крестик SLine := TLine.create(ax - 2, GroundLine.ap1.y + 10, ax + 2, GroundLine.ap1.y + 10, 2, ord(psSolid), clBlack, 0, GCadForm.PCad.GetLayerHandle(0), mydsNormal, GCadForm.PCad); GCadForm.PCad.AddCustomFigure(1, TFigure(SLine), false); SLine.Rotate((45/180)*PI); SLine := TLine.create(ax - 2, GroundLine.ap1.y + 10, ax + 2, GroundLine.ap1.y + 10, 2, ord(psSolid), clBlack, 0, GCadForm.PCad.GetLayerHandle(0), mydsNormal, GCadForm.PCad); GCadForm.PCad.AddCustomFigure(1, TFigure(SLine), false); SLine.Rotate((-45/180)*PI); DrawPoint(ax + 5, NullLine.ap1.y, clBlack); // ноль SLine := TLine.create(ax + 5, NullLine.ap1.y, ax + 5, GroundLine.ap1.y + Round(Dist* 0.6), 2, ord(psSolid), clBlack, 0, GCadForm.PCad.GetLayerHandle(0), mydsNormal, GCadForm.PCad); GCadForm.PCad.AddCustomFigure(1, TFigure(SLine), false); SLine := TLine.create(ax + 5, GroundLine.ap1.y + Round(Dist* 0.6), ax, GroundLine.ap1.y + Round(Dist* 0.7), 2, ord(psSolid), clBlack, 0, GCadForm.PCad.GetLayerHandle(0), mydsNormal, GCadForm.PCad); GCadForm.PCad.AddCustomFigure(1, TFigure(SLine), false); DrawPoint(ax + 10, GroundLine.ap1.y, clBlack); //земля SLine := TLine.create(ax + 10 , GroundLine.ap1.y, ax + 10 , GroundLine.ap1.y + Round(Dist* 0.6), 2, ord(psSolid), clBlack, 0, GCadForm.PCad.GetLayerHandle(0), mydsNormal, GCadForm.PCad); GCadForm.PCad.AddCustomFigure(1, TFigure(SLine), false); SLine := TLine.create(ax + 10 , GroundLine.ap1.y + Round(Dist* 0.6), ax, GroundLine.ap1.y + Round(Dist* 0.7), 2, ord(psSolid), clBlack, 0, GCadForm.PCad.GetLayerHandle(0), mydsNormal, GCadForm.PCad); GCadForm.PCad.AddCustomFigure(1, TFigure(SLine), false); // снизу SLine := TLine.create(ax, ay, ax , GroundLine.ap1.y + Round(Dist* 0.4), 2, ord(psSolid), clBlack, 0, GCadForm.PCad.GetLayerHandle(0), mydsNormal, GCadForm.PCad); GCadForm.PCad.AddCustomFigure(1, TFigure(SLine), false); SLine := TLine.create(ax, GroundLine.ap1.y + Round(Dist* 0.4), ax - 8, GroundLine.ap1.y + 10, 2, ord(psSolid), clBlack, 0, GCadForm.PCad.GetLayerHandle(0), mydsNormal, GCadForm.PCad); GCadForm.PCad.AddCustomFigure(1, TFigure(SLine), false); // Кабель подписать if ConnectedSwitchCompon <> nil then begin TextList.Clear; TextList.Add(ConnectedSwitchCompon.GetNameForVisible); CurrText := CreateTextObject(ax, ay, TextList, True); CurrText.Move(ax - 6 - CurrText.CenterPoint.x , ay - Dist/3 - 3 - currText.CenterPoint.y); CurrText.Rotate(-0.5 * PI); end; end; Procedure DrawTable; var i, j: integer; bx, by, sx, sy: Double; figList: TList; MaxHeight, MaxWidth: double; Fig: TFIgure; SLine: TLine; NPoint: TDoublePoint; UserRect: TRectangle; begin { SLine := TLine.create(Line_x1, Line_y2, Line_x2, Line_y2, 2, ord(psSolid), clBlack, 0, GCadForm.PCad.GetLayerHandle(0), mydsNormal, GCadForm.PCad); GCadForm.PCad.AddCustomFigure(1, TFigure(SLine), false); } bx := GCadForm.PCad.WorkWidth/10 + 5; for i := 0 to DownObjectList.Count - 1 do begin ConnectedSwitchCompon := nil; // кабель от автомата if i > 0 then begin if aCableList.Count >= (i - 1) then ConnectedSwitchCompon := aCableList[i - 1]; end; FigList := TList(DownObjectList[i]); by := 180; //(GCadForm.PCad.WorkHeight/2); SLine := TLine.create(bx - 5, by - 3 - MaxTableHeightArray[0], bx + MaxTableWidthArray[i] + 5, by - 3 - MaxTableHeightArray[0], 2, ord(psSolid), clBlack, 0, GCadForm.PCad.GetLayerHandle(0), mydsNormal, GCadForm.PCad); GCadForm.PCad.AddCustomFigure(1, TFigure(SLine), false); for j := 0 to FigList.Count - 1 do begin Fig := TFigure(FigList[j]); Fig.Move(bx - Fig.ap4.x , by - Fig.ap4.y); SLine := TLine.create(bx - 5, by + 3 , bx + MaxTableWidthArray[i] + 5, by + 3, 2, ord(psSolid), clBlack, 0, GCadForm.PCad.GetLayerHandle(0), mydsNormal, GCadForm.PCad); by := by + MaxTableHeightArray[j] + 5; GCadForm.PCad.AddCustomFigure(1, TFigure(SLine), false); end; if i > 0 then begin DrawConnectionLine(bx + (MaxTableWidthArray[i])/2 ,180 - 3 - MaxTableHeightArray[0]); // автомат подписать TextList.Clear; TextList.Add(SwitchNames[i - 1]); CurrText := CreateTextObject(bx + (MaxTableWidthArray[i])/2 - 25, GroundLine.ap1.y + 5, TextList, True); TextList.Clear; end; bx := bx + MaxTableWidthArray[i] + 10; SLine := TLine.create(bx - 5, 180 - 3 - MaxTableHeightArray[0], bx - 5, by - 6, 2, ord(psSolid), clBlack, 0, GCadForm.PCad.GetLayerHandle(0), mydsNormal, GCadForm.PCad); GCadForm.PCad.AddCustomFigure(1, TFigure(SLine), false); if i = 0 then begin //Левая SLine := TLine.create(GCadForm.PCad.WorkWidth/10 - 10, 180 - 3 - MaxTableHeightArray[0], GCadForm.PCad.WorkWidth/10 - 10, by - 6, 2, ord(psSolid), clBlack, 0, GCadForm.PCad.GetLayerHandle(0), mydsNormal, GCadForm.PCad); GCadForm.PCad.AddCustomFigure(1, TFigure(SLine), false); //Правая SLine := TLine.create(GCadForm.PCad.WorkWidth/10, 180 - 3 - MaxTableHeightArray[0], GCadForm.PCad.WorkWidth/10, by - 6, 2, ord(psSolid), clBlack, 0, GCadForm.PCad.GetLayerHandle(0), mydsNormal, GCadForm.PCad); GCadForm.PCad.AddCustomFigure(1, TFigure(SLine), false); //Верхняя SLine := TLine.create(GCadForm.PCad.WorkWidth/10 - 10, 180 - 3 - MaxTableHeightArray[0], GCadForm.PCad.WorkWidth/10, 180 - 3 - MaxTableHeightArray[0], 2, ord(psSolid), clBlack, 0, GCadForm.PCad.GetLayerHandle(0), mydsNormal, GCadForm.PCad); GCadForm.PCad.AddCustomFigure(1, TFigure(SLine), false); //Нижняя SLine := TLine.create(GCadForm.PCad.WorkWidth/10 - 10, by - 6, GCadForm.PCad.WorkWidth/10, by - 6, 2, ord(psSolid), clBlack, 0, GCadForm.PCad.GetLayerHandle(0), mydsNormal, GCadForm.PCad); GCadForm.PCad.AddCustomFigure(1, TFigure(SLine), false); end; end; bx := bx + 10; //if Phaze_Line.ap2.x < bx then begin NPoint.x := bx; NPoint.z := 0; NPoint.y := Phaze_Line.ap2.y; Phaze_Line.ActualPoints[2] := NPoint; NPoint.y := NullLine.ap2.y; NullLine.ActualPoints[2] := NPoint; NPoint.y := GroundLine.ap2.y; GroundLine.ActualPoints[2] := NPoint; end; UserRect := TRectangle.create(Phaze_Line.ap1.x - 3 , Phaze_Line.ap1.y - 20, Phaze_Line.ap2.x + 5, 160 , 2, ord(psDash), clBlack, ord(bsClear), clRed, GCadForm.PCad.GetLayerHandle(0), mydsNormal, GCadForm.PCad); GCadForm.PCad.AddCustomFigure(1, TFigure(UserRect), false); end; Begin try OldGCadForm := GCadForm; ListParams := GetListParamsForNewList; ListParams.Caption := 'Схема однолинейная';//cChooseComponType_Mes1; ListParams.Name := ListParams.Caption; ListParams.MarkID := 0; //ListParams.Settings.ListType := lt_ProjectPlan; ListParams.Settings.ListType := lt_ElScheme; MakeEditList(meMake, ListParams, False); AllChemeFiguresList := TList.Create; //DrawProjectPlan(GCadForm, ComponTypes, cbDivideGroupsByJoinedNetTypes.Checked, cbShowGroupContents.Checked); //DisableOptionsForDesignList; except on e: Exception do; end; if GCadForm <> OldGCadForm then begin Line_x1 := GCadForm.PCad.WorkWidth/10 + 30; //Line_y1 := GCadForm.PCad.WorkHeight/2; Line_y1 := GCadForm.PCad.WorkHeight/3; Line_x2 := GCadForm.PCad.WorkWidth/2; { Phaze_Line := TOrthoLine.create(Line_x1, Line_y1, 0, Line_x2, Line_y1, 0, 4, ord(psSolid), clBlue, 0, GCadForm.PCad.GetLayerHandle(0), mydsNormal, GCadForm.PCad, False, False); GCadForm.PCad.AddCustomFigure(1, TFigure(Phaze_Line), false); NullLine := TOrthoLine.create(Line_x1, Line_y1 - 20, 0, Line_x2, Line_y1 - 20, 0, 4, ord(psSolid), clBlack, 0, GCadForm.PCad.GetLayerHandle(0), mydsNormal, GCadForm.PCad, False, False); GCadForm.PCad.AddCustomFigure(1, TFigure(NullLine), false); GroundLine := TOrthoLine.create(Line_x1, Line_y1 + 20, 0, Line_x2, Line_y1 + 20, 0, 4, ord(psSolid), clRed, 0, GCadForm.PCad.GetLayerHandle(0), mydsNormal, GCadForm.PCad, False, False); GCadForm.PCad.AddCustomFigure(1, TFigure(GroundLine), false); } // Lines Count Line_Count := aSwitchList.Count; TextList := TStringList.Create; // фаза Phaze_Line := TLine.create(Line_x1, Line_y1, Line_x2, Line_y1, 3, ord(psSolid), clRed, 0, GCadForm.PCad.GetLayerHandle(0), mydsNormal, GCadForm.PCad); GCadForm.PCad.AddCustomFigure(1, TFigure(Phaze_Line), false); TextList.Clear; TextList.Add('L1 L2 L3'); CurrText := CreateTextObject(Line_x1 + 2, Line_y1 - 4, TextList, true); //ноль NullLine := TLine.create(Line_x1, Line_y1 + 5, Line_x2, Line_y1 + 5, 3, ord(psSolid), clBlue, 0, GCadForm.PCad.GetLayerHandle(0), mydsNormal, GCadForm.PCad); GCadForm.PCad.AddCustomFigure(1, TFigure(NullLine), false); TextList.Clear; TextList.Add('N'); CurrText := CreateTextObject(Line_x1 + 2, Line_y1 + 1, TextList, true); //земля GroundLine := TLine.create(Line_x1, Line_y1 + 10, Line_x2, Line_y1 + 10, 3, ord(psSolid), clBlack, 0, GCadForm.PCad.GetLayerHandle(0), mydsNormal, GCadForm.PCad); GCadForm.PCad.AddCustomFigure(1, TFigure(GroundLine), false); TextList.Clear; TextList.Add('PE'); CurrText := CreateTextObject(Line_x1 + 2, Line_y1 + 6, TextList, true); Line_y1 := Line_y1 + 70; TextFigList := TList.Create; TextList.Clear; TextList.Add(El_Mess1); CurrText := CreateTextObject(Line_x1 - 45, Line_y1 + 35, TextList); CurrText.Rotate(((-90)/180) * PI, CurrText.CenterPoint); //TextFigList.Add(CurrText); ColObjList := TList.Create; TextList.Clear; TextList.Add(El_Mess2); CurrText := CreateTextObject(Line_x1, Line_y1 + 10, TextList); TextFigList.Add(CurrText); TextList.Clear; TextList.Add(El_Mess3); CurrText := CreateTextObject(Line_x1, Line_y1 + 20, TextList); TextFigList.Add(CurrText); TextList.Clear; TextList.Add(El_Mess4); CurrText := CreateTextObject(Line_x1, Line_y1 + 30, TextList); TextFigList.Add(CurrText); TextList.Clear; TextList.Add(El_Mess5); CurrText := CreateTextObject(Line_x1, Line_y1 + 40, TextList); TextFigList.Add(CurrText); TextList.Clear; TextList.Add(El_Mess6); CurrText := CreateTextObject(Line_x1, Line_y1 + 50, TextList); TextFigList.Add(CurrText); TextList.Clear; TextList.Add(El_Mess7); CurrText := CreateTextObject(Line_x1, Line_y1 + 60, TextList); TextFigList.Add(CurrText); DownObjectList := TList.Create; DownObjectList.Add(TextFigList); // Line_x1, Line_y1, Line_x2, Line_y1 { Line_x2 := 0; for i := 1 to TextFigList.Count - 1 do begin if comparevalue(Line_x2, TFigure(TextFigList[i]).Ap2.x) = -1 then Line_x2 := TFigure(TextFigList[i]).Ap2.x; end; Line_x2 := Line_x2 + 3; Line_x1 := TFigure(TextFigList[1]).Ap1.x - 2; Line_y1 := TFigure(TextFigList[1]).Ap1.y - 2; Line_y2 := TFigure(TextFigList[1]).Ap1.y - 3; SLine := TLine.create(Line_x1, Line_y2, Line_x2, Line_y2, 2, ord(psSolid), clBlack, 0, GCadForm.PCad.GetLayerHandle(0), mydsNormal, GCadForm.PCad); GCadForm.PCad.AddCustomFigure(1, TFigure(SLine), false); for i := 1 to TextFigList.Count - 1 do begin Line_y2 := TFigure(TextFigList[i]).Ap4.y + 2; SLine := TLine.create(Line_x1, Line_y2, Line_x2, Line_y2, 2, ord(psSolid), clBlack, 0, GCadForm.PCad.GetLayerHandle(0), mydsNormal, GCadForm.PCad); GCadForm.PCad.AddCustomFigure(1, TFigure(SLine), false); end; SLine := TLine.create(TFigure(TextFigList[1]).Ap1.x - 2, TFigure(TextFigList[1]).Ap1.y - 3, TFigure(TextFigList[1]).Ap1.x - 2, Line_y2, 2, ord(psSolid), clBlack, 0, GCadForm.PCad.GetLayerHandle(0), mydsNormal, GCadForm.PCad); GCadForm.PCad.AddCustomFigure(1, TFigure(SLine), false); SLine := TLine.create(Line_x2, TFigure(TextFigList[1]).Ap1.y - 3, Line_x2, Line_y2, 2, ord(psSolid), clBlack, 0, GCadForm.PCad.GetLayerHandle(0), mydsNormal, GCadForm.PCad); GCadForm.PCad.AddCustomFigure(1, TFigure(SLine), false); } k := 0; GuidIconList := TStringList.Create; SwitchNames := TStringList.Create; LineCounter := 0; for i := 0 to aSwitchList.Count - 1 do begin Switches := TSCSComponents(aSwitchList[i]); for j := 0 to Switches.Count - 1 do // Автомат(линия) begin SwitchNames.Add(Switches[j].GetNameForVisible); ComponDrawFigure := nil; Line_x1 := Line_x2; Connections := TSCSComponents(aConnectedList[k]); ColObjList := TList.Create; TextList.Clear; inc(LineCounter); //получить угошку потребителя for l := 0 to Connections.Count - 1 do begin TextList.Add(Connections[l].NAme); if Connections[l].IsLine = biFalse then begin ParentCatalog := Connections[l].GetFirstParentCatalog; if ParentCatalog <> nil then begin ComponList := Connections[l].GetListOwner; if ComponList <> nil then begin ComponCad := GetListByID(ComponList.SCSID); if ComponCad <> nil then begin ComponFigure := GetFigureByID(ComponCad, ParentCatalog.SCSID); if ComponFigure <> nil then begin if ComponFigure is TConnectorObject then if TConnectorObject(ComponFigure).ConnectorType = ct_NB then if TConnectorObject(ComponFigure).DrawFigure <> nil then begin { DrawFigureStream := TMemoryStream.Create; TConnectorObject(ComponFigure).DrawFigure.WriteToStream(DrawFigureStream); DrawFigureStream.Position := 0; //ComponDrawFigure := TFigureGrpMod(TFigure(ComponDrawFigure).CreateFromStream(DrawFigureStream, GCadForm.PCad.GetLayerHandle(0),myDsNormal, GCadForm.PCad)); ComponDrawFigure := TFigureGrpMod(TFigure.CreateFromStream(DrawFigureStream, 0, myDsNormal, GCadForm.PCad)); GCadForm.PCad.AddCustomFigure(1, TFigure(ComponDrawFigure), False); ComponDrawFigure.Move(100, 100); } ComponDrawFigure := TFigureGrpMod(TConnectorObject(ComponFigure).DrawFigure.Duplicate); GCadForm.PCad.AddCustomFigure(1, TFigure(ComponDrawFigure), False); ColObjList.Add(ComponDrawFigure); break; end; end; end; end; end; end; end; if ComponDrawFigure = nil then ColObjList.Add(Nil); // если нет фигуры отрисовки ConnectedSwitchCompon := nil; if aCableList.Count >= k then ConnectedSwitchCompon := aCableList[k]; // номер линии TextList.Clear; TextList.Add(inttostr(LineCounter)); CurrText := CreateTextObject(1, 1, TextList); ColObjList.Add(CurrText); // Расчетная мощность, кВт' TextList.Clear; TextList.Add(inttostr(LineCounter)); CurrText := CreateTextObject(1, 1, TextList); ColObjList.Add(CurrText); // Расчетный ток, А TextList.Clear; TextList.Add(inttostr(LineCounter)); CurrText := CreateTextObject(1, 1, TextList); ColObjList.Add(CurrText); //Расчетный ток, А TextList.Clear; TextList.Add(inttostr(LineCounter)); CurrText := CreateTextObject(1, 1, TextList); ColObjList.Add(CurrText); // получить список нагрузок TextList.Free; TextList := GetComponNamesCounted(Connections); CurrText := CreateTextObject(1, 1, TextList); ColObjList.Add(CurrText); inc(k); DownObjectList.Add(ColObjList); end; end; if DownObjectList.Count > 0 then begin CountMaxValues(DownObjectList); DrawTable; end; SwitchNames.Free; AllChemeFiguresList.Free; GCadForm.PCad.Refresh; end; End; *) //Tolik 08/08/2019 -- {Procedure DrawGdiImage(agdigraphics: TGPGraphics; aGpImage: TGPImage; x, y, aWidth, aHeight : Integer); begin agdigraphics.SetInterpolationMode(InterpolationModeHighQualityBicubic); agdigraphics.DrawImage( aGpImage, Gdipapi.MakeRect(0, 0 , x, y), 0, 0, aWidth, aHeight, UnitPixel); end;} // // TODO 5: Пересмотреть где Figures.count используется через for в движке PowerCAD и по возможности юзать for // TODO 6: Учесть сорт список на undo/redo, копировании листа, дублировании объектов end.